23.05.2022, 13:54
es wird hier alle Ordner und dessen Inhalte in einem Verzeichnis und gespeichert am + deren Besitzerinformationen in ein Excel File ausgibt aber bei der Besitzer erlebe ich Probleme. Wie kann man hier den Besitzer abrufen?
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
Sub Verzeichnisse_auflisten()
Dim Pfad1, Name1, Anzahl, X, X0, X1, X2, Verz, Anzverz, Größe, Besitzer
Dim TB1, TB2 As Worksheet
Dim msg As String
Set TB1 = ThisWorkbook.Worksheets(1)
Set TB2 = ThisWorkbook.Worksheets(2)
start = Now
TB1.[a:D] = ""
TB2.[a:D] = ""
'überflüssige Tabellenblätter löschen
If ThisWorkbook.Worksheets.Count > 2 Then
Application.DisplayAlerts = False
For X = 3 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(3).Delete
Next X
Application.DisplayAlerts = True
End If
' Pfad abfragen
msg = "Wählen Sie bitte einen Ordner aus:"
Pfad1 = getdirectory(msg)
If Pfad1 = "" Then Exit Sub
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
TB1.[a2] = Pfad1
Anzahl = 2
TB1.[a1] = "Pfad"
TB1.[b1] = "UnterVerz."
TB1.[c1] = "Anz. Dateien"
TB1.[d1] = "Datgröße in Verz."
X0 = 2
X1 = 2
Do While TB1.Cells(Rows.Count, 1).End(xlUp).Row <> TB1.Cells(Rows.Count, 2).End(xlUp).Row
For X2 = X0 To X1
Pfad1 = TB1.Cells(X2, 1) ' Pfad setzen.
If Right(Pfad1, 1) <> "\" Then Pfad1 = Pfad1 & "\"
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
Verz = 0
Do While Name1 <> "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If Name1 <> "." And Name1 <> ".." Then
' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein
' Verzeichnis ist.
If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then
Anzahl = Anzahl + 1
TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & "\"
Verz = Verz + 1
'Eintrag nur anzeigen, wenn es sich um ein Verzeichnis handelt.
End If
End If
Name1 = Dir ' Nächsten Eintrag abrufen.
Loop
TB1.Cells(X2, 2) = Verz
Next X2
X0 = X1 + 1
X1 = X2
Loop
'Dateien aus den Verzeichnissen auslesen
Anzverz = TB1.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
ii = 0
For Verz = 2 To Anzverz
Anzahl = 0
Größe = 0
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(TB1.Cells(Verz, 1))
Set fc = f.Files
For Each f1 In fc
If i = 65536 Then
ii = ii + 1
ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
ThisWorkbook.Worksheets(ii + 2).Name = "Dateien " & ii + 1
Set TB2 = ThisWorkbook.Worksheets(ii + 2)
i = 1
End If
i = i + 1
Anzahl = Anzahl + 1
TB2.Cells(i, 1) = f1.Name
TB2.Cells(i, 2) = f & "\" & f1.Name
'Hyperlink auf die Datei einfügen
TB2.Hyperlinks.Add Anchor:=TB2.Cells(i, 2), Address:= _
f & "\" & f1.Name
TB2.Cells(i, 3) = FileLen(f1)
TB2.Cells(i, 4) = FileDateTime(f1)
Größe = Größe + FileLen(f1)
Next
TB1.Cells(Verz, 3) = Anzahl
TB1.Cells(Verz, 4) = Größe / 1024 / 1024
Next Verz
'MsgBox (ii * 65536) + i
Sheets("Dateien 1").Range("A2") = "DATEI"
Sheets("Dateien 1").Range("B2") = "PFAD"
Sheets("Dateien 1").Range("C2") = "Volumen"
Sheets("Dateien 1").Range("D2") = "Gespeichert am"
Sheets("Dateien 1").Range("E2") = "Ersteller"
ende = Now
MsgBox "Anzahl der Verzeichnisse: " & Verz & Chr(13) & _
"Anzahl der Dateien: " & (ii * 65536) + i & Chr(13) & _
Chr(13) & "Dauer: " & Format(ende - start, "nn:ss")
End Sub
' Muß erwähnt sein: Diese Funktion stammt nicht von mir.
' Die Quelle ist mir nicht mehr bekannt.
Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, X As Long, pos As Integer
' Ausgangsordner = Desktop
bInfo.pidlRoot = 0&
' Dialogtitel
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
' Rückgabe des Unterverzeichnisses
bInfo.ulFlags = &H1
' Dialog anzeigen
X = SHBrowseForFolder(bInfo)
' Ergebnis gliedern
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
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
Sub Verzeichnisse_auflisten()
Dim Pfad1, Name1, Anzahl, X, X0, X1, X2, Verz, Anzverz, Größe, Besitzer
Dim TB1, TB2 As Worksheet
Dim msg As String
Set TB1 = ThisWorkbook.Worksheets(1)
Set TB2 = ThisWorkbook.Worksheets(2)
start = Now
TB1.[a:D] = ""
TB2.[a:D] = ""
'überflüssige Tabellenblätter löschen
If ThisWorkbook.Worksheets.Count > 2 Then
Application.DisplayAlerts = False
For X = 3 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(3).Delete
Next X
Application.DisplayAlerts = True
End If
' Pfad abfragen
msg = "Wählen Sie bitte einen Ordner aus:"
Pfad1 = getdirectory(msg)
If Pfad1 = "" Then Exit Sub
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
TB1.[a2] = Pfad1
Anzahl = 2
TB1.[a1] = "Pfad"
TB1.[b1] = "UnterVerz."
TB1.[c1] = "Anz. Dateien"
TB1.[d1] = "Datgröße in Verz."
X0 = 2
X1 = 2
Do While TB1.Cells(Rows.Count, 1).End(xlUp).Row <> TB1.Cells(Rows.Count, 2).End(xlUp).Row
For X2 = X0 To X1
Pfad1 = TB1.Cells(X2, 1) ' Pfad setzen.
If Right(Pfad1, 1) <> "\" Then Pfad1 = Pfad1 & "\"
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
Verz = 0
Do While Name1 <> "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If Name1 <> "." And Name1 <> ".." Then
' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein
' Verzeichnis ist.
If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then
Anzahl = Anzahl + 1
TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & "\"
Verz = Verz + 1
'Eintrag nur anzeigen, wenn es sich um ein Verzeichnis handelt.
End If
End If
Name1 = Dir ' Nächsten Eintrag abrufen.
Loop
TB1.Cells(X2, 2) = Verz
Next X2
X0 = X1 + 1
X1 = X2
Loop
'Dateien aus den Verzeichnissen auslesen
Anzverz = TB1.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
ii = 0
For Verz = 2 To Anzverz
Anzahl = 0
Größe = 0
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(TB1.Cells(Verz, 1))
Set fc = f.Files
For Each f1 In fc
If i = 65536 Then
ii = ii + 1
ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
ThisWorkbook.Worksheets(ii + 2).Name = "Dateien " & ii + 1
Set TB2 = ThisWorkbook.Worksheets(ii + 2)
i = 1
End If
i = i + 1
Anzahl = Anzahl + 1
TB2.Cells(i, 1) = f1.Name
TB2.Cells(i, 2) = f & "\" & f1.Name
'Hyperlink auf die Datei einfügen
TB2.Hyperlinks.Add Anchor:=TB2.Cells(i, 2), Address:= _
f & "\" & f1.Name
TB2.Cells(i, 3) = FileLen(f1)
TB2.Cells(i, 4) = FileDateTime(f1)
Größe = Größe + FileLen(f1)
Next
TB1.Cells(Verz, 3) = Anzahl
TB1.Cells(Verz, 4) = Größe / 1024 / 1024
Next Verz
'MsgBox (ii * 65536) + i
Sheets("Dateien 1").Range("A2") = "DATEI"
Sheets("Dateien 1").Range("B2") = "PFAD"
Sheets("Dateien 1").Range("C2") = "Volumen"
Sheets("Dateien 1").Range("D2") = "Gespeichert am"
Sheets("Dateien 1").Range("E2") = "Ersteller"
ende = Now
MsgBox "Anzahl der Verzeichnisse: " & Verz & Chr(13) & _
"Anzahl der Dateien: " & (ii * 65536) + i & Chr(13) & _
Chr(13) & "Dauer: " & Format(ende - start, "nn:ss")
End Sub
' Muß erwähnt sein: Diese Funktion stammt nicht von mir.
' Die Quelle ist mir nicht mehr bekannt.
Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, X As Long, pos As Integer
' Ausgangsordner = Desktop
bInfo.pidlRoot = 0&
' Dialogtitel
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
' Rückgabe des Unterverzeichnisses
bInfo.ulFlags = &H1
' Dialog anzeigen
X = SHBrowseForFolder(bInfo)
' Ergebnis gliedern
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