mit dem weiter unten aufgeführten VBA-Code (hier aus der Newsgroup)
lese ich explizit Dateien bzw. deren Informationen auf einen Laufwerk
aus. Auf dem Laufwerk sind keine weiteren Pfade vorhanden. Diese
Informationen werden dann in einer Exceltabelle ausgegeben. Künftig
werden auch Unterordner auf dem Laufwerk vorhanden sein.
Wie ist dieser VBA-Code umzubauen, damit enthaltene Ordner (eine
Ebene) mit ausgelesen werden und wiederum in einer Exceltabelle – mit
Erweiterung der Ordnerangabe – ausgegeben werden? Ich bekomme den
Wechsel zwischen den Ordner nicht hin, ohne selber im VBA-Code
herumzufummeln. Das will ich eigentich vermeiden.
Hintergrund der Aktion ist, dass Sicherungsdateien auf einer
Festplatte (Laufwerk F:) kopiert werden und der Stand der Dateien
nachts als einfache DateiInformation gesichert werden sollen. Nun ist
die Anzahl der Dateien so groß geworden, dass je Jahr/Monat ein Ordner
(z.B. 2008_08) angelegt wird, so dass auf Laufwerk F: nur noch Pfade
liegen und darin die Dateien enthalten sind.
Bin für jede Hilfe dankbar.
Sub DateiInformationen_auslesen()
'
Dim Blatt As Worksheet
Dim Pfad As String
Dim DatNam As String
Dim i As Integer
'
Set Blatt = ThisWorkbook.Worksheets("Dateiinfos")
Pfad = "F:\"
DatNam = Dir(Pfad)
'
Sheets("Dateiinfos").Select
Range("A3:E10000").ClearContents
Range("A1").Select
'
With Blatt
.Cells(1, 1) = "Pfad:"
.Cells(1, 2) = Pfad
.Cells(2, 2) = "Name"
.Cells(2, 3) = "Datum"
.Cells(2, 4) = "Uhrzeit"
.Cells(2, 5) = "Größe"
.Cells(2, 6) = "Ordner" 'neue Spalte in Tabellenblatt
i = 3
'
Do While DatNam <> ""
.Cells(i, 2) = DatNam
.Cells(i, 3) = Int(FileDateTime(Pfad & DatNam))
.Cells(i, 4) = FileDateTime(Pfad & DatNam) -
Int(FileDateTime(Pfad & DatNam))
.Cells(i, 5) = FileLen(Pfad & DatNam)
'.Cells(i, 6) = 'neuer Eintrag zur Angabe des Ordners (?)
i = i + 1
DatNam = Dir
Loop
'
.Columns("C:C").NumberFormat = "DD.MM.YYYY"
.Columns("D:D").NumberFormat = "hh:mm:ss"
End With
'
End Sub
Schönen Gruß
Hermann
Hallo Hermann.
Das Durchwandern eines Ordners mir Dir() ist IMHO nicht mehr
zeitgemäß. Dafür gibt es Objekte mit extra dafür vorgesehenen
Eigenschaften und Methoden. Zum Beispiel hat das Folder-Object eine
Files-Auflistung und eine SubFolders-Auflistung die man bequem mit
For-Each durchlaufen kann. Siehe dazu auch die Links am Ende diese
Postings.
Peter
Sub DateiInformationen_auslesen_Peter()
Dim fso As Object
Dim ordner As Object
Dim subordner As Variant
Dim file As Variant
Dim i As Integer
Const PFAD = "F:\"
i = 3
Set fso = CreateObject("Scripting.FileSystemObject")
Set ordner = fso.GetFolder(PFAD)
With ThisWorkbook.Worksheets("Dateiinfos")
.[A1].Select
.[A3:F10000].ClearContents
.[A1:B1] = Array("Pfad:", PFAD)
.[B2:F2] = Array("Name","Datum","Uhrzeit","Größe","Ordner")
.[C:C].NumberFormat = "dd.mm.yyyy"
.[D:D].NumberFormat = "hh:mm:ss"
.[E:E].NumberFormat = "#,##0"
For Each file In ordner.Files
.Cells(i, 2) = file.Name
.Cells(i, 3) = DateValue(file.DateLastModified)
.Cells(i, 4) = TimeValue(file.DateLastModified)
.Cells(i, 5) = file.Size
i = i + 1
Next
For Each subordner In ordner.SubFolders
If (subordner.Attributes And 4) = 0 Then
For Each file In subordner.Files
.Cells(i, 2) = file.Name
.Cells(i, 3) = DateValue(file.DateLastModified)
.Cells(i, 4) = TimeValue(file.DateLastModified)
.Cells(i, 5) = file.Size
.Cells(i, 6) = subordner.Name
i = i + 1
Next
End If
Next
.[A:F].EntireColumn.AutoFit
End With
End Sub
Folder-Object:
http://msdn.microsoft.com/en-us/library/1c87day3(VS.85).aspx
File-Object
http://msdn.microsoft.com/en-us/library/1ft05taf(VS.85).aspx
Files-Auflistung:
http://msdn.microsoft.com/en-us/library/wz72a8c0(VS.85).aspx
SubFolders-Auflistung:
http://msdn.microsoft.com/en-us/library/e1dthkks(VS.85).aspx
Hallo Peter,
vielen herzlichen Dank für die Hilfe. Es klappt gut!
Werde mich dann mal den moderneren Programmierabläufen widmen. :-)
Gruß Hermann
Kann ich nur empfehlen. Macht ja auch viel mehr Spaß.
Übrigens: Falls ihr doch mal Sub-Sub-Ordner anlegt (F:\2008\August)
ist es besser die Ordner-Struktur rekursiv zu druchlaufen. Du hattest
zwar eindeutig von nur einer Ebene gesprochen, aber ich poste trotzdem
mal den Code. Prophylaktisch. :-)
Peter
Sub DateiInformationen_auslesen_Peter2()
Const PFAD = "F:\"
With ThisWorkbook.Worksheets("Dateiinfos")
.[A1].Select
.[A3:F65000].ClearContents
.[A1:B1] = Array("Pfad:", PFAD)
.[B2:F2] = Array("Name","Datum","Uhrzeit","Größe","Ordner")
.[C:C].NumberFormat = "dd.mm.yyyy"
.[D:D].NumberFormat = "hh:mm:ss"
.[E:E].NumberFormat = "#,##0"
Call list_files(.[B3:F3], CreateObject( _
"Scripting.FileSystemObject").GetFolder(PFAD))
.[A:F].EntireColumn.AutoFit
End With
End Sub
Sub list_files(r As Range, ordner As Variant)
Dim file As Variant
Dim subordner As Variant
For Each file In ordner.Files
r(1) = file.Name
r(2) = DateValue(file.DateLastModified)
r(3) = TimeValue(file.DateLastModified)
r(4) = file.Size
r(5) = ordner.Path
Set r = r.Offset(1)
Next
For Each subordner In ordner.SubFolders
If (subordner.Attributes And 4) = 0 Then '/System-Ordner/
Call list_files(r, subordner)
End If
Next
End Sub
kann mir als Amateur hier noch jemand weiter helfen und das Script von oben erweitern um die Information "zuletzt gespeichert von"?
Do While DatNam <> ""
.Cells(i, 2) =DatNam
.Cells(i, 3) =Int(FileDateTime(Pfad & DatNam))
.Cells(i, 4) =FileDateTime(Pfad & DatNam) -
Int(FileDateTime(Pfad & DatNam))
.Cells(i, 5) =FileLen(Pfad & DatNam)
'.Cells(i, 6) ='neuer Eintrag zur Angabe des Ordners
(?)
'.Cells(i, 7) ='NEUER EINTRAG MIT "ZULETZT GESPEICHTER VON"
i =3D i + 1
DatNam =3D Dir
Loop
Soweit ich herausgefunden habe findet sich die Info in BuiltinDocumentProperties - aber leider wei? ich nicht, wie ich das hir korrekt einsetzte. Vielen Dank!
Stefan
Peter Schleif wrote:
Re: Dateiinformationen auslesen und in Excel erfassen per VBA-Code
31-Aug-08
Hermann Splitthoff schrieb am 30.08.2008 20:29 Uhr:
Kann ich nur empfehlen. Macht ja auch viel mehr Spa?.
?brigens: Falls ihr doch mal Sub-Sub-Ordner anlegt (F:\2008\August)
ist es besser die Ordner-Struktur rekursiv zu druchlaufen. Du hattest
zwar eindeutig von nur einer Ebene gesprochen, aber ich poste trotzdem
mal den Code. Prophylaktisch. :-)
Peter
Sub DateiInformationen_auslesen_Peter2()
Const PFAD = "F:\"
With ThisWorkbook.Worksheets("Dateiinfos")
.[A1].Select
.[A3:F65000].ClearContents
.[A1:B1] = Array("Pfad:", PFAD)
.[B2:F2] = Array("Name","Datum","Uhrzeit","Gr??e","Ordner")
Previous Posts In This Thread:
On Saturday, August 30, 2008 1:44 PM
Peter Schleif wrote:
Re: Dateiinformationen auslesen und in Excel erfassen per VBA-Code
Hermann Splitthoff schrieb am 30.08.2008 18:21 Uhr:
Hallo Hermann.
Das Durchwandern eines Ordners mir Dir() ist IMHO nicht mehr
zeitgem??. Daf?r gibt es Objekte mit extra daf?r vorgesehenen
Eigenschaften und Methoden. Zum Beispiel hat das Folder-Object eine
Files-Auflistung und eine SubFolders-Auflistung die man bequem mit
For-Each durchlaufen kann. Siehe dazu auch die Links am Ende diese
Postings.
Peter
Sub DateiInformationen_auslesen_Peter()
Dim fso As Object
Dim ordner As Object
Dim subordner As Variant
Dim file As Variant
Dim i As Integer
Const PFAD = "F:\"
i = 3
Set fso = CreateObject("Scripting.FileSystemObject")
Set ordner = fso.GetFolder(PFAD)
With ThisWorkbook.Worksheets("Dateiinfos")
.[A1].Select
.[A3:F10000].ClearContents
.[A1:B1] = Array("Pfad:", PFAD)
.[B2:F2] = Array("Name","Datum","Uhrzeit","Gr??e","Ordner")
.[C:C].NumberFormat = "dd.mm.yyyy"
.[D:D].NumberFormat = "hh:mm:ss"
.[E:E].NumberFormat = "#,##0"
For Each file In ordner.Files
.Cells(i, 2) = file.Name
.Cells(i, 3) = DateValue(file.DateLastModified)
.Cells(i, 4) = TimeValue(file.DateLastModified)
.Cells(i, 5) = file.Size
i = i + 1
Next
For Each subordner In ordner.SubFolders
If (subordner.Attributes And 4) = 0 Then
For Each file In subordner.Files
.Cells(i, 2) = file.Name
.Cells(i, 3) = DateValue(file.DateLastModified)
.Cells(i, 4) = TimeValue(file.DateLastModified)
.Cells(i, 5) = file.Size
.Cells(i, 6) = subordner.Name
i = i + 1
Next
End If
Next
.[A:F].EntireColumn.AutoFit
End With
End Sub
Folder-Object:
http://msdn.microsoft.com/en-us/library/1c87day3(VS.85).aspx
File-Object
http://msdn.microsoft.com/en-us/library/1ft05taf(VS.85).aspx
Files-Auflistung:
http://msdn.microsoft.com/en-us/library/wz72a8c0(VS.85).aspx
SubFolders-Auflistung:
http://msdn.microsoft.com/en-us/library/e1dthkks(VS.85).aspx
On Saturday, August 30, 2008 3:17 PM
Hermann Splitthoff wrote:
Dateiinformationen auslesen und in Excel erfassen per VBA-Code
Hallo liebe Leute,
mit dem weiter unten aufgef=FChrten VBA-Code (hier aus der Newsgroup)
lese ich explizit Dateien bzw. deren Informationen auf einen Laufwerk
aus. Auf dem Laufwerk sind keine weiteren Pfade vorhanden. Diese
Informationen werden dann in einer Exceltabelle ausgegeben. K=FCnftig
werden auch Unterordner auf dem Laufwerk vorhanden sein.
Wie ist dieser VBA-Code umzubauen, damit enthaltene Ordner (eine
Ebene) mit ausgelesen werden und wiederum in einer Exceltabelle =96 mit
Erweiterung der Ordnerangabe =96 ausgegeben werden? Ich bekomme den
Wechsel zwischen den Ordner nicht hin, ohne selber im VBA-Code
herumzufummeln. Das will ich eigentich vermeiden.
Hintergrund der Aktion ist, dass Sicherungsdateien auf einer
Festplatte (Laufwerk F:) kopiert werden und der Stand der Dateien
nachts als einfache DateiInformation gesichert werden sollen. Nun ist
die Anzahl der Dateien so gro=DF geworden, dass je Jahr/Monat ein Ordner
(z.B. 2008_08) angelegt wird, so dass auf Laufwerk F: nur noch Pfade
liegen und darin die Dateien enthalten sind.
Bin f=FCr jede Hilfe dankbar.
Sub DateiInformationen_auslesen()
'
Dim Blatt As Worksheet
Dim Pfad As String
Dim DatNam As String
Dim i As Integer
'
Set Blatt =3D ThisWorkbook.Worksheets("Dateiinfos")
Pfad =3D "F:\"
DatNam =3D Dir(Pfad)
'
Sheets("Dateiinfos").Select
Range("A3:E10000").ClearContents
Range("A1").Select
'
With Blatt
.Cells(1, 1) =3D "Pfad:"
.Cells(1, 2) =3D Pfad
.Cells(2, 2) =3D "Name"
.Cells(2, 3) =3D "Datum"
.Cells(2, 4) =3D "Uhrzeit"
.Cells(2, 5) =3D "Gr=F6=DFe"
.Cells(2, 6) =3D "Ordner" 'neue Spalte in Tabellenblatt
i =3D 3
'
Do While DatNam <> ""
.Cells(i, 2) =3D DatNam
.Cells(i, 3) =3D Int(FileDateTime(Pfad & DatNam))
.Cells(i, 4) =3D FileDateTime(Pfad & DatNam) -
Int(FileDateTime(Pfad & DatNam))
.Cells(i, 5) =3D FileLen(Pfad & DatNam)
'.Cells(i, 6) =3D 'neuer Eintrag zur Angabe des Ordners (?)
i =3D i + 1
DatNam =3D Dir
Loop
'
.Columns("C:C").NumberFormat =3D "DD.MM.YYYY"
.Columns("D:D").NumberFormat =3D "hh:mm:ss"
End With
'
End Sub
Sch=F6nen Gru=DF
Hermann
On Saturday, August 30, 2008 3:17 PM
Hermann Splitthoff wrote:
Re: Dateiinformationen auslesen und in Excel erfassen per VBA-Code
Hallo Peter,
vielen herzlichen Dank f=FCr die Hilfe. Es klappt gut!
Werde mich dann mal den moderneren Programmierabl=E4ufen widmen. :-)
Gru=DF Hermann
On Sunday, August 31, 2008 5:59 AM
Peter Schleif wrote:
Re: Dateiinformationen auslesen und in Excel erfassen per VBA-Code
Hermann Splitthoff schrieb am 30.08.2008 20:29 Uhr:
Kann ich nur empfehlen. Macht ja auch viel mehr Spa?.
?brigens: Falls ihr doch mal Sub-Sub-Ordner anlegt (F:\2008\August)
ist es besser die Ordner-Struktur rekursiv zu druchlaufen. Du hattest
zwar eindeutig von nur einer Ebene gesprochen, aber ich poste trotzdem
mal den Code. Prophylaktisch. :-)
Peter
Sub DateiInformationen_auslesen_Peter2()
Const PFAD = "F:\"
With ThisWorkbook.Worksheets("Dateiinfos")
.[A1].Select
.[A3:F65000].ClearContents
.[A1:B1] = Array("Pfad:", PFAD)
.[B2:F2] = Array("Name","Datum","Uhrzeit","Gr??e","Ordner")
Submitted via EggHeadCafe - Software Developer Portal of Choice
Adding WCF Service References
http://www.eggheadcafe.com/tutorials/aspnet/a1647f10-9aa4-4b0c-bbd9-dfa51a9fab8e/adding-wcf-service-refere.aspx
> kann mir als Amateur hier noch jemand weiter helfen und das Script von oben erweitern um die Information "zuletzt gespeichert von"?
...
> Soweit ich herausgefunden habe findet sich die Info in BuiltinDocumentProperties - aber leider wei? ich nicht, wie ich das hir korrekt einsetzte. Vielen Dank!
Nun ja, es gibt in den BuiltinDocumentProperties zwar eine
"Letzter Autor"-Eigenschaft, aber wie der Name schon sagt sind diese
Eigenschaften "BuildIn" und extern nicht zugänglich.
Das bedeutet Du müsstest jede Datei einzeln öffnen um diese
Eigenschaft auslesen zu können.
Andreas.
On Thu, 18 Mar 2010 17:39:40 +0100, Andreas Killer wrote:
>> Soweit ich herausgefunden habe findet sich die Info in BuiltinDocumentProperties - aber leider wei? ich nicht, wie ich das hir korrekt einsetzte. Vielen Dank!
> Nun ja, es gibt in den BuiltinDocumentProperties zwar eine
> "Letzter Autor"-Eigenschaft, aber wie der Name schon sagt sind diese
> Eigenschaften "BuildIn" und extern nicht zugänglich.
> Das bedeutet Du müsstest jede Datei einzeln öffnen um diese
> Eigenschaft auslesen zu können.
mit Bordmitteln kannst du tatsächlich nur die Datei öffnen und
anschließend diese Eigenschaften auslesen.
Microsoft stellt aber bereits seit Jahren die Dll DsoFile.dll bereit,
mit der man die Eigenschaften von OLE-Dokumenten auslesen und sogar
ändern kann. Die neuste wurde vom Office-Team wurde für die Verwendung
mit .NET-Programmiersprachen entworfen, kann aber problemlos mit VBA
benutzt werden. Ist aber alles ohne offiziellen Support oder einer
Garantie!
Wenn man diese auf dem System registriert (regsvr32.exe), funktioniert
aber der Code nicht mehr, der auf die alte zugeschnitten war. In
Firmennetzwerken muss man auch immer erst einmal die Erlaubnis haben,
die Datei überhaupt zu installieren.
Hier mal auf die Schnelle etwas Code dazu:
Public Sub TestDSOFile()
Dim varRet As Variant
Dim colInfos As Collection
Dim strResult As String
varRet = Application.GetOpenFilename( _
"Excel Files (*.xls;*.xlsm;*.xlsx), *.xls;*.xlsm;*.xlsx" & _
",Word Files (*.doc;*.docm;*.docx), *.doc;*.docm;*.docx" & _
",All Files (*.*), *.*")
If varRet <> False Then
Set colInfos = GetBuiltInProps(CStr(varRet))
End If
On Error Resume Next
' Möglich sind auch andere Objekte, nicht nur Strings,
' der Einfachheit halber die Fehlerbehandlung
For Each varRet In colInfos("ItemNames")
strResult = strResult & varRet & " : " & _
CStr(colInfos(CStr(varRet))) & vbCrLf
Next
' Ausgabe in einer Messagebox, möglicherweise werden nicht alle
' Zeilen dargestellt, dann in der Schleife vbCrLf durch ein
' paar Leerzeichen ersetzen
strResult = Left(strResult, Len(strResult) - 2)
MsgBox strResult
End Sub
Public Function GetBuiltInProps(strFile As String) As Collection
Dim objFile As Object
Dim objCustomProp As Object
Dim colResult As New Collection
Dim colItems As New Collection
' Code zum Testen der dsofile.dll von M$.
' OLE Document Properties können mittels
' der dsofile.dll ausgelesen und geschrieben
' werden. Frei bei M$, aber ohne Support
' Link bitte in eine Zeile
' Einige Erklärungen: http://support.microsoft.com/kb/224351/de
' Download:
http://www.microsoft.com/downloads/details.aspx?FamilyId=9BA6FAC6-520B-4A0A-878A-53EC8300C4C2&displaylang=en
Set objFile = CreateObject("DSOFile.OleDocumentProperties")
objFile.Open strFile
On Error Resume Next
Set colDummy = New Collection
With objFile.SummaryProperties
colItems.Add "ApplicationName"
colResult.Add .ApplicationName, "ApplicationName"
colItems.Add "Author"
colResult.Add .Author, "Author"
colItems.Add "ByteCount"
colResult.Add .ByteCount, "ByteCount"
colItems.Add "Category"
colResult.Add .Category, "Category"
colItems.Add "CharacterCount"
colResult.Add .CharacterCount, "CharacterCount"
colItems.Add "CharacterCountWithSpaces"
colResult.Add .CharacterCountWithSpaces, "CharacterCountWithSpaces"
colItems.Add "Comments"
colResult.Add .Comments, "Comments"
colItems.Add "Company"
colResult.Add .Company, "Company"
colItems.Add "DateCreated"
colResult.Add .DateCreated, "DateCreated"
colItems.Add "DateLastPrinted"
colResult.Add .DateLastPrinted, "DateLastPrinted"
colItems.Add "DateLastSaved"
colResult.Add .DateLastSaved, "DateLastSaved"
colItems.Add "DigitalSignature"
colResult.Add .DigitalSignature, "DigitalSignature"
colItems.Add "DocumentSecurity"
colResult.Add .DocumentSecurity, "DocumentSecurity"
colItems.Add "HiddenSlideCount"
colResult.Add .HiddenSlideCount, "HiddenSlideCount"
colItems.Add "Keywords"
colResult.Add .Keywords, "Keywords"
colItems.Add "LastSavedBy"
colResult.Add .LastSavedBy, "LastSavedBy"
colItems.Add "LineCount"
colResult.Add .LineCount, "LineCount"
colItems.Add "Manager"
colResult.Add .Manager, "Manager"
colItems.Add "MultimediaClipCount"
colResult.Add .MultimediaClipCount, "MultimediaClipCount"
colItems.Add "NoteCount"
colResult.Add .NoteCount, "NoteCount"
colItems.Add "PageCount"
colResult.Add .PageCount, "PageCount"
colItems.Add "ParagraphCount"
colResult.Add .ParagraphCount, "ParagraphCount"
colItems.Add "PresentationFormat"
colResult.Add .PresentationFormat, "PresentationFormat"
colItems.Add "RevisionNumber"
colResult.Add .RevisionNumber, "RevisionNumber"
colItems.Add "SharedDocument"
colResult.Add .SharedDocument, "SharedDocument"
colItems.Add "SlideCount"
colResult.Add .SlideCount, "SlideCount"
colItems.Add "Subject"
colResult.Add .Subject, "Subject"
colItems.Add "Template"
colResult.Add .Template, "Template"
colItems.Add "Thumbnail"
colResult.Add .Thumbnail, "Thumbnail"
colItems.Add "Title"
colResult.Add .Title, "Title"
colItems.Add "TotalEditTime"
colResult.Add .TotalEditTime, "TotalEditTime"
colItems.Add "Version"
colResult.Add .Version, "Version"
colItems.Add "WordCount"
colResult.Add .WordCount, "WordCount"
End With
With objFile
colItems.Add "CLSID"
colResult.Add .CLSID, "CLSID"
colItems.Add "IsDirty"
colResult.Add .IsDirty, "IsDirty"
colItems.Add "ProgID"
colResult.Add .ProgID, "ProgID"
colItems.Add "CustomPropertiesCount"
colResult.Add .CustomProperties.Count, "CustomPropertiesCount"
For Each objCustomProp In .CustomProperties
colItems.Add objCustomProp.Name
colResult.Add objCustomProp.Value, objCustomProp.Name
Next
End With
colResult.Add colItems, "ItemNames", 1
Set GetBuiltInProps = colResult
End Function
Link zur Datei im Quellcode!
Viele Grüße
Michael