AW: Ordnerverzeichnis durchsuchen und ausgeben
13.07.2018 08:08:20
JoWE
Hallo Andreas,
vllt. so, Der Code stammt von Ramses aus 2004 'glaub' ich'.
Das Makro fragt nach dem zu durchsuchenden Ordner:
Option explicit
'Dieser Bereich kann entfallen, wenn der Variable 'Laufwerk' ein fester Wert zugewiesen wird.#
Public 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
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private z!
'Ruft das Dialogfeld zur Ordnerauswahl auf
Function GetDirectory(Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
With bInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub Dateisuche(Laufwerk, Dateien)
Dim tmp, Wdhlg, Dateiname As String
On Error Resume Next
If Right(Laufwerk, 1) "\" Then Laufwerk = Laufwerk + "\"
tmp = Dir(Laufwerk & Dateien)
Cells(5, 1).Value = "Pfad"
Cells(5, 2).Value = "Dateiname"
Cells(5, 3).Value = "Größe"
Cells(5, 4).Value = "Dateidatum"
Range(Cells(5, 1), Cells(5, 4)).Font.Bold = True
Columns("3:3").NumberFormat = "0"
Do While Len(tmp)
Dateiname = Laufwerk & tmp
Application.StatusBar = Dateiname
Cells(z, 1).Select
Cells(z, 1) = Laufwerk
Cells(z, 2) = tmp
Cells(z, 3) = FileLen(Laufwerk & tmp)
Cells(z, 4) = FileDateTime(Laufwerk & tmp)
z = z + 1
tmp = Dir()
Loop
tmp = Dir(Laufwerk, vbDirectory)
Do While Len(tmp)
If (tmp ".") And (tmp "..") Then
If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then
Dateisuche Laufwerk & tmp, Dateien
z = z - 1
Wdhlg = Dir(Laufwerk, vbDirectory)
z = z + 1
Do While Wdhlg tmp
Wdhlg = Dir()
Loop
End If
End If
tmp = Dir()
Loop
On Error GoTo 0
Cells.EntireColumn.AutoFit
Application.StatusBar = False
End Sub
'Aufruf mit dem folgenden Makro
Sub Dateien_auflisten()
Dim Laufwerk$, Dateien$
'Erste Zeile, in der eine Eintragung erfolgt
z = 6
'Alte Eintragungen löschen
Cells.Clear
'Den Variablen Laufwerk und Dateien kann auch ein direkter Wert zugewiesen werden.
Laufwerk = GetDirectory("Bitte einen Ordner wählen") 'Ersatz: ... = "C:\Eigene Dateien"
If Laufwerk = "" Then Exit Sub
'Ersatz: Dateien = "*.*"
Dateien = InputBox("Nach welchen Dateien soll in" & Chr(10) & " " & _
Laufwerk & Chr(10) & "gesucht werden (z. B. *.xls)?", "Dateityp", "*.*")
If Dateien = "" Then Exit Sub
Dateisuche Laufwerk, Dateien
End Sub
Gruß
Jochen