| home |  
  

   © 2005 by Friedel Schmidt •  E-Mail  •                      Top  

   | impressum | feedback | home |  


Inhaltsverzeichnis

Suchen

Links
  

Dateien aus Verzeichnis und Unterverzeichnis einlesen
Versionen: Excel 97

Aus einem Verzeichnis inklusive aller Unterverzeichnisse sollen alle Dateien eingelesen werden.
Es soll eine Verzeichnisübersicht und eine Dateiliste erstellt werden

Die Verzeichnisübersicht soll die Verzeichnisnamen aller Verzeichnisse samt Unterverzeichnissen, die Anzahl der Unterverzeichnisse, die Anzahl der darin enthaltenen Dateien und deren gesamte Dateigröße enthalten.
Die Eintragung erfolgt in Tabelle1

 ABCD
1PfadUnterVerz.Anz. DateienDatgröße in Verz.
2C:\Eigene Dateien3161,42789936
3C:\Eigene Dateien\Download\210,25065136
4C:\Eigene Dateien\Vorlagen\180,29530907
5C:\Eigene Dateien\start\100
6C:\Eigene Dateien\Download\ZIP\0141,7140989
7C:\Eigene Dateien\Download\McAfee\033,09511757
8C:\Eigene Dateien\Vorlagen\Proof\0215,99200249
9C:\Eigene Dateien\start\00000\020,00076675


Die Dateiliste soll Dateinamen, Dateigröße und das Änderungsdatum enthalten. Zusätzlich soll ein Hyperlink zu den Dateien gesetzt werden.
Die Eintragung erfolgt in Tabelle2

 ABCD
1    
2desktop.iniC:\Eigene Dateien\desktop.ini12513.07.00 22:22
3URL.txtC:\Eigene Dateien\URL.txt4528.03.02 23:00
4Pivot-Test.xlsC:\Eigene Dateien\Pivot-Test.xls2969605.06.02 01:10
5Titelleiste anpassen.xlsC:\Eigene Dateien\Titelleiste anpassen.xls2048008.06.02 01:29
6Urlaubsplaner V19M33BK.xlsC:\Eigene Dateien\Urlaubsplaner V19M33BK.xls12032008.06.02 01:34
7Urlaubsplaner V026VE5O.xlsC:\Eigene Dateien\Urlaubsplaner V026VE5O.xls2713608.06.02 01:42
8Urlaub_2002.zipC:\Eigene Dateien\Download\Urlaub_2002.zip26282708.06.02 00:41
9Friedel - Fax.dotC:\Eigene Dateien\Vorlagen\Friedel - Fax.dot4864002.12.01 22:38
10Petra - Fax.dotC:\Eigene Dateien\Vorlagen\Petra - Fax.dot2252802.12.01 22:41


Das Haupt - Verzeichnis wird mittels eines Verzeichnisbrowsers abgefragt und am Ende wird ein Meldung mit diversen Angaben angezeigt.

VBA-Entwicklungsumgebung öffnen und folgenden Code in ein Modul einfügen

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 StringAs 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
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] = ""

' 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
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

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


Makro "Verzeichnisse_auflisten" starten - viel Spaß


Dateien unter Vorgabe eines Filters aus Verzeichnis auslesen