Auslesen von Datei-Eigenschaften via VBA-Script in Word

  • #1
E

Emanuel

Guest
Hallo,

ist es mit VBA für Word möglich die erweiterten Datei-Eigenschaften wie Titel, Thema, Autor, Manager, usw. auszulesen. In meinen Fall wäre das entsprechende Dokument auch schon offen.
:D Ich bin für jede Antwort dankbar.
 
  • #2
Hallo Emanuel,

der folgende Makro erstellt eine Tabelle und listet die Dokumenteneigenschaften auf:
- Name der Eigenschaft
- Index der Eigenschaft
- Wert der Eigenschaft

Am Ende stehen 2 Beispiele für den Zugriff auf die Eigenschaft->Titel', einmal über den Namen und einmal über den Index.

Gruß Matjes ;)

Code: 
Option Explicit

Sub DocumentEigenschaftenAuflisten()

  Dim p As Variant, my_tab As Table, z As Long, l_index As Long
  
 ->Schreibmarke ans Ende des Dokumentes stellen
  Selection.WholeStory
  Selection.Collapse Direction:=wdCollapseEnd
  
 ->Absatz einfügen
  With Selection
    .InsertParagraphAfter: .Collapse Direction:=wdCollapseEnd
    .Font.Bold = True: .Font.Size = 14: .Font.Name = Tahoma
    .InsertAfter Dokument Eigenschaften
    .InsertAfter vbCrLf
    .Collapse Direction:=wdCollapseEnd
  End With

 ->Tabelle einfügen:
 ->Zeilen entsprechend der Anzahl Eigenschaften +1 für Überchrift
  With Selection
    .Font.Bold = False: .Font.Size = 10: .Font.Name = Tahoma
    .InsertParagraphAfter
    .Collapse Direction:=wdCollapseEnd
    .InsertParagraphAfter
  End With
  Set my_tab = ActiveDocument.Tables.Add(Selection.Range, _
      ActiveDocument.BuiltInDocumentProperties.Count + 1, 3)
    
 ->Zeilenindex auf Anfang
  z = 1
 ->Tabellen-Überschriften
  my_tab.Cell(z, 1).Range.InsertAfter Name
  my_tab.Cell(z, 1).Range.Font.Bold = True
  my_tab.Cell(z, 2).Range.InsertAfter Index
  my_tab.Cell(z, 2).Range.Font.Bold = True
  my_tab.Cell(z, 3).Range.InsertAfter Wert
  my_tab.Cell(z, 3).Range.Font.Bold = True
 ->Zeilenindex auf nächste Zeile
  z = z + 1
 ->Name,Index und Wert der Eigenschaften in Tabelle eintragen
  l_index = 0
  For Each p In ActiveDocument.BuiltInDocumentProperties
    my_tab.Cell(z, 1).Range.InsertAfter p.Name
    l_index = l_index + 1
    my_tab.Cell(z, 2).Range.InsertAfter l_index
    On Error GoTo LeererWert
    my_tab.Cell(z, 3).Range.InsertAfter p.Value
   ->Zeilenindex weiterschalten
    z = z + 1
  Next
  On Error GoTo 0
  
 ->optimale Breite der Spalten setzen
  For l_index = 1 To 3
    my_tab.Columns(l_index).AutoFit
  Next
  
 ->Schreibmarke hinter die Tabelle
  my_tab.Select
  Selection.Collapse Direction:=wdCollapseEnd
  Selection.InsertParagraphAfter
  Selection.Collapse Direction:=wdCollapseEnd

  Selection.InsertAfter _
    Auf die DokumentEigenschaften kann über  & _
    den Namen oder den Index zugegriffen werden.  & _
    Dazu zwei Beispiele für den Zugriff auf->Titel': & _
    vbCrLf & vbCrLf & _
    Index: & vbCrLf & _
    ActiveDocument.BuiltInDocumentProperties(Title).Value & _
     = Titel über Name gesetzt & _
    Name: & vbCrLf & _
    ActiveDocument.BuiltInDocumentProperties(1).Value & _
     = Titel über Index gesetzt
  
  Set my_tab = Nothing
