Új hozzászólás Aktív témák

• #129 jeges senior tag workman #128

  Új Válasz 2005-07-01 06:53:16 #129

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  jeges

  senior tag

  válasz workman #128 üzenetére

  kicsit hosszadalmas a dolog, van egy külön modul, amit be köll építeni az adatbázisba, de asszem betolom ide, mer' nekem pl. qrva sok melómba került, míg megtaláltam (nagy részét nem én csináltam, de nagyon hasznos kis util)
  
  szóval, az alábbit be köll másolni egy külön modulba (akármilyen néven)
  
  Option Compare Database
  
  Const ALLFILES = ''All Files''
  
  Const OFN_ALLOWMULTISELECT = &H200
  Const OFN_CREATEPROMPT = &H2000
  Const OFN_EXPLORER = &H80000
  Const OFN_FILEMUSTEXIST = &H1000
  Const OFN_HIDEREADONLY = &H4
  Const OFN_NOCHANGEDIR = &H8
  Const OFN_NODEREFERENCELINKS = &H100000
  Const OFN_NONETWORKBUTTON = &H20000
  Const OFN_NOREADONLYRETURN = &H8000
  Const OFN_NOVALIDATE = &H100
  Const OFN_OVERWRITEPROMPT = &H2
  Const OFN_PATHMUSTEXIST = &H800
  Const OFN_READONLY = &H1
  Const OFN_SHOWHELP = &H10
  Declare Function GetOpenFileName Lib ''comdlg32.dll'' Alias _
  ''GetOpenFileNameA'' (pOpenfilename As OPENFILENAME) As Boolean
  
  Type MSA_OPENFILENAME
  ' Filter string used for the Open dialog filters.
  ' Use MSA_CreateFilterString() to create this.
  ' Default = All Files, *.*
  strFilter As String
  ' Initial Filter to display.
  ' Default = 1.
  lngFilterIndex As Long
  ' Initial directory for the dialog to open in.
  ' Default = Current working directory.
  strInitialDir As String
  ' Initial file name to populate the dialog with.
  ' Default = ''''.
  strInitialFile As String
  strDialogTitle As String
  ' Default extension to append to file if user didn't specify one.
  ' Default = System Values (Open File, Save File).
  strDefaultExtension As String
  ' Flags (see constant list) to be used.
  ' Default = no flags.
  lngFlags As Long
  ' Full path of file picked. When the File Open dialog box is
  ' presented, if the user picks a nonexistent file,
  ' only the text in the ''File Name'' box is returned.
  strFullPathReturned As String
  ' File name of file picked.
  strFileNameReturned As String
  ' Offset in full path (strFullPathReturned) where the file name
  ' (strFileNameReturned) begins.
  intFileOffset As Integer
  ' Offset in full path (strFullPathReturned) where the file extension begins.
  intFileExtension As Integer
  End Type
  
  Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As Long
  nMaxCustrFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  Flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustrData As Long
  lpfnHook As Long
  lpTemplateName As Long
  End Type
  
  Function ListDir(strParent As String, Optional intAttr As Integer, Optional strSeparator As String) As String
  
  'Funkció: az strParent könyvtár tartalmát listaszerűen, strSeparator karakterrel elválasztva adja meg.
  'Amennyiben strSeparator-t nem adjuk meg, az '';'' (pontosvessző)
  'Megadhatjuk még a listában látni akart állományok attribútumát, a Dir függvény szerint.
  '(Ezt az intAttr változóban adjuk meg)
  
  Dim i As Boolean, j As Integer, k As Integer
  Dim strSubDir As String
  Dim strSubDir_All As String
  Dim strSep As String
  
  'Dim strFile As String
  
  If Right(strParent, 1) <> ''\'' Then
  strParent = strParent & ''\''
  End If
  
  ChDir strParent
  
  If Not IsNull(intAttr) Then
  j = intAttr
  Else
  j = 1000
  End If
  
  strSubDir_All = ''''
  
  If Not (IsNull(strSeparator) Or strSeparator = '''') Then
  strSep = strSeparator
  Else
  strSep = '';''
  End If
  
  If j <> 1000 Then
  strSubDir = Dir(strParent & ''*'', j) ' Retrieve the first entry.
  Else
  strSubDir = Dir(strParent & ''*'')
  End If
  
  'If IsNull(intAttr) Then
  ' intAttr = 1000
  'End If
  
  Do While strSubDir <> '''' ' Start the loop.
  ' Ignore the current directory and the encompassing directory.
  If strSubDir <> ''.'' Then
  Select Case j
  Case 1000
  i = True
  Case 16
  k = GetAttr(strParent & ''\'' & strSubDir)
  On Error Resume Next
  If k > 31 Then
  Do Until k < 32
  k = k - 32
  Loop
  End If
  If k > 15 Then
  i = True
  Else
  i = False
  End If
  Case Else
  k = GetAttr(strParent & ''\'' & strSubDir)
  On Error Resume Next
  If k > 31 Then
  Do Until k < 32
  k = k - 32
  Loop
  End If
  If k < 16 Then
  i = True
  Else
  i = False
  End If
  ' k = GetAttr(strParent & ''\'' & strSubDir)
  ' If k > (2 * j - 1) Then
  ' Do Until k < (2 * j)
  ' k = k - (2 * j)
  ' Loop
  ' End If
  
  ' If (k > (j - 1)) Or (k = 0) Then
  ' i = True
  ' Else
  ' i = False
  ' End If
  End Select
  
  If i Then
  If strSubDir_All = '''' Then
  strSubDir_All = strSubDir '& strSep & GetAttr(strParent & ''\'' & strSubDir)
  Else
  strSubDir_All = strSubDir_All & strSep & strSubDir '& strSep & GetAttr(strParent & ''\'' & strSubDir)
  End If
  End If
  
  End If
  strSubDir = Dir() ' Get next entry.
  Loop
  
  ListDir = strSubDir_All
  
  End Function
  
  'Ha attribútumot is megadtunk:
  ' If (intAttr = 0) Then
  ' If GetAttr(strParent & ''\'' & strSubDir) = intAttr Then
  ' If strSubDir_All = '''' Then
  ' strSubDir_All = strSubDir
  ' Else
  ' strSubDir_All = strSubDir_All + strSep + strSubDir
  ' End If
  ' End If ' it represents a directory.
  ' 'Ha attribútumot nem adtunk meg:
  ' ElseIf strSubDir_All = '''' Then
  ' strSubDir_All = strSubDir
  ' Else
  ' strSubDir_All = strSubDir_All + strSep + strSubDir
  ' End If
  ' End If
  
  
  Function FindFile(strSearchPath) As String
  ' Displays the Open dialog box for the user to locate
  ' the Northwind database. Returns the full path to Northwind.
  
  Dim msaof As MSA_OPENFILENAME
  
  ' Set options for the dialog box.
  msaof.strDialogTitle = ''Jelölje ki a kívánt fájlt!''
  msaof.strInitialDir = strSearchPath
  msaof.strFilter = MSA_CreateFilterString(''All files'', ''*.*'')
  
  ' Call the Open dialog routine.
  MSA_GetOpenFileName msaof
  
  ' Return the path and file name.
  FindFile = Trim(msaof.strFullPathReturned)
  
  End Function
  
  
  Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
  ' Creates a filter string from the passed in arguments.
  ' Returns '''' if no argumentss are passed in.
  ' Expects an even number of argumentss (filter name, extension), but
  ' if an odd number is passed in, it appends ''*.*''.
  
  Dim strFilter As String
  Dim intRet As Integer
  Dim intNum As Integer
  
  intNum = UBound(varFilt)
  If (intNum <> -1) Then
  For intRet = 0 To intNum
  strFilter = strFilter & varFilt(intRet) & vbNullChar
  Next
  If intNum Mod 2 = 0 Then
  strFilter = strFilter & ''*.*'' & vbNullChar
  End If
  
  strFilter = strFilter & vbNullChar
  Else
  strFilter = ''''
  End If
  
  MSA_CreateFilterString = strFilter
  End Function
  
  Function MSA_ConvertFilterString(strFilterIn As String) As String
  ' Creates a filter string from a bar (''|'') separated string.
  ' The string should pairs of filter|extension strings, i.e. ''Access Databases|*.mdb|All Files|*.*''
  ' If no extensions exists for the last filter pair, *.* is added.
  ' This code will ignore any empty strings, i.e. ''||'' pairs.
  ' Returns '''' if the strings passed in is empty.
  
  
  Dim strFilter As String
  Dim intNum As Integer, intPos As Integer, intLastPos As Integer
  
  strFilter = ''''
  intNum = 0
  intPos = 1
  intLastPos = 1
  
  ' Add strings as long as we find bars.
  ' Ignore any empty strings (not allowed).
  Do
  intPos = InStr(intLastPos, strFilterIn, ''|'')
  If (intPos > intLastPos) Then
  strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
  intNum = intNum + 1
  intLastPos = intPos + 1
  ElseIf (intPos = intLastPos) Then
  intLastPos = intPos + 1
  End If
  Loop Until (intPos = 0)
  
  ' Get last string if it exists (assuming strFilterIn was not bar terminated).
  intPos = Len(strFilterIn)
  If (intPos >= intLastPos) Then
  strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
  intNum = intNum + 1
  End If
  
  ' Add *.* if there's no extension for the last string.
  If intNum Mod 2 = 1 Then
  strFilter = strFilter & ''*.*'' & vbNullChar
  End If
  
  ' Add terminating NULL if we have any filter.
  If strFilter <> '''' Then
  strFilter = strFilter & vbNullChar
  End If
  
  MSA_ConvertFilterString = strFilter
  End Function
  
  Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
  ' Opens the Open dialog.
  
  Dim of As OPENFILENAME
  Dim intRet As Integer
  
  MSAOF_to_OF msaof, of
  intRet = GetOpenFileName(of)
  If intRet Then
  OF_to_MSAOF of, msaof
  End If
  MSA_GetOpenFileName = intRet
  End Function
  
  Function MSA_SimpleGetOpenFileName() As String
  ' Opens the Open dialog with default values.
  
  Dim msaof As MSA_OPENFILENAME
  Dim intRet As Integer
  Dim strRet As String
  
  intRet = MSA_GetOpenFileName(msaof)
  If intRet Then
  strRet = msaof.strFullPathReturned
  End If
  
  MSA_SimpleGetOpenFileName = strRet
  End Function
  
  Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
  ' This sub converts from the Win32 structure to the Microsoft Access structure.
  
  msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
  msaof.strFileNameReturned = of.lpstrFileTitle
  msaof.intFileOffset = of.nFileOffset
  msaof.intFileExtension = of.nFileExtension
  End Sub
  
  Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
  ' This sub converts from the Microsoft Access structure to the Win32 structure.
  
  Dim strFile As String * 512
  
  ' Initialize some parts of the structure.
  of.hwndOwner = Application.hWndAccessApp
  of.hInstance = 0
  of.lpstrCustomFilter = 0
  of.nMaxCustrFilter = 0
  of.lpfnHook = 0
  of.lpTemplateName = 0
  of.lCustrData = 0
  
  If msaof.strFilter = '''' Then
  of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
  Else
  of.lpstrFilter = msaof.strFilter
  End If
  of.nFilterIndex = msaof.lngFilterIndex
  
  of.lpstrFile = msaof.strInitialFile _
  & String(512 - Len(msaof.strInitialFile), 0)
  of.nMaxFile = 511
  
  of.lpstrFileTitle = String(512, 0)
  of.nMaxFileTitle = 511
  
  of.lpstrTitle = msaof.strDialogTitle
  
  of.lpstrInitialDir = msaof.strInitialDir
  
  of.lpstrDefExt = msaof.strDefaultExtension
  
  of.Flags = msaof.lngFlags
  
  of.lStructSize = Len(of)
  End Sub
  
  
  innentől ha vmelyik formon csinálsz egy nyomógombot, a köv. kóddal tudsz tallózni:
  
  
  Private Sub Command3_Click()
  
  Me.TextBox0 = FindFile(''C:\'')
  
  End Sub
  
  
  a fentiben ''TextBox0'' egy sima textbox (nahát ) a formon, amibe visszaírja a tallózás eredményeként kapott állomány elérési útvonalát és nevét
  
  nem állítom, h minden környezetben működik, de nekem többféle win/office kombinációval jól működött

Új hozzászólás Aktív témák