Option Explicit
' Typdeklaration für API-Dialog->Verzeichnis auswählen'
Private Type BrowseInfo
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long
' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
Public Function VerzeichnisWählen(Optional DialogTitel) As String
Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
Dim hWndAccessApp As Long
With StrukturVerzeichnisInfo
.hOwner = hWndAccessApp
.lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
.ulFlags = &H1-> BIF_RETURNONLYFSDIRS
End With
ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
Pfad = Space$(512)
If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWählen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
End Function
Public Sub FilesAusVerzeichnisInTabellenblatt()
'Makro zum Auflisten der Files eines Directories
'Die Ausgabe erfolgt in einem neu angelegten Blatt
'a) mit Auswahl des Pfades
'b) mit Abfrage des Filters für Dateinamen (z.B. ATI*.SYS)
'c) mit Auswahl Ausgabe mit komplettem Pfad oder nur Dateiname
'd) der Dateiname des aktuellen Dokumentes wird in der Ausgabe unterdrückt
Dim ws As Worksheet
Dim fs As FileSearch
Dim i As Long, z As Long
Dim sPath As String, sname As String, s_tmp As String, sSuchpfad As String, sFilename As String
Dim b_mitPfadangabe ->True= Dokument mit Pfadangabe , false=ohne
Dim ret As Integer
-> Auswahl des Pfades
sSuchpfad = VerzeichnisWählen(Bitte wählen Sie das Verzeichnis)
If sSuchpfad = Then
ret = MsgBox(Es wurde kein Suchpfad eingegeben ! & vbCrLf & Der Makro wird beendet., _
vbOKOnly + vbInformation, Kein Suchpfad ausgewählt)
Else
->Wahl: Ausgabe mit Pfadnamen oder ohne
ret = MsgBox(Wollen Sie die Ausgabe der Filenamen mit komplettem Pfad ?, _
vbQuestion + vbYesNo, Auswahl Pfad: komplett <> nur filename)
If ret = vbYes Then
b_mitPfadangabe = True
Else
b_mitPfadangabe = False
End If
->Wahl: Filename
sFilename = InputBox(Geben Sie bitte den Filter für Filenamen ein !, Eingabe Filter Filname, *.xls)
If sFilename = Then sFilename = *.*
sPath = ActiveWorkbook.Path->Pfad des Dokuments
sname = ActiveWorkbook.Name->Name des Dokuments
->neues Blatt anlegen
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set ws = Worksheets(Worksheets.Count)
->Zeilenzähler für nächsten Eintrag initialisieren
z = 1
->Überschrift
ws.Cells(z, 1).Value = folgende Dokumente befinden sich im Pfad & sSuchpfad
ws.Cells(z, 1).Font.Bold = True
z = z + 2->Zeilenzaehler für naechsten Eintrag erhöhen
ws.Cells(z, 1).Value = Filenamen
ws.Cells(z, 1).Font.Bold = True
z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
->Filenamen aus dem Directory sPath auflisten
Set fs = Application.FileSearch
With fs
.NewSearch
.LookIn = sSuchpfad
.FileName = sFilename
i = .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending)
If .FoundFiles.Count > 0 Then
For i = 1 To .FoundFiles.Count
If .FoundFiles(i) <> (sPath & \ & sname) Then->nicht dieses Dokument
s_tmp = .FoundFiles(i)
If b_mitPfadangabe Then
ws.Cells(z, 1).Value = s_tmp->mit Pfad
Else
ws.Cells(z, 1).Value = NurFilenamen(s_tmp)->ohne Pfad
End If
z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
End If
Next i
Else
ws.Cells(z, 1).Value = kein File vorhanden !!!
MsgBox Keine Dokumente gefunden
End If
End With
ws.Columns(1).AutoFit
End If
End Sub
Private Function NurFilenamen(s_vollstaendigerFilename As String) As String
'schneidet die Pfadangaben aus einem String und gibt den Filenamen zurueck
Dim p1 As Integer, p2 As Integer
p2 = 0: p1 = 0
Do
p1 = InStr(p1 + 1, s_vollstaendigerFilename, \)
If p1 <> 0 Then p2 = p1
Loop While p1 <> 0
NurFilenamen = Right(s_vollstaendigerFilename, Len(s_vollstaendigerFilename) - p2)
End Function