Exit Sub
LeererWert:
  my_tab.Cell(z, 3).Range.InsertAfter kein Wert
  Resume Next
End Sub

Sub DocEigenscaften_Setzen1()
  ActiveDocument.BuiltInDocumentProperties(Title).Value = Titel über Name gesetzt
End Sub
Sub DocEigenscaften_Setzen2()
  ActiveDocument.BuiltInDocumentProperties(1).Value = Titel über Index gesetzt
End Sub
 
  • #3
Ola,

vielleicht ist noch anzumerken, dass es für die meisten dieser Eigenschaften auch einfache Feldfunktionen gibt, mit denen die Eigenschaften ohne Makro einfach in den Text gezogen werden können ;)
 
  • #4
Hi PCDJoe,

da hast Du völlig Recht. :D

Über Einfügen->Feld->Dokument-Informationen->Eigenschaft sind die gängigsten zu erreichen.

Alle, bei denen der Datenschutz nicht zuschlägt, sind über
Einfügen->Feld->Dokument-Informationen->Dok-Eigenschaften->Optionen->Eigenschaft->hinzufügen->OK
zu erreichen.

Die wegen Datenschutz nicht auswählbaren nur per selbsteditiertem Feld:
Einfügen->Feld->Dokument-Informationen->Dok-Eigenschaft
{DOKEIGENSCHAFT Name \* FORMATVERBINDEN}

Weiterhin hab ich den Makro noch bzgl. benutzerdefinierter Dokument-Eigenschaften erweitert. Verlinkung zu Textmarken wird auch ausgegeben. Die Ausgabe erfolgt jetzt in einem neuangelegten Dokument.

Weiterhin sind folgende Beispiele angefügt:
- MyPropertie_AddAsCustomBuildProperties
Einfügen einer benutzerdefinierten Dokument-Eigenschaft
- MyPropertie_InsertFieldInText
Einfügen eines Feldes in den Text mit der benutzerdefinierten Eigenschaft.


Gruß Matjes ;)

Code: 
Option Explicit
'****************************************************************
Sub BuildinDocumentEigenschaftenAuflisten()
  Dim s_Text1 As String, s_Text2 As String
  s_Text1 = _
    Auf die Dokument-Eigenschaften kann über  & _
    Name oder Index zugegriffen werden.  & vbCrLf & _
    Dazu zwei Beispiele für den Zugriff auf->Titel': & _
    vbCrLf & vbCrLf & _
    Index:  & _
    ActiveDocument.BuiltInDocumentProperties(Title).Value & _
     = Titel über Name gesetzt & vbCrLf & _
    Name:  & _
    ActiveDocument.BuiltInDocumentProperties(1).Value & _
     = Titel über Index gesetzt & vbCrLf & vbCrLf & _
    BuildinDocumentProperties sind die fest vorgegebenen Dokument-Eigenschaften.
  
  s_Text2 = vbCrLf & vbCrLf & _
    Einfügen lassen sich die meisten Dokument-Eigenschaften über ein Feld  & vbCrLf & _
   ->Dok-Eigenschaft' + Name & vbCrLf & _
    {DOKEIGENSCHAFT Name \* FORMATVERBINDEN} & vbCrLf & _
    zu erreichen über: & vbCrLf & _
    Einfügen->Feld->Dokument-Informationen->Dok-Eigenschaften->Optionen->Eigenschaft->hinzufügen->OK & _
    vbCrLf & _
    Darüber nicht erreichbare Eigenschaften können per Makro eingefügt werden.
  Call DocumentEigenschaftenAuflisten( _
        ActiveDocument.BuiltInDocumentProperties, _
        BuildInDocumentProperties, _
        s_Text1, s_Text2)
