-
-
Save pa-0/bdf8d3acc31568a7c8e19ebe1613b4fd to your computer and use it in GitHub Desktop.
VBA Macro for exporting and importing Word Document Properties
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Option Explicit | |
Private fileName As String | |
Public Sub ExportProperties() | |
On Error GoTo ErrorHandler | |
Let fileName = InputBox("Export properties to ...", "Export", fileName) | |
Open fileName For Output As #1 | |
Dim o As Variant | |
For Each o In ActiveDocument.CustomDocumentProperties | |
Dim prop As DocumentProperty: Set prop = o | |
Print #1, prop.Name & vbTab & prop.Value | |
Next o | |
GoSub Finally | |
Exit Sub | |
Finally: | |
Close #1 | |
Return | |
ErrorHandler: | |
Dim errNr As Long: Let errNr = Err.Number | |
Dim errDsc As String: Let errDsc = Err.Description | |
Select Case errNr | |
Case Else | |
Debug.Print errNr | |
Debug.Print errDsc | |
GoSub Finally | |
End Select | |
End Sub | |
Public Sub ImportProperties() | |
On Error GoTo ErrorHandler | |
Let fileName = InputBox("Inport properties from ...", "Import", fileName) | |
Open fileName For Input As #1 | |
Dim docProps As DocumentProperties: Set docProps = ActiveDocument.CustomDocumentProperties | |
Dim currentProp As String | |
Do | |
Line Input #1, currentProp | |
Dim propName As String: Let propName = Left(currentProp, InStr(currentProp, vbTab) - 1) | |
Dim propValue As String: Let propValue = Right(currentProp, Len(currentProp) - InStr(currentProp, vbTab)) | |
Dim docProp As DocumentProperty: Set docProp = docProps.Item(propName) | |
If docProp Is Nothing Then | |
Debug.Print "Creating " & propName & "..." | |
Call docProps.Add(propName, False, msoPropertyTypeString, propValue) | |
Else | |
If docProp.Value = propValue Then | |
Debug.Print "Skipping " & propName & " (up to date)." | |
Else | |
Debug.Print "Updating " & propName & "." | |
Let docProp.Value = propValue | |
End If | |
End If | |
Loop Until EOF(1) | |
GoSub Finally | |
Exit Sub | |
Finally: | |
Close #1 | |
Return | |
ErrorHandler: | |
Dim errNr As Long: Let errNr = Err.Number | |
Dim errDsc As String: Let errDsc = Err.Description | |
Select Case errNr | |
Case 5 | |
'Invalid procedure call or argument. | |
'Exception occurs when trying to retrieve a document property with a name that does not exist. | |
Set docProp = Nothing | |
Resume Next | |
Case Else | |
Debug.Print errNr | |
Debug.Print errDsc | |
GoSub Finally | |
End Select | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment