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