End Sub
'****************************************************************
Sub CustomDocumentEigenschaftenAuflisten()
  Dim s_Text1 As String, s_Text2 As String
  s_Text1 = _
    Auf die Dokument-Eigenschaften kann über  & _
    CustomDocumentProperties(Name) oder  & _
    CustomDocumentProperties(Index) zugegriffen werden.  & _
     (analog zu BiuldInDocumentProperties) & _
    vbCrLf & vbCrLf & _
    CustomDocumentProperties sind die selbstdefinierten  & _
    Dokument-Eigenschaften. & vbCrLf & _
    Per Add-Methode können hier Dokument-Eigenschaften hinzugefügt werden.
  
  s_Text2 = vbCrLf & vbCrLf & _
    Einfügen lassen sich die Dokument-Eigenschaften über ein Feld  & vbCrLf & _
   ->Dok-Eigenschaft' + Name & vbCrLf & _
    {DOKEIGENSCHAFT Name \* FORMATVERBINDEN} & vbCrLf & _
    zu erreichen über: & vbCrLf & _
    Einfügen->Feld->Dokument-Informationen->Dok-Eigenschaften->Optionen->Eigenschaft->hinzufügen->OK
  
  Call DocumentEigenschaftenAuflisten( _
        ActiveDocument.CustomDocumentProperties, _
        CustomDocumentProperties, _
        s_Text1, s_Text2)
End Sub
'****************************************************************
Function DocumentEigenschaftenAuflisten(pl As DocumentProperties, _
                                          s_Ueberschrift As String, _
                                          s_Text1 As String, _
                                          Optional s_Text2 As String)

  Dim p As DocumentProperty, my_tab As Table, z As Long, l_index As Long
  
 ->Neues Dokument anlegen
 ->Documents.Add
  
 ->Seite formatieren setzen
  With ActiveDocument.PageSetup
    .Orientation = wdOrientLandscape
    .TopMargin = CentimetersToPoints(1.5)
    .BottomMargin = CentimetersToPoints(1.5)
  End With

 ->Schreibmarke ans Ende des Dokumentes stellen
  Selection.WholeStory
  Selection.Collapse Direction:=wdCollapseEnd
  
 ->Absatz einfügen
  With Selection
    .InsertParagraphAfter: .Collapse Direction:=wdCollapseEnd
    .Font.Bold = True: .Font.Size = 12: .Font.Name = Tahoma
    .InsertAfter s_Ueberschrift & vbCrLf
    .Collapse Direction:=wdCollapseEnd
  End With

  If pl.Count = 0 Then GoTo TextAusgeben

 ->Tabelle einfügen:
 ->Zeilen entsprechend der Anzahl Eigenschaften +1 für Überchrift
  With Selection
    .Font.Bold = False: .Font.Size = 8: .Font.Name = Tahoma
    .InsertParagraphAfter
    .Collapse Direction:=wdCollapseEnd
    .InsertParagraphAfter
    Set my_tab = ActiveDocument.Tables.Add(.Range, pl.Count + 1, 6)
  End With
    
 ->Zeilenindex auf Anfang
  z = 1
 ->Tabellen-Überschriften
  With my_tab.Cell(z, 1).Range
    .InsertAfter Name: .Font.Bold = True
  End With
  With my_tab.Cell(z, 2).Range
    .InsertAfter Index: .Font.Bold = True
  End With
  With my_tab.Cell(z, 3).Range
    .InsertAfter Value: .Font.Bold = True
  End With
  With my_tab.Cell(z, 4).Range:
    .InsertAfter mso & vbCrLf & Property & vbCrLf & Type
    .Font.Bold = True
  End With
  With my_tab.Cell(z, 5).Range:
    .InsertAfter mit & vbCrLf & Textmarke & vbCrLf & verbunden
    .Font.Bold = True
  End With
  With my_tab.Cell(z, 6).Range:
    .InsertAfter Textmarke
    .Font.Bold = True
  End With
  
 ->Zeilenindex auf nächste Zeile
  z = z + 1
 ->Name,Index und Wert der Eigenschaften in Tabelle eintragen
  l_index = 0
  For Each p In pl
    my_tab.Cell(z, 1).Range.InsertAfter p.Name
    l_index = l_index + 1
    my_tab.Cell(z, 2).Range.InsertAfter l_index
    On Error GoTo LeererWert->Fehler,wenn Value leer ist
    my_tab.Cell(z, 3).Range.InsertAfter p.Value
    On Error GoTo 0
    With my_tab.Cell(z, 4).Range
      Select Case p.Type
        Case msoPropertyTypeString: .InsertAfter String
        Case msoPropertyTypeDate: .InsertAfter Date
        Case msoPropertyTypeNumber: .InsertAfter Number
        Case msoPropertyTypeBoolean: .InsertAfter Boolean
        Case msoPropertyTypeFloat: .InsertAfter Float
        Case Else: .InsertAfter p.Type
      End Select
    End With
    With my_tab.Cell(z, 5).Range
      If p.LinkToContent Then .InsertAfter True Else .InsertAfter False
    End With
    With my_tab.Cell(z, 6).Range
      If p.LinkToContent Then .InsertAfter p.LinkSource Else .InsertAfter leer
    End With
   
   ->Zeilenindex weiterschalten
    z = z + 1
  Next
  
 ->optimale Breite der Spalten setzen
  For l_index = 1 To my_tab.Columns.Count: my_tab.Columns(l_index).AutoFit: Next
  
 ->Schreibmarke hinter die Tabelle
  my_tab.Select: Selection.Collapse Direction:=wdCollapseEnd

