Ordner Eigenschaften

Question

Hallo Zusammen
Ich hätte eine Frage an das Forum und bräuchte Eure HILFE,
wie kann man mit einem Makro die Eigenschaften eines Ordners anzeigen lassen
und die WERTE in verschiedene Zellen in Excel eintragen lassen
( Größe, Größe auf Datenträger, Inhalt Dateien, Inhalt ALLER Ordner - auch
Unterorder - genauso als wenn man mit der rechten Maustaste einen Ordner anwählt
und auf Eigenschaften klickt und zu sehen bekommt )
Die Pfadangabe sollte im Makro frei wählbar sein.
Ich habe Windows 7 und Excel 2010

Vielen Dank schon mal im Voraus
Gruß Peter

Answer 1

Hallo Piedro,

klingt für mich nach nem typischen Fall für das Scripting.FilesystemObject.

Sub ShowFolderInfo()

Dim fs, fld, fls, sz

Pfad = "C:\Program Files (x86)\Microsoft Office\Office12"

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Pfad)
sz = f.Size
Set fls = f.Files
For Each fl In fls
flist = flist & fl.Name & Chr(13)
Next fl

MsgBox "Ordnergröße " & Application.RoundDown(sz / 1024 ^ 2, 1) _
& "MB" & Chr(13) & flist

End Sub

Vor zwei Jahren habe ich damit mal testweise versucht, den Explorer ins Excel zu bekommen. Leider sind in Excel aber nur die ersten 8 Ordnerebenen gruppierbar.

Achtung, bei sehr vielen Dateien, kann es ein paar Minuten dauern bis das Makro durchgelaufen ist. Am besten du führst das Makro über Ansicht, Makro, Makro ausführen aus. Dann siehst du auf der Statusleiste den aktuell durchsuchten Ordner.

Hier mein Code.

Sub DateiListe2()

'Übersichtlicher, funktioniert noch besser
Dim sz As Double

ShowFilesize = True


ActiveSheet.Outline.SummaryRow = xlAbove

On Error GoTo Fehler:

Columns("A:BZ").ColumnWidth = 3

