Zurück zur Homepage

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.

Dose.zip 23 kB

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