TextAusgeben:
 ->Zusatztext ausgeben
  With Selection
    .Collapse Direction:=wdCollapseEnd
    .Font.Bold = False: .Font.Size = 8: .Font.Name = Tahoma
    .Collapse Direction:=wdCollapseEnd
    .InsertAfter vbCrLf & s_Text1
    If Not IsEmpty(s_Text2) Then
      .Collapse Direction:=wdCollapseEnd
      .InsertAfter vbCrLf & s_Text2
    End If
  End With
  
 ->Schreibmarke ans ende stellen
  Selection.Collapse Direction:=wdCollapseEnd
  
  Set my_tab = Nothing
Exit Function
LeererWert:
  my_tab.Cell(z, 3).Range.InsertAfter kein Wert
  Resume Next
End Function
'****************************************************************
Sub DocEigenscaften_Titel_Setzen1()
  ActiveDocument.BuiltInDocumentProperties(Title).Value = _
                                        Titel über Name gesetzt
End Sub
'****************************************************************
Sub DocEigenscaften_Titel_Setzen2()
  ActiveDocument.BuiltInDocumentProperties(1).Value = _
                                        Titel über Index gesetzt
End Sub
'****************************************************************
Sub MyPropertie_AddAsCustomBuildProperties()
  ActiveDocument.CustomDocumentProperties.Add _
    Name:=MyPropertie, _
    LinkToContent:=False, _
    Value:=Dies ist meine neue Property, _
    Type:=msoPropertyTypeString
    
   ->das ganze mit einer Textmarke verbinden
   ->LinkToContent:=True
   ->LinkSource:= Name der Textmarke
End Sub
'****************************************************************
Sub MyPropertie_InsertFieldInText()
    Selection.WholeStory
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Fields.Add _
      Range:=Selection.Range, _
      Type:=wdFieldDocProperty, _
      Text:=MyPropertie, _
      PreserveFormatting:=True
End Sub
 
Thema:

Auslesen von Datei-Eigenschaften via VBA-Script in Word

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.840
Beiträge
707.963
Mitglieder
51.494
Neuestes Mitglied
Flensburg45
Oben