Pfad = InputBox("Geben Sie einen Pfad ein für den Sie Unterordner und Dateien anzeigen wollen", "DateListeErstellen", "C:\")

zei = 1: eb = 1
Cells(zei, eb) = Pfad
Cells(zei, eb).Font.Bold = True

Set fs = CreateObject("Scripting.FileSystemObject")
pd = Pfad

Neu:
sf = 0
Set fld = fs.getfolder(pd)

fnr = 1
For Each sfld In fld.subfolders
sf = sf + 1
If InStr(1, FTest, sfld.Path + ";") = 0 Then
FTest = FTest + sfld.Path + ";"
zei = zei + 1: eb = eb + 1
' Stop

fnr = 2
Set fds = fs.getfolder(sfld.Path & "\")
fnm = fds.Name
sz = fds.Size
szt = Byteunit(fds.Size)

With Cells(zei, eb)
.Value = sfld.Name & "\ [" & szt & "]"
.Font.Bold = True
'Range(Cells(zei, 1), Cells(zei, eb)).Borders(xlInsideVertical).LineStyle = xlHairline
End With
If eb <= 8 Then Rows(zei).OutlineLevel = eb Else Rows(zei).OutlineLevel = 8
pd = sfld.Path
Application.StatusBar = pd
Exit For
End If
Next sfld

If pd = fld.Path And (sf = 0 Or sf = fld.subfolders.Count) Then
eb = eb + 1
For Each fl In fld.Files
zei = zei + 1
With Cells(zei, eb)
.Value = fl.Name & IIf(ShowFilesize, " [" & Format(Int(fl.Size / 1024) + 1, "#,##0") & " KB]", "")
'Range(Cells(zei, 1), Cells(zei, eb)).Borders(xlInsideVertical).LineStyle = xlHairline
End With
If eb <= 8 Then Rows(zei).OutlineLevel = eb Else Rows(zei).OutlineLevel = 8
Next fl

If fld.Path = Pfad Then
Application.StatusBar = False
MsgBox "Dateiliste wurde erstellt", vbInformation
End
Else
pd = fld.ParentFolder
eb = eb - 2
End If
End If

GoTo Neu

Fehler:
If fnr = 1 Then
eb = eb - 1
pd = fld.ParentFolder
Resume Neu
Else
sz = 0
szt = "***"
Resume Next
End If

End Sub
Function Byteunit(bt As Double) As String

Select Case bt
Case Is < 1024 ^ 1
Byteunit = bt & " Byte"
Case Is < 1024 ^ 2
Byteunit = Round(bt / 1024, 2) & " KB"
Case Is < 1024 ^ 3
Byteunit = Round(bt / 1024 ^ 2, 2) & " MB"
Case Is < 1024 ^ 4
Byteunit = Round(bt / 1024 ^ 3, 2) & " GB"
Case Is < 1024 ^ 5
Byteunit = Round(bt / 1024 ^ 4, 2) & " TB"
Case Is < 1024 ^ 6
Byteunit = Round(bt / 1024 ^ 5, 2) & " PB"
End Select

End Function

Viele Grüße - Mr. K.

Answer 2

Hallo Mr. K.

Danke für deine Hilfe,
das 1. Makro funktioniert prima aber nur mit Ordnergröße, es fehlen Inhalt: Anzahl Dateien u. Anzahl Ordner
außerdem hätte ich das lieber nicht mit MsgBox sondern das die Werte gleich eingetragen werden in leere Zellen
z.B. in A1 = 30 MB, in B1 = 50 Dateien, in C1 = 5 Ordner
oder ich mache mir vorher eine Spalten Überschrift und schreibe darunter nur die Werte
in A2 = 30, in B2 = 50, in C2 = 5

Beispiel: 2. Makro ist zu detailliert ich wollte nur das mir das Makro die Ordnergröße und den Inhalt an
Dateien und Ordner anzeigt, wie zum Beispiel: das was man sieht - wenn man mit rechte Maustaste
auf einen Ordner klickt und Eigenschaften anwählt:
- Größe des angewählten Ordners - z.B. 30 MB
- Inhalt an Dateien - z.B. 50 Dateien
- Inhalt an Ordner - z.B. 5 Ordner

Ich wäre dir sehr dankbar wenn du das so hinbekommst
Gruß Peter

Answer 3

Hallo Piedro,

Sorry, ich vergaß gestern diesen Link zu posten, da ich
selbst lieber mit der Excel-Internen Hilfe arbeite. Das Objekt bietet natürlich noch viel mehr Eigenschaften und Methoden, die du
hier nachsehen kannst.

Natürlich kann man damit ziemlich vielen Wünschen entsprechen. Auch deinen. Nur hab ich leider noch nicht so ganz
verstanden, was genau du machen willst, Willst du nur auf diesen einen Ordner zugreifen, oder auf eine Liste von Pfaden? Wann
gibst du einen neuen Pfad ein? Soll die Aktualisierung eines bestehenden Pfads manuell oder automatisch erfolgen? Es gibt
viele Möglichkeiten damit umzugehen.

Sub Ordnereigenschaften()

Dim fs, fld
Dim Pfad As String

Pfad = "C:\Program Files (x86)\Microsoft Office\Office12"
'oder alternativ: Pfad = Range("D1")
'oder alternativ: Pfad = InputBox("Bitte Pfad eingeben:")

Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(Pfad) Then
Set fld = fs.GetFolder(Pfad)
Range("A1") = Pfad
Range("A2") = Byteunit(fld.Size)
Range("B2") = fld.Files.Count
Range("C2") = fld.Subfolders.Count
Range("D2") = fld.DateCreated
End If

End Sub
Function Byteunit(bt As Single) As String

Select Case bt
Case Is < 1024 ^ 1
Byteunit = bt & " Byte"
Case Is < 1024 ^ 2
Byteunit = Round(bt / 1024, 2) & " KB"
Case Is < 1024 ^ 3
Byteunit = Round(bt / 1024 ^ 2, 2) & " MB"
Case Is < 1024 ^ 4
Byteunit = Round(bt / 1024 ^ 3, 2) & " GB"
Case Is < 1024 ^ 5
Byteunit = Round(bt / 1024 ^ 4, 2) & " TB"
Case Is < 1024 ^ 6
Byteunit = Round(bt / 1024 ^ 5, 2) & " PB"
End Select

End Function

Gruß Mr. K.

Answer 4

Hallo Mr. K.

Das Makro macht genau das was ich suchte, könntest du mir noch eine Zeile ändern:

Range ("B2") = fld.Files.Count

Hier sollten die Anzahl der Dateien eingetragen werden, nicht nur von diesem einen
Hauptordner der als letztes im Pfad angegeben ist
(er könnte nämlich leer sein und keine Dateien enthalten)
sondern die Gesamt Anzahl aller Dateien angefangen von dem Hauptordner
(für den Fall das er doch Dateien enthält) und von den Unterordner deren Anzahl
in ("C2") eingetragen werden, die in diesem Hauptordner enthalten sind.

z.B.
- Hauptordner = ( 1 Datei )
- Unterordner = ( 10 Dateien )
- Unterordner = ( 3 Dateien )
- Unterordner = ( 2 Dateien )

Eintrag in Zelle B2 = Anzahl aller Dateien ( im Beispiel sind es 16 )

Alle anderen Einträge waren richtig
A1 = Pfad
A2 = Größe aller Dateien ( Beispiel 50,17 MB )
C2 = Anzahl der Unterordner ( im Beispiel 3 )
D2 = Datum, Uhrzeit

Vielen, vielen Dank für Deine Mühe,
ich hoffe das du das jetzt auch noch hinbekommst
und wünsche Dir noch ein schönes Wochenende

Gruß Peter

Answer 5

Hi nochmal,

auch das ist natürlich möglich, wobei es dafür allerdings dann keine Eigenschaft gibt. Damit wären wir wieder bei einer leicht abgewandelten Form aus AW1, da ja die Subfolders auch wieder Subfolders enthalten können. Hier der angepasste Code:

Sub Ordnereigenschaften()

Dim fs, fld, sf
Dim Pfad As String
Dim flc As Long, fdc As Long

On Error GoTo Fehler:

Pfad = "E:\MeineDaten"
'oder alternativ: Pfad = Range("D1")
'oder alternativ: Pfad = InputBox("Bitte Pfad eingeben:")

Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(Pfad) Then
Set fld = fs.getfolder(Pfad)
Range("A1") = Pfad
Range("A2") = Byteunit(fld.Size)
Range("D2") = fld.DateCreated


pd = Pfad
Neu:
sf = 0
Set fld = fs.getfolder(pd)

fnr = 1
For Each sfld In fld.subfolders
sf = sf + 1

If InStr(1, FTest, sfld.Path + ";") = 0 Then
FTest = FTest + sfld.Path + ";"
fdc = fdc + 1
eb = eb + 1
' Stop

fnr = 2
Set fds = fs.getfolder(sfld.Path & "\")
fnm = fds.Name

pd = sfld.Path
'Application.StatusBar = pd
Exit For
End If
Next sfld

If pd = fld.Path And (sf = 0 Or sf = fld.subfolders.Count) Then
eb = eb + 1
flc = flc + fld.Files.Count

If fld.Path = Pfad Then
Range("B2") = flc: Range("C2") = fdc
Application.StatusBar = False
'MsgBox "Dateiliste wurde erstellt", vbInformation
End
Else
pd = fld.ParentFolder
eb = eb - 2
End If
End If
GoTo Neu
End If

Fehler:
If fnr = 1 Then
eb = eb - 1
pd = fld.ParentFolder
Resume Neu
Else
sz = 0
szt = "***"
Resume Next
End If


End Sub
Function Byteunit(bt As Single) As String

Select Case bt
Case Is < 1024 ^ 1
Byteunit = bt & " Byte"
Case Is < 1024 ^ 2
Byteunit = Round(bt / 1024, 2) & " KB"
Case Is < 1024 ^ 3
Byteunit = Round(bt / 1024 ^ 2, 2) & " MB"
Case Is < 1024 ^ 4
Byteunit = Round(bt / 1024 ^ 3, 2) & " GB"
Case Is < 1024 ^ 5
Byteunit = Round(bt / 1024 ^ 4, 2) & " TB"
Case Is < 1024 ^ 6
Byteunit = Round(bt / 1024 ^ 5, 2) & " PB"
End Select

End Function

Gruß Mr. K.

Answer 6

Hallo Mr. K.

ich konnte das Makro nicht ausprobieren, es kommt eine Meldung im letzten Teil des Makros
7. Zeile von unten bei "pd = fld.ParentFolder"

Laufzeitfehler '91':
Objektvariable oder With-Blockvariable nicht festgelegt

könntest du das Makro mal bei dir durchlaufen lassen oder liegt der Fehler bei mir
Mein Pfad hat am Ende einen Ordner.
Dieser hat dann nochmal 8 Unterordner die 83 Dateien enthalten
Normal sollte es jetzt mir anzeigen oder einfügen in die Zellen
Gesamtgröße aller Ordner, Unterordner und Dateien = 31,5 MB
Inhalt: 83 Dateien, 8 Ordner

aber ich konnte es nicht prüfen weil das Makro wegen dieser Fehlermeldung nicht zu
Ende ausgeführt werden kann

Gruß Peter

Answer 7

Hallo piedro,

Das ist merkwürdig. Bei mir funktioniert der Code mit Allen Testpfaden einwandfrei. Habs grad nochmal durchlaufen lassen. Hast
du wirklich Alles rüberkopiert?

Probiers mal mit pd = fld.ParentFolder.Path - Bei mir klappts zwar auch ohne, da Path als Standardeigenschaft erkannt wird,
aber vielleicht ist das ja bei dir anders.

Ergänze auch die Variablendeklaration im oberen Bereich. Da ich aus Gründen der Übersichtlichkeit viel mit Variant-Variablen
arbeite vergesse ich da gern mal die eine oder Andere - sorry. Grad nochmal mit Option Explicit durchgeprüft. Sollte jetzt
vollständig sein.

Dim fs, fld, sf, sfld, fds
Dim Pfad As String, ftest As String, fnm As String, szt As String
Dim flc As Long, fdc As Long
Dim pd As String, fnr As Byte, eb As Integer, sz As Double


Eventuell ist bei deinem Pfad auch irgendwas ganz anders, was ich grad nicht nachvollziehen kann. Der Fehler tritt bei dir
innerhalb einer Routine auf, die eigentlich einen anderen Fehler abfangen soll. Falls die oberen Lösungen nicht helfen, nimm
mal die Zeile On Error GoTo Fehler: vorübergehend raus. dann bekommen wir vielleicht besser raus an welcher Stelle der
Fehler tatsächlich auftritt.

Mr. K.

Answer 8

Eine Idee hab ich noch. Es könnte sein, dass du auf einen Ordner zugreifst, der geschützte Unterordner enthält. Oder du willst ein
ganzes Laufwerk zurückgeben. Auch da gibt es viele versteckte Dateien. Da ein Laufwerk im allgemeinen kein Ordner ist, führt der
Zugriff auf einige Eigenschaften (z.B. Size) zu einem Fehler, der normalerweise durch die Routine abgefangen wird. (zumindest
bei mir). Um ganz sicher zu gehen, dass es auch bei dir klappt, probier es mal mit diesem leicht verändertem Code, damit sollte
dein Fehler eigentlich behoben sein.

Sub Ordnereigenschaften()

Dim fs, fld, sf, sfld, fds, fl
Dim Pfad As String, ftest As String, fnm As String, szt As String
Dim flc As Long, fdc As Long
Dim pd As String, fnr As Byte, eb As Integer, sz As Single

On Error GoTo Fehler:

Pfad = "E:\"
'oder alternativ: Pfad = Range("D1")
'oder alternativ: Pfad = InputBox("Bitte Pfad eingeben:")

Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(Pfad) Then
Set fld = fs.getfolder(Pfad)
Range("A1") = Pfad
Range("D2") = fld.DateCreated

For Each sf In fld.subfolders
sz = sz + sf.Size
Next sf
For Each fl In fld.Files
sz = sz + fl.Size
Next fl


pd = Pfad
Neu:
sf = 0
Set fld = fs.getfolder(pd)

fnr = 1
For Each sfld In fld.subfolders
sf = sf + 1

If InStr(1, ftest, sfld.Path + ";") = 0 Then
ftest = ftest + sfld.Path + ";"
fdc = fdc + 1
eb = eb + 1
' Stop

fnr = 2
Set fds = fs.getfolder(sfld.Path & "\")
fnm = fds.Name

pd = sfld.Path

Application.StatusBar = pd
'If pd = "E:\Zeitschriften\AudioVideoFotoBild" Then Stop
Exit For
End If
Next sfld

If pd = fld.Path And (sf = 0 Or sf = fld.subfolders.Count) Then
fnr = 3
eb = eb + 1
flc = flc + fld.Files.Count

'Stop
If fld.Path = Pfad Then
'Stop
Range("B2") = flc: Range("C2") = fdc
Application.StatusBar = False
Range("A2") = Byteunit(sz)
'MsgBox "Dateiliste wurde erstellt", vbInformation
End
Else
pd = fld.ParentFolder
eb = eb - 2
End If
End If
GoTo Neu




End If

Fehler:

If fnr = 1 Then
' Stop
eb = eb - 1
pd = fld.ParentFolder.Path
Resume Neu
Else
Resume Next
End If


End Sub
Function Byteunit(bt As Single) As String

Select Case bt
Case Is < 1024 ^ 1
Byteunit = bt & " Byte"
Case Is < 1024 ^ 2
Byteunit = Round(bt / 1024, 2) & " KB"
Case Is < 1024 ^ 3
Byteunit = Round(bt / 1024 ^ 2, 2) & " MB"
Case Is < 1024 ^ 4
Byteunit = Round(bt / 1024 ^ 3, 2) & " GB"
Case Is < 1024 ^ 5
Byteunit = Round(bt / 1024 ^ 4, 2) & " TB"
Case Is < 1024 ^ 6
Byteunit = Round(bt / 1024 ^ 5, 2) & " PB"
End Select

End Function

Gruß Mr. K.

Answer 9

Hallo Mr. K.

Endlich hat es geklappt !!!!!!!
Das Makro aus Antwort 5 macht's

Es war meine Schuld, habe im Makro Pfad einen Ordner mit kleinen Buchstaben geschrieben,
tatsächlich war er im Explorer aber mit Großbuchstaben benannt.

Bitte um Entschuldigung für meine Unachtsamkeit und vielen,vielen Dank das du soviel Zeit
für mich geopfert hast.
Am Ende war ich der Depp. Ich hätte ja schon früher drauf kommen können aber ..... naja
es ist nun mal passiert.
Ich freue mich trotzdem das du mir geholfen hast und nochmals Vielen Dank

Gruß Peter

Answer 10

OK, Schön zu hören, dass es funktioniert, obwohl ich auch dieses Problem nicht nachvollziehen kann. Ein nicht existierender Ordner
führt bei mir dank FolderExists lediglich zum schnellen Ende des Makros. Damit dabei aber die Fehlerroutine gar nicht erst anspringt
kann man noch zwischen End Sub und Fehler: die Zeile Exit Sub ergänzen.

Na egal. Hauptsache es funktioniert jetzt und du bekommst die Daten die du haben willst.

L.G. Mr. K.