AW: VBA: Pfad einer gesuchten Datei
28.12.2007 09:59:13
Christian
Hallo,
hier eine sehr effiziente Variante von Nepumuk.
Den Pfad auszuschneiden dürfte ja kein Problem sein.
Gruß
Christian
Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" ( _
ByVal hFindFile As Long) As Long
Private Enum FILE_ATTRIBUTE
FILE_ATTRIBUTE_READONLY = &H1
FILE_ATTRIBUTE_HIDDEN = &H2
FILE_ATTRIBUTE_SYSTEM = &H4
FILE_ATTRIBUTE_DIRECTORY = &H10
FILE_ATTRIBUTE_ARCHIVE = &H20
FILE_ATTRIBUTE_NORMAL = &H80
FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum
Private Const INVALID_HANDLE_VALUE = -1&
Private Const MAX_PATH = 260&
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Public Sub start()
Dim myFileSystemObject As Object, myDrive As Object
Dim lngFilecount As Long
Application.ScreenUpdating = False
Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
lngFilecount = 0
Columns(1).ClearContents
For Each myDrive In myFileSystemObject.Drives
If myDrive.IsReady Then
FindFiles myDrive.DriveLetter & ":\", "Mappe1.xls", lngFilecount
End If
Next
Set myFileSystemObject = Nothing
Columns(1).AutoFit
Application.ScreenUpdating = True
End Sub
Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String, _
ByRef lngFilecount As Long)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
If lngSearch INVALID_HANDLE_VALUE Then
GetFilesInFolder strFolderPath, strSearch, lngFilecount
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
If (strDirName ".") And (strDirName "..") Then _
FindFiles strFolderPath & strDirName & "\", strSearch, lngFilecount
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String, _
ByRef lngFilecount As Long)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String
lngSearch = FindFirstFile(strFolderPath & strSearch, WFD)
If lngSearch INVALID_HANDLE_VALUE Then
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
FILE_ATTRIBUTE_DIRECTORY Then
strFileName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
lngFilecount = lngFilecount + 1
Cells(lngFilecount, 1) = strFolderPath & strFileName
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
End Sub