Option Explicit
'Listet für einen vom Benutzer gewählten Ordner und dessen Unterordner
'jeweils auf einem neuen Arbeitsblatt alle Dateien
'
'Ursprungscode https://www.herber.de/forum/archiv/1928to1932/1929342_Zugriff_verweigert.html
Private oSheet As Worksheet
Private oFSO As Object
Private shFolder As Object
Private dtStart As Date
Private t(4) As Variant
Const cFilesRead = 0
Const cLinesOut = 1
Const cTimeElapsed = 2
Const cPathNoReadPerm = 3
Const cPathSysHid = 4
Public Sub OVBAde_DateienMitUnterordnernAuslesen()
Dim sRootPath As String
Dim objFileDialog As Object
Dim shApp As Object
Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.InitialView = msoFileDialogViewSmallIcons
.Title = "Bitte den Ordner auswählen"
If .Show Then sRootPath = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If sRootPath = "" Then
Exit Sub
End If
dtStart = Now
t(cLinesOut) = 0
t(cFilesRead) = 0
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
t(cPathNoReadPerm) = 0
t(cPathSysHid) = 0
dtStart = Now
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set shApp = CreateObject("Shell.Application")
Set shFolder = shApp.Namespace(sRootPath & "\")
Set oSheet = Sheets.Add
'Titelzeile erstellen
With oSheet.Range("A1:D1")
.Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")
.Interior.ColorIndex = 11
.Font.Color = vbWhite
.Font.Color = vbWhite
.HorizontalAlignment = xlCenter
End With
'Titel für Zähleranzeige während der Laufzeit
oSheet.Range("i1:M1").Value = Array("Files geprüft", "Files ausgeg.", "Laufzeit", "Folder o. Rechte", "Folder Sys/Hidden")
oSheet.Range("i2:M2").Value = t
oSheet.Range("i1:M2").Columns.AutoFit
If oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).Path = sRootPath Then
OVBAde_ReadSubFolder oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).RootFolder
Else
OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End If
'Zähleranzeige entfernen
oSheet.Range("i1:M2").Clear
oSheet.Columns.AutoFit
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
MsgBox "Files geprüft " & vbTab & ": " & t(cFilesRead) & vbCrLf & _
"Files ausgegeben" & vbTab & ": " & t(cLinesOut) & vbCrLf & _
"Laufzeit " & vbTab & ": " & t(cTimeElapsed) & vbCrLf & vbCrLf & _
"Folder o. Leserechte" & vbTab & ": " & t(cPathNoReadPerm) & vbCrLf & _
"Folder Syst./Hidden" & vbTab & ": " & t(cPathSysHid)
End Sub
Private Sub OVBAde_ReadSubFolder(oFolder As Object)
Dim oSubFolder As Object
Dim oFile As Object
'Testet ob Verzeichnis gelesen werden kann
On Error Resume Next
If Not (oFolder.Files.Count >= 0) Then
t(cPathNoReadPerm) = t(cPathNoReadPerm) + 1
Exit Sub
End If
On Error GoTo 0
'Alle Dateien durchforsten
For Each oFile In oFolder.Files
If Not oFile Is Nothing Then
Details_auslesen oFile, oFolder.Path
End If
Next
'Alle Unterverzeichnisse verarbeiten (rekursiv), die nicht System oder Hidden sind
For Each oSubFolder In oFolder.subfolders
If Not ((oSubFolder.Attributes And (vbSystem + vbHidden)) > 0) Then
OVBAde_ReadSubFolder oSubFolder
Else
t(cPathSysHid) = t(cPathSysHid) + 1
End If
Next oSubFolder
End Sub
Sub Details_auslesen(Datei As Object, Ordner As String)
Dim ShFolderItem As Object 'Folder-Item, also Datei, nach Shell.GetItem
DoEvents
t(cFilesRead) = t(cFilesRead) + 1
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
oSheet.Range("i2:M2").Value = t
oSheet.Cells(2, 10).Value = oSheet.Cells(2, 10).Value + 1
Set ShFolderItem = shFolder.ParseName(Datei.Name)
t(cLinesOut) = t(cLinesOut) + 1
With oSheet.Cells(t(cLinesOut), 1)
.Offset(1, 0).Hyperlinks.Add Anchor:=.Offset(1, 0), Address:=Datei.Path, TextToDisplay:=Datei.Name
.Offset(1, 1).Value = Ordner
.Offset(1, 2).Value = shFolder.GetDetailsOf(ShFolderItem, 24) 'Kategorie
.Offset(1, 3).Value = shFolder.GetDetailsOf(ShFolderItem, 25) 'Kommentar
End With
End Sub
Option Explicit
'Listet für einen vom Benutzer gewählten Ordner und dessen Unterordner
'jeweils auf einem neuen Arbeitsblatt alle Dateien
'
'Ursprungscode https://www.herber.de/forum/archiv/1928to1932/1929342_Zugriff_verweigert.html
Private oSheet As Worksheet
Private oFSO As Object
Private dtStart As Date
Private t(4) As Variant
Const cFilesRead = 0
Const cLinesOut = 1
Const cTimeElapsed = 2
Const cPathNoReadPerm = 3
Const cPathSysHid = 4
Public Sub OVBAde_DateienMitUnterordnernAuslesen()
Dim sRootPath As String
Dim objFileDialog As Object
Dim shApp As Object
Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.InitialView = msoFileDialogViewSmallIcons
.Title = "Bitte den Ordner auswählen"
If .Show Then sRootPath = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If sRootPath = "" Then
Exit Sub
End If
dtStart = Now
t(cLinesOut) = 0
t(cFilesRead) = 0
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
t(cPathNoReadPerm) = 0
t(cPathSysHid) = 0
dtStart = Now
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oSheet = Sheets.Add
'Titelzeile erstellen
With oSheet.Range("A1:D1")
.Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")
.Interior.ColorIndex = 11
.Font.Color = vbWhite
.Font.Color = vbWhite
.HorizontalAlignment = xlCenter
End With
'Titel für Zähleranzeige während der Laufzeit
oSheet.Range("i1:M1").Value = Array("Files geprüft", "Files ausgeg.", "Laufzeit", "Folder o. Rechte", "Folder Sys/Hidden")
oSheet.Range("i2:M2").Value = t
oSheet.Range("i1:M2").Columns.AutoFit
If oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).Path = sRootPath Then
OVBAde_ReadSubFolder oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).RootFolder
Else
OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End If
'Zähleranzeige entfernen
oSheet.Range("i1:M2").Clear
oSheet.Columns.AutoFit
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
MsgBox "Files geprüft " & vbTab & ": " & t(cFilesRead) & vbCrLf & _
"Files ausgegeben" & vbTab & ": " & t(cLinesOut) & vbCrLf & _
"Laufzeit " & vbTab & ": " & t(cTimeElapsed) & vbCrLf & vbCrLf & _
"Folder o. Leserechte" & vbTab & ": " & t(cPathNoReadPerm) & vbCrLf & _
"Folder Syst./Hidden" & vbTab & ": " & t(cPathSysHid)
End Sub
Private Sub OVBAde_ReadSubFolder(oFolder As Object)
Dim oSubFolder As Object
Dim oFile As Object
'Testet ob Verzeichnis gelesen werden kann
On Error Resume Next
If Not (oFolder.Files.Count >= 0) Then
t(cPathNoReadPerm) = t(cPathNoReadPerm) + 1
Exit Sub
End If
On Error GoTo 0
'Alle Dateien durchforsten
For Each oFile In oFolder.Files
If Not oFile Is Nothing Then
Details_auslesen oFile, oFolder.Path
End If
Next
'Alle Unterverzeichnisse verarbeiten (rekursiv), die nicht System oder Hidden sind
For Each oSubFolder In oFolder.subfolders
If Not ((oSubFolder.Attributes And (vbSystem + vbHidden)) > 0) Then
OVBAde_ReadSubFolder oSubFolder
Else
t(cPathSysHid) = t(cPathSysHid) + 1
End If
Next oSubFolder
End Sub
Sub Details_auslesen(Datei As Object, Ordner As String)
Dim shApp As Object
Dim shFolder As Object
Dim ShFolderItem As Object 'Folder-Item, also Datei, nach Shell.GetItem
DoEvents
t(cFilesRead) = t(cFilesRead) + 1
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
oSheet.Range("i2:M2").Value = t
oSheet.Cells(2, 10).Value = oSheet.Cells(2, 10).Value + 1
Set shApp = CreateObject("Shell.Application")
Set shFolder = shApp.Namespace(Datei.parentfolder.Path)
Set ShFolderItem = shFolder.ParseName(Datei.Name)
t(cLinesOut) = t(cLinesOut) + 1
With oSheet.Cells(t(cLinesOut), 1)
.Offset(1, 0).Hyperlinks.Add Anchor:=.Offset(1, 0), Address:=Datei.Path, TextToDisplay:=Datei.Name
.Offset(1, 1).Value = Datei.parentfolder.Path
.Offset(1, 2).Value = shFolder.GetDetailsOf(ShFolderItem, 23) 'Kategorie
.Offset(1, 3).Value = shFolder.GetDetailsOf(ShFolderItem, 24) 'Kommentar
End With
End Sub
Option Explicit
'Listet für einen vom Benutzer gewählten Ordner und dessen Unterordner
'jeweils auf einem neuen Arbeitsblatt alle Dateien
'
'Ursprungscode https://www.herber.de/forum/archiv/1928to1932/1929342_Zugriff_verweigert.html
Private oSheet As Worksheet
Private oApp As Object
Private oFSO As Object
Private dtStart As Date
Private t(4) As Variant
Const cFilesRead = 0
Const cLinesOut = 1
Const cTimeElapsed = 2
Const cPathNoReadPerm = 3
Const cPathSysHid = 4
Public Sub OVBAde_DateienMitUnterordnernAuslesen()
Dim sRootPath As String
Dim objFileDialog As Object
Dim shApp As Object
Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.InitialView = msoFileDialogViewSmallIcons
.Title = "Bitte den Ordner auswählen"
If .Show Then sRootPath = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If sRootPath = "" Then
Exit Sub
End If
dtStart = Now
t(cLinesOut) = 0
t(cFilesRead) = 0
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
t(cPathNoReadPerm) = 0
t(cPathSysHid) = 0
dtStart = Now
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oApp = CreateObject("Shell.Application")
Set oSheet = Sheets.Add
'Titelzeile erstellen
With oSheet.Range("A1:D1")
.Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")
.Interior.ColorIndex = 11
.Font.Color = vbWhite
.Font.Color = vbWhite
.HorizontalAlignment = xlCenter
End With
' Application.ScreenUpdating = False
'Titel für Zähleranzeige während der Laufzeit
oSheet.Range("i1:M1").Value = Array("Files geprüft", "Files ausgeg.", "Laufzeit", "Folder o. Rechte", "Folder Sys/Hidden")
oSheet.Range("i2:M2").Value = t
oSheet.Range("i1:M2").Columns.AutoFit
If oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).Path = sRootPath Then
OVBAde_ReadSubFolder oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).RootFolder
Else
OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End If
'Zähleranzeige entfernen
oSheet.Range("i1:M2").Clear
oSheet.Columns.AutoFit
' Application.ScreenUpdating = True
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
MsgBox "Files geprüft " & vbTab & ": " & t(cFilesRead) & vbCrLf & _
"Files ausgegeben" & vbTab & ": " & t(cLinesOut) & vbCrLf & _
"Laufzeit " & vbTab & ": " & t(cTimeElapsed) & vbCrLf & vbCrLf & _
"Folder o. Leserechte" & vbTab & ": " & t(cPathNoReadPerm) & vbCrLf & _
"Folder Syst./Hidden" & vbTab & ": " & t(cPathSysHid)
End Sub
Private Sub OVBAde_ReadSubFolder(oFolder As Object)
Dim oSubFolder As Object
Dim oFile As Object
'Testet ob Verzeichnis gelesen werden kann
On Error Resume Next
If Not (oFolder.Files.Count >= 0) Then
t(cPathNoReadPerm) = t(cPathNoReadPerm) + 1
Exit Sub
End If
On Error GoTo 0
Dim shfolder As Object
Dim shfolderitem As Object
Set shfolder = oApp.Namespace(oFolder.Path)
'Alle Dateien durchforsten
For Each oFile In oFolder.Files
If Not oFile Is Nothing Then
Set shfolderitem = shfolder.ParseName(oFile.Name)
Details_auslesen shfolder, shfolderitem
End If
Next
'Alle Unterverzeichnisse verarbeiten (rekursiv), die nicht System oder Hidden sind
For Each oSubFolder In oFolder.subfolders
If Not ((oSubFolder.Attributes And (vbSystem + vbHidden)) > 0) Then
OVBAde_ReadSubFolder oSubFolder
Else
t(cPathSysHid) = t(cPathSysHid) + 1
End If
Next oSubFolder
End Sub
Sub Details_auslesen(shfolder As Object, item As Object)
DoEvents
t(cFilesRead) = t(cFilesRead) + 1
t(cLinesOut) = t(cLinesOut) + 1
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
oSheet.Range("i2:M2").Value = t
With oSheet.Cells(t(cLinesOut), 1)
.Offset(1, 0).Hyperlinks.Add Anchor:=.Offset(1, 0), Address:=item.Path, TextToDisplay:=item.Name
.Offset(1, 1).Value = shfolder.self.Path
.Offset(1, 2).Value = shfolder.GetDetailsOf(item, 23) 'Kategorie
.Offset(1, 3).Value = shfolder.GetDetailsOf(item, 24) 'Kommentar
End With
End Sub
Option Explicit
'Listet für einen vom Benutzer gewählten Ordner und dessen Unterordner
'jeweils auf einem neuen Arbeitsblatt alle Dateien
'
'Ursprungscode https://www.herber.de/forum/archiv/1928to1932/1929342_Zugriff_verweigert.html
'
'andere Attribute und ohne Beschränkung auf bestimmte Dateitypen
'Aus Geschwindigkeitsgründen:
'Kontrollausgaben entfernt
'Ausgabe wird in Array vorbereitet
'Hyperlinks ergänzt (und jetzt per Formel)
'DoEvents lass ich mal drin
'Oppawinni : Du sitzt halt davor und fragst dich, ob sich noch was tut....es kann dauern.
Private oSheet As Worksheet
Private oApp As Object
Private oFSO As Object
Private dtStart As Date
Private arrOut As Variant
Private t(4) As Variant
Const cFilesRead = 0
Const cLinesOut = 1
Const cTimeElapsed = 2
Const cPathNoReadPerm = 3
Const cPathSysHid = 4
Public Sub OVBAde_DateienMitUnterordnernAuslesen()
Dim sRootPath As String
Dim objFileDialog As Object
Dim shApp As Object
Dim i As Long
Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.InitialView = msoFileDialogViewSmallIcons
.Title = "Bitte den Ordner auswählen"
If .Show Then sRootPath = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If sRootPath = "" Then
Exit Sub
End If
dtStart = Now
t(cFilesRead) = 0
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
t(cPathNoReadPerm) = 0
t(cPathSysHid) = 0
dtStart = Now
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oApp = CreateObject("Shell.Application")
ReDim arrOut(3, 1000)
Set oSheet = Sheets.Add
'Titelzeile erstellen
With oSheet.Range("A1:D1")
.Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")
.Interior.ColorIndex = 11
.Font.Color = vbWhite
.Font.Color = vbWhite
.HorizontalAlignment = xlCenter
End With
If oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).Path = sRootPath Then
OVBAde_ReadSubFolder oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).RootFolder
Else
OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End If
'Ausgabe
ReDim Preserve arrOut(3, t(cFilesRead) - 1)
oSheet.Range("A2").Resize(UBound(arrOut, 2) + 1, 4) = WorksheetFunction.Transpose(arrOut)
For i = 0 To UBound(arrOut, 2)
oSheet.Range("A2").Offset(i, 0).FormulaR1C1 = "=HYPERLINK(RC[1]&""\" & arrOut(0, i) & """,""" & arrOut(0, i) & """)"
Next
oSheet.Columns.AutoFit
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
MsgBox "Files gelesen " & vbTab & ": " & t(cFilesRead) & vbCrLf & _
"Laufzeit " & vbTab & ": " & t(cTimeElapsed) & vbCrLf & vbCrLf & _
"Folder o. Leserechte" & vbTab & ": " & t(cPathNoReadPerm) & vbCrLf & _
"Folder Syst./Hidden" & vbTab & ": " & t(cPathSysHid)
End Sub
Private Sub OVBAde_ReadSubFolder(oFolder As Object)
Dim oSubFolder As Object
Dim oFile As Object
'Testet ob Verzeichnis gelesen werden kann
On Error Resume Next
If Not (oFolder.Files.Count >= 0) Then
t(cPathNoReadPerm) = t(cPathNoReadPerm) + 1
Exit Sub
End If
On Error GoTo 0
Dim shfolder As Object
Dim shfolderitem As Object
Set shfolder = oApp.Namespace(oFolder.Path)
'Alle Dateien durchforsten
For Each oFile In oFolder.Files
If Not oFile Is Nothing Then
Set shfolderitem = shfolder.ParseName(oFile.Name)
Details_auslesen shfolder, shfolderitem
End If
Next
Set shfolder = Nothing
Set shfolderitem = Nothing
'Alle Unterverzeichnisse verarbeiten (rekursiv), die nicht System oder Hidden sind
For Each oSubFolder In oFolder.subfolders
If Not ((oSubFolder.Attributes And (vbSystem + vbHidden)) > 0) Then
OVBAde_ReadSubFolder oSubFolder
Else
t(cPathSysHid) = t(cPathSysHid) + 1
End If
Next oSubFolder
End Sub
Sub Details_auslesen(shfolder As Object, item As Object)
Dim lngArrSize As Long
DoEvents
t(cFilesRead) = t(cFilesRead) + 1
lngArrSize = UBound(arrOut, 2)
If t(cFilesRead) = lngArrSize Then
ReDim Preserve arrOut(3, lngArrSize + 1000)
End If
arrOut(0, t(cFilesRead) - 1) = item.Name
arrOut(1, t(cFilesRead) - 1) = shfolder.self.Path
arrOut(2, t(cFilesRead) - 1) = shfolder.GetDetailsOf(item, 23)
arrOut(3, t(cFilesRead) - 1) = shfolder.GetDetailsOf(item, 24)
End Sub
Sub theAttributes()
Dim shApp As Object
Dim shfolder As Object
Dim strAttrib As String
Dim i As Long
Set oApp = CreateObject("Shell.Application")
Set shfolder = oApp.Namespace("C:\")
For i = 0 To 400
strAttrib = shfolder.GetDetailsOf("", i)
Debug.Print i & ":" & Left(strAttrib & String(40, " "), 40);
If i Mod 3 = 2 Then Debug.Print
Next
End Sub
0:Name 1:Größe 2:Elementtyp
3:Änderungsdatum 4:Erstelldatum 5:Letzter Zugriff
6:Attribute 7:Offlinestatus 8:Verfügbarkeit
9:Erkannter Typ 10:Besitzer 11:Art
12:Aufnahmedatum 13:Mitwirkende Interpreten 14:Album
15:Jahr 16:Genre 17:Dirigenten
18:Markierungen 19:Bewertung 20:Autoren
21:Titel 22:Betreff 23:Kategorien
24:Kommentare 25:Copyright 26:Titelnummer
27:Länge 28:Bitrate 29:Geschützt
30:Kameramodell 31:Abmessungen 32:Kamerahersteller
33:Firma 34:Dateibeschreibung 35:Masterschlüsselwörter
36:Masterschlüsselwörter 37: 38:
39: 40: 41:
42:Programmname 43:Dauer 44:Ist online
45:Periodisch wiederkehrend 46:Ort 47:Adressen der optionalen Teilnehmer
48:Optionale Teilnehmer 49:Organisatoradresse 50:Organisatorname
51:Erinnerungszeit 52:Adressen der erforderlichen Teilnehmer 53:Erforderliche Teilnehmer
54:Ressourcen 55:Besprechungsstatus 56:Status frei/besetzt
57:Gesamtgröße 58:Kontoname 59:
60:Aufgabenstatus 61:Computer 62:Jahrestag
63:Name des Assistenten 64:Telefonnummer des Assistenten 65:Geburtstag
66:Geschäftsadresse 67:Ort (geschäftlich) 68:Land/Region (geschäftlich)
69:Postfach (geschäftlich) 70:Postleitzahl (geschäftlich) 71:Bundesland/Provinz (geschäftlich)
72:Straße (geschäftlich) 73:Fax (geschäftlich) 74:Homepage (geschäftlich)
75:Rufnummer (geschäftlich) 76:Rückrufnummer 77:Autotelefon
78:Kinder 79:Zentrale Firmenrufnummer 80:Abteilung
81:E-Mail-Adresse 82:E-Mail2 83:E-Mail3
84:E-Mail-Liste 85:E-Mail-Anzeigename 86:Speichern unter
87:Vorname 88:Vollständiger Name 89:Geschlecht
90:Gegebener Name 91:Hobbies 92:Privatadresse
93:Ort (privat) 94:Land/Region (privat) 95:Postfach (privat)
96:Postleitzahl (privat) 97:Bundesland/Provinz (privat) 98:Straße (privat)
99:Fax (privat) 100:Rufnummer (privat) 101:Adressen für Chats
102:Initialen 103:Position 104:Bezeichnung
105:Nachname 106:Adresse 107:Zweiter Vorname
108:Mobiltelefon 109:Spitzname 110:Bürostandort
111:Weitere Adresse 112:Andere Stadt 113:Anderes Land/Region
114:Anderes Postfach 115:Andere Postleitzahl 116:Anderes Bundesland oder Provinz
117:Andere Straße 118:Pager 119:Persönlicher Titel
120:Stadt 121:Land/Region 122:Postfach
123:Postleitzahl 124:Bundesland/Provinz 125:Straße
126:Primäre E-Mail 127:Primäre Telefonnummer 128:Beruf
129:Ehepartner/Partner 130:Suffix 131:TTY/TTD-Telefon
132:Telex 133:Webseite 134:Inhaltstatus
135:Inhaltstyp 136:Erfassungsdatum 137:Archivierungsdatum
138:Vollendungsdatum 139:Gerätekategorie 140:Verbindung hergestellt
141:Erkennungsmethode 142:Anzeigename 143:Lokaler Computer
144:Hersteller 145:Modell 146:Gekoppelt
147:Klassifizierung 148:Status 149:Gerätestatus
150:Clientkennung 151:Mitwirkende 152:Inhalt erstellt
153:Zuletzt gedruckt 154:Letzte Speicherung 155:Hauptabteilung
156:Dokument-ID 157:Seiten 158:Folien
159:Gesamtbearbeitungszeit 160:Wortanzahl 161:Fällig am
162:Enddatum 163:Dateianzahl 164:Dateierweiterung
165:Dateiname 166:Dateiversion 167:Kennzeichnungsfarbe
168:Kennzeichnungsstatus 169:Freier Speicherplatz 170:
171: 172:Gruppe 173:Freigabetyp
174:Bittiefe 175:Horizontale Auflösung 176:Breite
177:Vertikale Auflösung 178:Höhe 179:Wichtigkeit
180:Anlage? 181:Ist gelöscht 182:Verschlüsselungsstatus
183:Kennzeichnung vorhanden 184:Wurde beendet 185:Unvollständig
186:Lesestatus 187:Freigegeben 188:Ersteller
189:Datum 190:Ordnername 191:Ordnerpfad
192:Ordner 193:Teilnehmer 194:Pfad
195:Nach Ort 196:Typ 197:Kontaktnamen
198:Eintragstyp 199:Sprache 200:Letzter Besuch
201:Beschreibung 202:Verknüpfungsstatus 203:Verknüpfungsziel
204:URL 205: 206:
207: 208:Medium erstellt 209:Veröffentlichungsdatum
210:Codiert durch 211:Folgennummer 212:Produzenten
213:Herausgeber 214:Staffelnummer 215:Untertitel
216:Benutzerweb-URL 217:Texter 218:
219:Anlagen 220:BCC-Adressen 221:BCC
222:CC-Adressen 223:CC 224:Unterhaltungs-ID
225:Empfangsdatum 226:Absendungsdatum 227:Von Adressen
228:Von 229:Hat Anlagen 230:Absenderadresse
231:Absendername 232:Speicher 233:Empfängeradressen
234:Arbeitstitel 235:An 236:Laufzeit
237:Albuminterpret 238:Sortierung nach Albuminterpret 239:Album-ID
240:Sortierung nach Album 241:Sortierung nach mitwirkenden Interpreten242:Beats pro Minute
243:Komponisten 244:Sortierung nach Komponist 245:Disc
246:Ursprünglicher Schlüssel 247:Bestandteil einer Kompilation 248:Stimmung
249:Teil eines Satzes 250:Zeitraum 251:Farbe
252:Jugendschutz 253:Grund für Jugendschutzeinstufung 254:Verwendeter Speicherplatz
255:EXIF-Version 256:Ereignis 257:Lichtwert
258:Belichtungsprogramm 259:Belichtungszeit 260:Blendenzahl
261:Blitzlichtmodus 262:Brennweite 263:35mm Brennweite
264:ISO-Filmempfindlichkeit 265:Objektivhersteller 266:Objektivmodell
267:Lichtquelle 268:Maximale Blende 269:Messmodus
270:Ausrichtung 271:Kontakte 272:Programmmodus
273:Sättigung 274:Abstand 275:Weißausgleich
276:Priorität 277:Projekt 278:Kanal
279:Folgenname 280:Untertitel (Closed Captions) 281:Wiederholung
282:Zweikanalton 283:Sendungsdatum 284:Sendungsbeschreibung
285:Aufnahmezeit 286:Senderrufzeichen 287:Fernsehsendername
288:Zusammenfassung 289:Schnipsel 290:Automatische Zusammenfassung
291:Relevanz 292:Dateibesitz 293:Sensitivität
294:Freigegeben für 295:Freigabestatus 296:
297:Produktname 298:Produktversion 299:Supportlink
300:Quelle 301:Startdatum 302:Ist geteilt
303:Verfügbarkeitsstatus 304:Status 305:Abrechnungsinformationen
306:Abgeschlossen 307:Aufgabenbesitzer 308:Sortierung nach Titel
309:Gesamtdateigröße 310:Marken 311:Videokomprimierung
312:Regisseure 313:Datenrate 314:Bildhöhe
315:Einzelbildrate 316:Bildbreite 317:Kugelförmig
318:Stereo 319:Videoausrichtung 320:Gesamtbitrate Option Explicit
'Listet für einen vom Benutzer gewählten Ordner und dessen Unterordner
'jeweils auf einem neuen Arbeitsblatt alle Dateien
'
'Ursprungscode https://www.herber.de/forum/archiv/1928to1932/1929342_Zugriff_verweigert.html
'
'andere Attribute und ohne Beschränkung auf bestimmte Dateitypen
'Aus Geschwindigkeitsgründen:
'Kontrollausgaben entfernt
'Ausgabe wird in Array vorbereitet
'Hyperlinks ergänzt (und jetzt per Formel)
'DoEvents lass ich mal drin
'Oppawinni : Du sitzt halt davor und fragst dich, ob sich noch was tut....es kann dauern.
Private oSheet As Worksheet
Private oApp As Object
Private oFSO As Object
Private dtStart As Date
Private arrOut As Variant
Private rngStartOut As Range
Private t(4) As Variant
Const cFilesRead = 0
Const cLinesCount = 1
Const cTimeElapsed = 2
Const cPathNoReadPerm = 3
Const cPathSysHid = 4
Public Sub OVBAde_DateienMitUnterordnernAuslesen()
Dim sRootPath As String
Dim objFileDialog As Object
Dim shApp As Object
Dim i As Long
Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.InitialView = msoFileDialogViewSmallIcons
.Title = "Bitte den Ordner auswählen"
If .Show Then sRootPath = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If sRootPath = "" Then
Exit Sub
End If
dtStart = Now
t(cFilesRead) = 0
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
t(cPathNoReadPerm) = 0
t(cPathSysHid) = 0
t(cLinesCount) = 0
dtStart = Now
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oApp = CreateObject("Shell.Application")
ReDim arrOut(7, 800)
Set oSheet = Sheets.Add
'Titelzeile erstellen
With oSheet.Range("A1:H1")
.Value = Array("Datei", "Typ", "Größe", "Stand", "Ordner", "Betreff", "Kategorie", "Kommentar")
.Interior.ColorIndex = 11
.Font.Color = vbWhite
.Font.Color = vbWhite
.HorizontalAlignment = xlCenter
End With
Set rngStartOut = oSheet.Range("A2")
If oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).Path = sRootPath Then
OVBAde_ReadSubFolder oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).RootFolder
Else
OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End If
'Ausgabe der letzten Daten und Autofit
ReDim Preserve arrOut(UBound(arrOut, 1), t(cLinesCount) - 1)
putArray
oSheet.Columns.AutoFit
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
MsgBox "Files gelesen " & vbTab & ": " & t(cFilesRead) & vbCrLf & _
"Laufzeit " & vbTab & ": " & t(cTimeElapsed) & vbCrLf & vbCrLf & _
"Folder o. Leserechte" & vbTab & ": " & t(cPathNoReadPerm) & vbCrLf & _
"Folder Syst./Hidden" & vbTab & ": " & t(cPathSysHid)
End Sub
Private Sub OVBAde_ReadSubFolder(oFolder As Object)
Dim oSubFolder As Object
Dim oFile As Object
'Testet ob Verzeichnis gelesen werden kann
On Error Resume Next
If Not (oFolder.Files.Count >= 0) Then
t(cPathNoReadPerm) = t(cPathNoReadPerm) + 1
Exit Sub
End If
On Error GoTo 0
Dim shfolder As Object
Dim shfolderitem As Object
Set shfolder = oApp.Namespace(oFolder.Path)
'Alle Dateien durchforsten
For Each oFile In oFolder.Files
If Not oFile Is Nothing Then
Set shfolderitem = shfolder.ParseName(oFile.Name)
Details_auslesen shfolder, shfolderitem
End If
Next
Set shfolder = Nothing
Set shfolderitem = Nothing
'Alle Unterverzeichnisse verarbeiten (rekursiv), die nicht System oder Hidden sind
For Each oSubFolder In oFolder.subfolders
If Not ((oSubFolder.Attributes And (vbSystem + vbHidden)) > 0) Then
OVBAde_ReadSubFolder oSubFolder
Else
t(cPathSysHid) = t(cPathSysHid) + 1
End If
Next oSubFolder
End Sub
Private Sub Details_auslesen(shfolder As Object, item As Object)
Dim lngArrSize As Long
lngArrSize = UBound(arrOut, 2)
If t(cLinesCount) = lngArrSize Then
putArray
End If
arrOut(0, t(cLinesCount)) = item.Name
arrOut(1, t(cLinesCount)) = item.Type
arrOut(2, t(cLinesCount)) = item.Size
arrOut(3, t(cLinesCount)) = item.ModifyDate
arrOut(4, t(cLinesCount)) = shfolder.self.Path
arrOut(5, t(cLinesCount)) = shfolder.GetDetailsOf(item, 22)
arrOut(6, t(cLinesCount)) = shfolder.GetDetailsOf(item, 23)
arrOut(7, t(cLinesCount)) = shfolder.GetDetailsOf(item, 24)
t(cLinesCount) = t(cLinesCount) + 1
t(cFilesRead) = t(cFilesRead) + 1
End Sub
Private Sub putArray()
Dim i As Long
rngStartOut.Resize(UBound(arrOut, 2) + 1, UBound(arrOut, 1) + 1) = WorksheetFunction.Transpose(arrOut)
For i = 0 To UBound(arrOut, 2)
rngStartOut.Offset(i, 0).FormulaR1C1 = "=HYPERLINK(RC[4]&""\" & arrOut(0, i) & """,""" & arrOut(0, i) & """)"
Next
Set rngStartOut = rngStartOut.Offset(t(cLinesCount))
t(cLinesCount) = 0
DoEvents
End Sub
Sub Dateiliste()
Dim objShell As Object, objPath As Object, objFile As Object
Dim arrData, iCnt%
Set objShell = CreateObject("Shell.Application")
Set objPath = objShell.Namespace("c:\test")
ReDim arrData(3, 1000)
'Überschriften eintragen
Range("A1:D1").Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")
'Schleife ueber alle Files
For Each objFile In objPath.Items
'Daten in Array uebernehmen
arrData(0, iCnt) = Replace(objFile.Path, objFile.Name, "")
arrData(1, iCnt) = objFile.Name
arrData(2, iCnt) = objPath.GetDetailsOf(objFile, 24)
arrData(3, iCnt) = objPath.GetDetailsOf(objFile, 25)
'Zaehler fuer Arrayndex hochsetzen
iCnt = iCnt + 1
'Ende Schleife ueber alle Files
Next
'Array entsprechend Anzahl Eintraege kuerzen
ReDim Preserve arrData(3, iCnt - 1)
'Array in Bereich ab Zeile 2 eintragen
Cells(2, 1).Resize(iCnt - 1, 4).Value = WorksheetFunction.Transpose(arrData)
Columns("A:D").AutoFit
'Hyperlink-Formel
Range(Cells(2, 5), Cells(iCnt - 1, 5)).FormulaR1C1 = "=HYPERLINK(RC[-4]&RC[-3],""zur Datei"")"
End Sub
Sub Dateiliste()
Dim objShell As Object, objPath As Object, objFile As Object
Dim arrData, iCnt%
Set objShell = CreateObject("Shell.Application")
Set objPath = objShell.Namespace("c:\test")
ReDim arrData(3, 1000)
'Überschriften eintragen
Range("A1:D1").Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")
'Schleife ueber alle Files
For Each objFile In objPath.Items
'Daten in Array uebernehmen
arrData(0, iCnt) = Replace(objFile.Path, objFile.Name, "")
arrData(1, iCnt) = objFile.Name
arrData(2, iCnt) = objPath.GetDetailsOf(objFile, 24)
arrData(3, iCnt) = objPath.GetDetailsOf(objFile, 25)
'Zaehler fuer Arrayndex hochsetzen
iCnt = iCnt + 1
'Ende Schleife ueber alle Files
Next
'Array entsprechend Anzahl Eintraege kuerzen
ReDim Preserve arrData(3, iCnt - 1)
'Array in Bereich ab Zeile 2 eintragen
Cells(2, 1).Resize(iCnt - 1, 4).Value = WorksheetFunction.Transpose(arrData)
Columns("A:D").AutoFit
'Hyperlink-Formel
Range(Cells(2, 5), Cells(iCnt - 1, 5)).FormulaR1C1 = "=HYPERLINK(RC[-4]&RC[-3],""zur Datei"")"
End Sub
Sub Dateiliste()
Dim objShell As Object, objPath As Object, objFile As Object
Dim arrData, iCnt%
Set objShell = CreateObject("Shell.Application")
Set objPath = objShell.Namespace("c:\test")
ReDim arrData(3, 1000)
'Überschriften eintragen
Range("A1:D1").Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")
'Schleife ueber alle Files
For Each objFile In objPath.Items
'Daten in Array uebernehmen
arrData(0, iCnt) = Replace(objFile.Path, objFile.Name, "")
arrData(1, iCnt) = objFile.Name
arrData(2, iCnt) = objPath.GetDetailsOf(objFile, 24)
arrData(3, iCnt) = objPath.GetDetailsOf(objFile, 25)
'Zaehler fuer Arrayndex hochsetzen
iCnt = iCnt + 1
'Ende Schleife ueber alle Files
Next
'Array entsprechend Anzahl Eintraege kuerzen
ReDim Preserve arrData(3, iCnt - 1)
'Array in Bereich ab Zeile 2 eintragen
Cells(2, 1).Resize(iCnt - 1, 4).Value = WorksheetFunction.Transpose(arrData)
Columns("A:D").AutoFit
'Hyperlink-Formel
Range(Cells(2, 5), Cells(iCnt - 1, 5)).FormulaR1C1 = "=HYPERLINK(RC[-4]&RC[-3],""zur Datei"")"
End Sub
Sub Dateiliste()
Dim objShell As Object, objPath As Object, objFile As Object
Dim arrData, iCnt%
Set objShell = CreateObject("Shell.Application")
Set objPath = objShell.Namespace("c:\test")
ReDim arrData(3, 1000)
'Überschriften eintragen
Range("A1:D1").Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")
'Schleife ueber alle Files
For Each objFile In objPath.Items
'Daten in Array uebernehmen
arrData(0, iCnt) = Replace(objFile.Path, objFile.Name, "")
arrData(1, iCnt) = objFile.Name
arrData(2, iCnt) = objPath.GetDetailsOf(objFile, 24)
arrData(3, iCnt) = objPath.GetDetailsOf(objFile, 25)
'Zaehler fuer Arrayndex hochsetzen
iCnt = iCnt + 1
'Ende Schleife ueber alle Files
Next
'Array entsprechend Anzahl Eintraege kuerzen
ReDim Preserve arrData(3, iCnt - 1)
'Array in Bereich ab Zeile 2 eintragen
Cells(2, 1).Resize(iCnt - 1, 4).Value = WorksheetFunction.Transpose(arrData)
Columns("A:D").AutoFit
'Hyperlink-Formel
Range(Cells(2, 5), Cells(iCnt - 1, 5)).FormulaR1C1 = "=HYPERLINK(RC[-4]&RC[-3],""zur Datei"")"
End Sub
Sub Dateiliste()
Dim objShell As Object, objPath As Object, objFile As Object
Dim arrData, iCnt%
Set objShell = CreateObject("Shell.Application")
Set objPath = objShell.Namespace("c:\test")
ReDim arrData(3, 1000)
'Überschriften eintragen
Range("A1:D1").Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")
'Schleife ueber alle Files
For Each objFile In objPath.Items
'Daten in Array uebernehmen
arrData(0, iCnt) = Replace(objFile.Path, objFile.Name, "")
arrData(1, iCnt) = objFile.Name
arrData(2, iCnt) = objPath.GetDetailsOf(objFile, 24)
arrData(3, iCnt) = objPath.GetDetailsOf(objFile, 25)
'Zaehler fuer Arrayndex hochsetzen
iCnt = iCnt + 1
'Ende Schleife ueber alle Files
Next
'Array entsprechend Anzahl Eintraege kuerzen
ReDim Preserve arrData(3, iCnt - 1)
'Array in Bereich ab Zeile 2 eintragen
Cells(2, 1).Resize(iCnt - 1, 4).Value = WorksheetFunction.Transpose(arrData)
Columns("A:D").AutoFit
'Hyperlink-Formel
Range(Cells(2, 5), Cells(iCnt - 1, 5)).FormulaR1C1 = "=HYPERLINK(RC[-4]&RC[-3],""zur Datei"")"
End Sub