A Convenient Way to Fill-In Word Custom Properties

' Code originally published on:
' http://word.mvps.org/faqs/macrosvba/MixedDocProps.htm
 
 
Public Sub WriteProp(sPropName As String, ByVal sValue As String, _
      Optional lType As Long = msoPropertyTypeString)
 
' In the above declaration,
' "Optional lType As Long = msoPropertyTypeString" means
' that if the Document Property's Type is Text, we don't need
' to include the lType argument when we call the procedure;
' but if it's any other Prpperty Type (e.g. date) then we do
 
Dim bCustom As Boolean
 
  On Error GoTo ErrHandlerWriteProp
 
  'Try to write the value sValue to the custom documentproperties
  'If the customdocumentproperty does not exists, an error will occur
  'and the code in the errorhandler will run
  ActiveDocument.BuiltInDocumentProperties(sPropName).Value = sValue
  'Quit this routine
  Exit Sub
 
Proceed:
  'We know now that the property is not a builtin documentproperty,
  'but a custom documentproperty, so bCustom = True
  bCustom = True
 
Custom:
  'Try to set the value for the customproperty sPropName to sValue
  'An error will occur if the documentproperty doesn't exist yet
  'and the code in the errorhandler will take over
  ActiveDocument.CustomDocumentProperties(sPropName).Value = sValue
  Exit Sub
 
AddProp:
  'We came here from the errorhandler, so know we know that
  'property sPropName is not a built-in property and that there's
  'no custom property with this name
  'Add it
  On Error Resume Next
  ActiveDocument.CustomDocumentProperties.Add Name:=sPropName, _
    LinkToContent:=False, Type:=lType, Value:=sValue
 
  If Err Then
    'If we still get an error, the value isn't valid for the Property Type
    'e,g an invalid date was used
    Debug.Print "The Property " & Chr(34) & _
     sPropName & Chr(34) & " couldn't be written, because " & _
     Chr(34) & sValue & Chr(34) & _
     " is not a valid value for the property type"
  End If
 
  Exit Sub
 
ErrHandlerWriteProp:
  Select Case Err
    Case Else
   'Clear the error
   Err.Clear
   'bCustom is a boolean variable, if the code jumps to this
   'errorhandler for the first time, the value for bCustom is False
   If Not bCustom Then
     'Continue with the code after the label Proceed
     Resume Proceed
   Else
     'The errorhandler was executed before because the value for
     'the variable bCustom is True, therefor we know that the
     'customdocumentproperty did not exist yet, jump to AddProp,
     'where the property will be made
     Resume AddProp
   End If
  End Select
 
End Sub
 
Public Sub FillDocument()
 
Dim Var_Sender_Name, Var_Recipient_Name, Var_Customer_Number, _
Var_Location  As String
 
' This is the part to be edited
Var_Sender_Name = "Mr. Axel Rose"
Var_Recipient_Name = "Mr.John Bon Jovi"
Var_Customer_Number = "ANYTHING0037857"
Var_Location = "Here we go, the first line," & vbCrLf & _
"This is the second line," & vbCrLf & "This is a third line."
 
' Add as many calls as the properties you have
Call WriteProp(sPropName:="Sender_Name", sValue:=Var_Sender_Name, _
lType:=msoPropertyTypeString)
Call WriteProp(sPropName:="Recipient_Name", sValue:=Var_Recipient_Name, _
lType:=msoPropertyTypeString)
Call WriteProp(sPropName:="Customer_Number", sValue:=Var_Customer_Number, _
lType:=msoPropertyTypeString)
Call WriteProp(sPropName:="Location", sValue:=Var_Location, _
lType:=msoPropertyTypeString)
 
End Sub