Über VBA-Prozeduren können Dateieigenschaften gelesen und geschrieben werden. Voraussetzung hierfür ist, dass das jeweilige Dokument geöffnet ist.
Sub ReadDocumentProperties()
Dim iRow As Integer
Range("A4:F35").ClearContents
On Error Resume Next
With ActiveWorkbook.BuiltinDocumentProperties
For iRow = 1 To .Count
Cells(iRow + 3, 1).Value = .Item(iRow).Name
Cells(iRow + 3, 2).Value = .Item(iRow).Value
Cells(iRow + 3, 3).Value = .Item(iRow).Type
If Err.Number <> 0 Then
Cells(iRow + 3, 2).Value = CVErr(xlErrNA)
Err.Clear
End If
Next iRow
End With
With ActiveWorkbook.CustomDocumentProperties
For iRow = 1 To .Count
Cells(iRow + 3, 5).Value = .Item(iRow).Name
Cells(iRow + 3, 6).Value = .Item(iRow).Value
Cells(iRow + 3, 7).Value = .Item(iRow).Type
If Err.Number <> 0 Then
Cells(iRow + 3, 6).Value = CVErr(xlErrNA)
Err.Clear
End If
Next iRow
End With
On Error GoTo 0
End Sub
Sub WriteDocumentProperties()
Dim wks As Worksheet
Dim iRow As Integer
Set wks = ActiveSheet
If IsEmpty(Range("A4")) Then
Beep
MsgBox "Sie müssen zuerst die Eigenschaften einlesen!"
Exit Sub
End If
Workbooks.Add
With ActiveWorkbook.BuiltinDocumentProperties
For iRow = 4 To 35
If IsEmpty(wks.Cells(iRow, 1)) Then Exit For
If IsError(wks.Cells(iRow, 2)) = False Then
.Item(wks.Cells(iRow, 1).Value) = wks.Cells(iRow, 2).Value
End If
Next iRow
End With
With ActiveWorkbook.CustomDocumentProperties
For iRow = 4 To 4
.Add Name:=wks.Cells(iRow, 5).Value, LinkToContent:=False, _
Type:=msoPropertyTypeDate, Value:=wks.Cells(iRow, 6).Value
Next iRow
End With
MsgBox "Die editierbaren Dateieigenschaften wurden auf diese neue" & vbLf & _
"Arbeitsmappe übertragen, bitte prüfen."
End Sub