AW: VBA: Datei suchen (inkl. Unterordner)
02.10.2012 11:50:51
Tino
Hallo,
hier mal eine Variante.
Eventuell die Tabelle und den Pfad anpassen.
Bin davon ausgegangen, dass die ID ab A2 aufgelistet sind und in A1 die Überschrift steht.
Ergebnis wird als Funktion (Hyperlink) in Spalte B geschrieben.
kommt als Code in Modul1
Option Explicit
Sub Start()
Dim strFolder$, ArFileFilter()
Dim nCount&, lngFileCount&
Dim ArrayData(), ArrayFile(), sFile$
strFolder = "G:\VBA" 'Ordner angeben
With Tabelle1 'Tabelle anpassen
.Range("B2", .Cells(.Rows.Count, 2)).Clear 'Daten Spalte B löschen
nCount = .Cells(.Rows.Count, 1).End(xlUp).Row
If nCount < 2 Then Exit Sub 'keine Daten in Tabelle
ArrayData = .Range("A2", .Cells(nCount, 1))
strFolder = IIf(Right$(strFolder, 1) = "\", strFolder, strFolder & "\")
For nCount = 1 To Ubound(ArrayData)
If ArrayData(nCount, 1) <> "" Then
ArFileFilter = Array(ArrayData(nCount, 1) & "*.*") 'Filter für die Suche
'Suchen mit Unterordner sonst SubFolder = False
FindFiles ArrayFile, strFolder, lngFileCount, ArFileFilter, True
End If
If lngFileCount > 0 Then
'nur erste gefundene Datei Listen
sFile = ArrayFile(0)
'Hyperlink erstellen
ArrayData(nCount, 1) = _
"=HYPERLINK(""" & sFile & """,""" & Right$(sFile, Len(sFile) - InStrRev(sFile, "\")) & """)"
lngFileCount = 0
Else
ArrayData(nCount, 1) = "nix gefuden"
End If
Next nCount
.Range("B2").Resize(Ubound(ArrayData), 1).FormulaR1C1 = ArrayData
End With
Erase ArrayData
End Sub
kommt als Code in Modul2
Option Explicit
'Teile des Originalcode von Nepumuk. ***********************************************************
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 Const INVALID_HANDLE_VALUE = -1&
Private Const MAX_PATH = 260&
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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 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
Sub FindFiles(ArrayData(), ByVal strFolderPath As String, _
ByRef lngFileCount As Long, ArFileFilter, Optional SubFolder As Boolean = True)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
GetFilesInFolder ArrayData, strFolderPath, lngFileCount, ArFileFilter
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
If SubFolder = False Then Exit Sub 'ohne Unterordner
If (strDirName <> ".") And (strDirName <> "..") Then _
FindFiles ArrayData, strFolderPath & strDirName & "\", lngFileCount, ArFileFilter
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
End Sub
Sub GetFilesInFolder(ArrayData(), ByVal strFolderPath As String, _
ByRef lngFileCount As Long, ArFileFilter)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String
Dim FileFilter
For Each FileFilter In ArFileFilter
lngSearch = FindFirstFile(strFolderPath & FileFilter, 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)
Redim Preserve ArrayData(lngFileCount)
ArrayData(lngFileCount) = strFolderPath & strFileName 'auflisten in Zelle
lngFileCount = lngFileCount + 1
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
Next
End Sub
Gruß Tino