title image


Smiley Aus dem Spotlight-Archiv...
Hallo floti,



ich habe mir mal vor einiger Zeit eine Lösung aus dem Spotlight-Archiv kopiert (bzw. nicht aus dem Archiv, sondern das war damals ein aktueller Thread !)







      

'Listet alle Dateien in einem Ordner inkl. aller Subordner auf

'gefunden auf http://spotlight.de/zforen/mse/m/mse-1042725838-7421.html

'am 16.01.2003

'Ordner werden in Tabelle1 aufgelistet

'Dateien werden in Tabelle2 aufgelistet, inkl. Hyperlink zu diesen Dateien



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

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

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







 








Grüße, NoNet

  1,2,3 - kleine Excelei :   Infos + Anmeldung zum Jährlichen Exceltreffen



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: