OLE Dokumentinfos
Excel, Word, PowerPoint speichern Dokumentinfos in der Datei. Microsoft bietet
eine .dll an, mit der solche Infos ausgelesen werden können, sogar ohne
die zugehörigen Programme. Diese Dynamic Link Library (dsofile.dll)
kann bei Microsoft http://support.microsoft.com/default.aspx?scid=kb;en-us;224351
heruntergeladen werden und ist Freeware.
Option Explicit
Private Type MyDateiinfos
Pfad As String
AppName As String
Author As String
ByteCount As Long
Category As String
CharacterCount As Long
CharacterCountWithSpaces As Long
CLSID As String
Comments As String
Company As String
DateCreated As Date
DateLastPrinted As Date
DateLastSaved As Date
HasMacros As Boolean
HiddenSlides As Long
IsReadOnly As Boolean
Keywords As String
LastEditedBy As String
LineCount As Long
Location As String
Manager As String
MultimediaClips As Long
Name As String
PageCount As Long
ParagraphCount As Long
PresentationFormat As String
PresentationNotes As Long
ProgID As String
RevisionNumber As String
SlideCount As Long
Subject As String
Template As String
Title As String
TotalEditTime As Date
Version As String
WordCount As Long
CustomProperties As Long
UserDefinedProp(1 To 20) As String
End Type
Private MyDoseObj As New DSOleFile.PropertyReader
Private MyDose As DSOleFile.DocumentProperties
Private MyCustomProp As DSOleFile.CustomProperty
Private Dateiinfos() As MyDateiinfos
Dim DateiZähler As Long
Sub DSOFILE()
'Code zum Testen der dsofile.dll von M$.
'OLE Document Properties können mittels
'dieser dll ausgelesen und geschrieben
'werden. Free bei M$, aber ohne Support
' http://support.microsoft.com/search/preview.aspx?scid=kb;en-us;Q224351
'Verweis auf 'OLE Document Properties'
Dim Anfangspfad As String, i As Long, Zähler As Long
On Error Resume Next
ReDim Dateiinfos(1 To 1000)
'Den Anfangspfad holen
Anfangspfad = VerzeichnisWählen()
'Wenn nichts gewählt, beenden
If Anfangspfad = "" Then Exit Sub
DateiZähler = 0
'Infos holen, Dateifilter : keiner
MyOleListe Anfangspfad, "*"
'Array initialisieren
ReDim Preserve Dateiinfos(1 To DateiZähler)
Zähler = 1
With Sheets("OLE")
.Range("A3:IV10000").ClearContents '
Zellinhalte löschen
Application.ScreenUpdating = False 'Bildschirmaktualisierung
aus
For Zähler = 1 To DateiZähler
'Informationen
ins Blatt eintragen
.Cells(Zähler + 2, 1) =
Dateiinfos(Zähler).Name
.Hyperlinks.Add Anchor:=.Cells(Zähler
+ 2, 2), _
Address:=Dateiinfos(Zähler).Pfad
.Cells(Zähler + 2, 3) =
Dateiinfos(Zähler).AppName
.Cells(Zähler + 2, 4) =
Dateiinfos(Zähler).Author
.Cells(Zähler + 2, 5) =
Dateiinfos(Zähler).ByteCount
.Cells(Zähler + 2, 6) =
Dateiinfos(Zähler).Category
.Cells(Zähler + 2, 7) =
Dateiinfos(Zähler).CharacterCount
.Cells(Zähler + 2, 8) =
Dateiinfos(Zähler).CharacterCountWithSpaces
.Cells(Zähler + 2, 9) =
Dateiinfos(Zähler).CLSID
.Cells(Zähler + 2, 10)
= Dateiinfos(Zähler).Comments
.Cells(Zähler + 2, 11)
= Dateiinfos(Zähler).Company
.Cells(Zähler + 2, 12)
= Dateiinfos(Zähler).DateCreated
.Cells(Zähler + 2, 12).NumberFormat
= "dd.MM.YYYY hh:mm"
.Cells(Zähler + 2, 13)
= Dateiinfos(Zähler).DateLastPrinted
.Cells(Zähler + 2, 13).NumberFormat
= "dd.MM.YYYY hh:mm"
.Cells(Zähler + 2, 14)
= Dateiinfos(Zähler).DateLastSaved
.Cells(Zähler + 2, 14).NumberFormat
= "dd.MM.YYYY hh:mm"
.Cells(Zähler + 2, 15)
= Dateiinfos(Zähler).HasMacros
.Cells(Zähler + 2, 16)
= Dateiinfos(Zähler).HiddenSlides
.Cells(Zähler + 2, 17)
= Dateiinfos(Zähler).IsReadOnly
.Cells(Zähler + 2, 18)
= Dateiinfos(Zähler).Keywords
.Cells(Zähler + 2, 19)
= Dateiinfos(Zähler).LastEditedBy
.Cells(Zähler + 2, 20)
= Dateiinfos(Zähler).LineCount
.Cells(Zähler + 2, 21)
= Dateiinfos(Zähler).Location
.Cells(Zähler + 2, 22)
= Dateiinfos(Zähler).MultimediaClips
.Cells(Zähler + 2, 23)
= Dateiinfos(Zähler).Manager
.Cells(Zähler + 2, 24)
= Dateiinfos(Zähler).PageCount
.Cells(Zähler + 2, 25)
= Dateiinfos(Zähler).ParagraphCount
.Cells(Zähler + 2, 26)
= Dateiinfos(Zähler).PresentationFormat
.Cells(Zähler + 2, 27)
= Dateiinfos(Zähler).PresentationNotes
.Cells(Zähler + 2, 28)
= Dateiinfos(Zähler).ProgID
.Cells(Zähler + 2, 29)
= Dateiinfos(Zähler).RevisionNumber
.Cells(Zähler + 2, 30)
= Dateiinfos(Zähler).SlideCount
.Cells(Zähler + 2, 31)
= Dateiinfos(Zähler).Subject
.Cells(Zähler + 2, 32)
= Dateiinfos(Zähler).Template
.Cells(Zähler + 2, 33)
= Dateiinfos(Zähler).Title
.Cells(Zähler + 2, 34)
= Dateiinfos(Zähler).TotalEditTime
.Cells(Zähler + 2, 34).NumberFormat
= "[h]:mm"
.Cells(Zähler + 2, 35)
= Dateiinfos(Zähler).Version
.Cells(Zähler + 2, 36)
= Dateiinfos(Zähler).WordCount
For i = 1 To UBound(Dateiinfos(Zähler).UserDefinedProp)
If CStr(Dateiinfos(Zähler).UserDefinedProp(i))
= "" Then Exit For
'Benutzerdefinierte Infos eintragen, falls vorhanden
.Cells(Zähler
+ 2, 36 + i) = Dateiinfos(Zähler).UserDefinedProp(i)
Next
Next
End With
Application.ScreenUpdating = True 'Bildschirmaktualisierung
ein
Application.StatusBar = False
Erase Dateiinfos 'Speicher freigeben
End Sub
Private Sub MyOleListe(startdir As String, Filter As String)
Dim V() As String, Zähler As Long, Dateiname As String
Dim aktVerz As String, i As Long
On Error Resume Next
If Left$(Filter, 1) <> "." Then Filter = "." &
Filter
ReDim V(1 To 100)
If Right$(startdir, 1) <> "\" Then
'Nachschauen, ob übergebener
Pfad auch einen Backslash enthält.
'Wenn nicht, dann anhängen
startdir = startdir & "\"
End If
aktVerz = startdir
startdir = startdir & "*"
Dateiname = Dir$(startdir, vbDirectory Or vbNormal)
Do While Dateiname <> ""
If GetAttr(aktVerz & Dateiname) And vbDirectory
Then
'wenn Datei
ein Verzeichnis ist
If Right$(Dateiname, 1) <>
"." Then
'und zwar ein untergeordnetes,
Zähler
= Zähler + 1
'dann
ein Array mit Verzeichnissen füllen.
If Zähler
> UBound(V) Then
ReDim
Preserve V(1 To Zähler + 1)
End
If
V(Zähler)
= Dateiname
End If
Else
'Handelt
es sich um eine Datei,
If LCase(Right$(Dateiname, Len(Filter)))
= LCase(Filter) Or Filter = ".*" Then
'und entspricht sie noch den Filterbedingungen,
Application.StatusBar
= "Dateiinfos (" & DateiZähler - 1 & ") = "
& aktVerz & Dateiname
Err.Clear
Set
MyDose = MyDoseObj.GetDocumentProperties(aktVerz & Dateiname)
If Err.Number
= 0 Then
'Datei enthält OLE DocumentProperties
With
MyDose
'und Infos in Liste schreiben.
DateiZähler
= DateiZähler + 1
If
DateiZähler > UBound(Dateiinfos) Then _
ReDim
Preserve Dateiinfos(1 To UBound(Dateiinfos) + 1000)
Dateiinfos(DateiZähler).Pfad
= aktVerz & "\" & Dateiname
Dateiinfos(DateiZähler).AppName
= .AppName
Dateiinfos(DateiZähler).Author
= .Author
Dateiinfos(DateiZähler).ByteCount
= .ByteCount
Dateiinfos(DateiZähler).Category
= .Category
Dateiinfos(DateiZähler).CharacterCount
= .CharacterCount
Dateiinfos(DateiZähler).CharacterCountWithSpaces
= .CharacterCountWithSpaces
Dateiinfos(DateiZähler).CLSID
= .CLSID
Dateiinfos(DateiZähler).Comments
= .Comments
Dateiinfos(DateiZähler).Company
= .Company
Dateiinfos(DateiZähler).CustomProperties
= .CustomProperties.Count
Dateiinfos(DateiZähler).DateCreated
= .DateCreated
Dateiinfos(DateiZähler).DateLastPrinted
= .DateLastPrinted
Dateiinfos(DateiZähler).DateLastSaved
= .DateLastSaved
Dateiinfos(DateiZähler).HasMacros
= .HasMacros
Dateiinfos(DateiZähler).HiddenSlides
= .HiddenSlides
Dateiinfos(DateiZähler).IsReadOnly
= .IsReadOnly
Dateiinfos(DateiZähler).Keywords
= .Keywords
Dateiinfos(DateiZähler).LastEditedBy
= .LastEditedBy
Dateiinfos(DateiZähler).LineCount
= .LineCount
Dateiinfos(DateiZähler).Location
= .Location
Dateiinfos(DateiZähler).Manager
= .Manager
Dateiinfos(DateiZähler).MultimediaClips
= .MultimediaClips
Dateiinfos(DateiZähler).Name
= .Name
Dateiinfos(DateiZähler).PageCount
= .PageCount
Dateiinfos(DateiZähler).ParagraphCount
= .ParagraphCount
Dateiinfos(DateiZähler).PresentationFormat
= .PresentationFormat
Dateiinfos(DateiZähler).PresentationNotes
= .PresentationNotes
Dateiinfos(DateiZähler).ProgID
= .ProgID
Dateiinfos(DateiZähler).RevisionNumber
= .RevisionNumber
Dateiinfos(DateiZähler).SlideCount
= .SlideCount
Dateiinfos(DateiZähler).Subject
= .Subject
Dateiinfos(DateiZähler).Template
= .Template
Dateiinfos(DateiZähler).Title =
.Title
Dateiinfos(DateiZähler).TotalEditTime
= .TotalEditTime
Dateiinfos(DateiZähler).Version
= .Version
Dateiinfos(DateiZähler).WordCount
= .WordCount
i
= 0
For
Each MyCustomProp In .CustomProperties
i
= i + 1 'Benutzerdefinierte Infos in das Array, falls vorhanden
Dateiinfos(DateiZähler).UserDefinedProp(i)
= MyCustomProp.Name & _
"
= " & CStr(MyCustomProp.Value)
Next
End
With
End
If
End If
End If
Dateiname = Dir$()
Loop
'Jetzt erst werden die Unterverzeichnisse abgearbeitet,
'weil Dir$ mit Rekursionen nicht klarkommt.
If Zähler = 0 Then Exit Sub
ReDim Preserve V(1 To Zähler)
For Zähler = 1 To UBound(V)
'Jetzt ruft sich diese Funktion
noch mal auf.
MyOleListe aktVerz & V(Zähler), Filter
Next
End Sub
'---------------------------------------------------------------------------
'Zur Auswahl eines Verzeichnisses folgenden Code
Option Explicit
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
_
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO)
_
As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
_
"SHGetPathFromIDListA" (ByVal pidl As Long,
_
ByVal pszPath As String) As Long
Private 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
Private Const BIF_RETURNONLYFSDIRS = &H1
Public Function VerzeichnisWählen() As String
Dim Ret As Long
Dim Browse As BROWSEINFO
Dim Liste As Long
Dim Pfad As String, wPos As Integer
Browse.lpszTitle = "Bitte ein Startverzeichnis wählen"
Browse.ulFlags = BIF_RETURNONLYFSDIRS
Liste = SHBrowseForFolder(Browse)
Pfad = String(1024, 0)
Ret = SHGetPathFromIDList(ByVal Liste, ByVal Pfad)
If Ret Then
VerzeichnisWählen = NullTrim(Pfad)
End If
End Function
Private Function NullTrim(a As String) As String
Dim Zähler As Long, b As String
For Zähler = 1 To Len(a)
b = Mid$(a, Zähler, 1)
If (Asc(b) > 31) And (Asc(b) < 128) Then
NullTrim = NullTrim & b
End If
Next
NullTrim = Trim(NullTrim)
End Function