Hallo Zusammen,
[
attachment=43421]
Ich brauche ein Datenbank dass alle Ordner und dessen Inhalte in einem Verzeichnis und gespeichert am + deren Besitzerinformationen in ein Excel File ausgibt
aber bei der Besitzer komme ich nicht klar.
Ich habe ein Code gefunden aber ich weiß es nicht wohin ich diesen Code hinzufügen soll oder welche Alternativen gibt es noch?
mit freundlichen Grüßen
Sollen wir den Text nun abtippen um ihn zu prüfen?
Oder das hochgeladene Bild mit Photoshop bearbeiten?
Ja Hast du recht
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
Besitzer = objFolder.GetDetailsOf(datei, 5)
i = 1 + Cells(Rows.Count, 1).End(xlUp).Row das habe ich neu hinzugefügt
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)
TB2.Cells(i, 5) =
TB2.Cells(i, 6) = Mid(Besitzer, 5, (Len(Besitzer) - 4))
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
ich muss sozusagen den Besitzer auch abrufen für jede Dateien
Hallo
leider stürzt excel bei mir ab.
Aber aus
Besitzer = objFolder.GetDetailsOf(datei, 5)
mache mal
Besitzer = fs.GetDetailsOf(Name1, 5)
Ausserdem fehlt was hinter
TB2.Cells(i, 5) =""
Hat leider nicht geklappt
Hallöchen,
wann setzt Du eigentlich die Variable objfolder? Ich sehe nur Set f ...
Schaue Dir dazu auch mal das Script-Beispiel von Microsoft an,
win32-shell-folder-getdetailsof