Private
Sub
DocProperties_kopieren_Click()
Dim
wrdApp
As
Object
Dim
wrdDoc
As
Object
Dim
i
As
Integer
Set
wrdApp = CreateObject(
"Word.Application"
)
wrdApp.Visible =
True
Set
wrdDoc = wrdApp.Documents.Add
Call
FillWordDoc(wrdDoc)
FullName = Application.ActiveDocument.Path &
"\" & "
Document Properties.rtf"
With
wrdDoc
If
Dir(FullName) <>
""
Then
Kill FullName
End
If
.SaveAs FileName:=FullName, FileFormat:=wdFormatRTF
End
With
End
Sub
Sub
FillWordDoc(Doc
As
Object
)
Doc.Content.InsertParagraphAfter
Doc.Content.InsertParagraphAfter
Doc.Content.InsertParagraphAfter
pos = Doc.Content.
End
Doc.Tables.Add Range:=Doc.Range(pos - 1, pos - 1), numrows:=23, numcolumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitContent
Doc.Tables.Item(1).Cell(1, 1).Range.Text =
"test"
Doc.Tables.Item(1).Cell(1, 2).Range.Text = ActiveDocument.CustomDocumentProperties(
"test"
).Value
Doc.Tables.Item(1).Cell(2, 1).Range.Text =
"ende"
Doc.Tables.Item(1).Cell(2, 2).Range.Text = ActiveDocument.CustomDocumentProperties(
"ende"
).Value
End
Sub
Private
Sub
DocProperties_importieren_Click()
With
ActiveDocument
Dim
Doc
As
Object
Doc = Application.ActiveDocument.Path &
"\" & "
Document Properties.rtf"
.CustomDocumentProperties(
"test"
).Value = Doc.Tables.Item(1).Cell(1, 2).Range.Text
.CustomDocumentProperties(
"ende"
).Value = Doc.Tables.Item(1).Cell(2, 2).Range.Text
End
With
End
Sub