Reading/writting cutom properties....Help speeding up my code

[yeahwtaver]

Hi guys. Just after a bit of help.
I have a userform to populate a large user manaual (100 odd pages, 5mb) with about 20 custom properties.

All works, but im finding its taking quite a long time to cycle through all the custom properties. Its a selection of code that I have cobbled together so Im sure its very messy and not at all optimised.
The reading of custom properties into the user form takes especially long.

Can anyone point me in the right direction?

'''READ VARIABLES TO FILE PROPERTIES (ON LOAD)
Private Sub UserForm_Initialize()
Dim PropVal As String


MsgBox "Reading document properties. Please be patient", , "O&M Manual creation"


  PropVal = ReadProp("Subject")
  Subject = ReadProp("Subject")


  PropVal = ReadProp("Date Completed")
  DateComplete = ReadProp("Date Completed")
  
  PropVal = ReadProp("Company")
  Company = ReadProp("Company")
  
  PropVal = ReadProp("NoOfStages")
  NoOfStages = ReadProp("NoOfStages")
  
  PropVal = ReadProp("Stage1Process")
  Stage1Process = ReadProp("Stage1Process")
  
  PropVal = ReadProp("TrackSpeed")
  TrackSpeed = ReadProp("TrackSpeed")
  
  PropVal = ReadProp("Temperature_Controller_Type")
  Temperature_Controller_Type = ReadProp("Temperature_Controller_Type")
  
  PropVal = ReadProp("Temperature_Indicator")
  Temperature_Indicator = ReadProp("Temperature_Indicator")
  
  PropVal = ReadProp("Product_Height")
  Product_Height = ReadProp("Product_Height")
  
  PropVal = ReadProp("Product_Width")
  Product_Width = ReadProp("Product_Width")
  
  PropVal = ReadProp("Product_Length")
  Product_Length = ReadProp("Product_Length")
  
  PropVal = ReadProp("Customer_Address1")
  Customer_Address1 = ReadProp("Customer_Address1")
  
  PropVal = ReadProp("Customer_Address2")
  Customer_Address2 = ReadProp("Customer_Address2")
  
  PropVal = ReadProp("Customer_Address3")
  Customer_Address3 = ReadProp("Customer_Address3")
  
  PropVal = ReadProp("Customer_Address4")
  Customer_Address4 = ReadProp("Customer_Address4")
  
  PropVal = ReadProp("Customer_Address5")
  Customer_Address5 = ReadProp("Customer_Address5")
  
  PropVal = ReadProp("Customer_Address6")
  Customer_Address6 = ReadProp("Customer_Address6")
  
'''WRITE VARIABLES TO FILE PROPERTIES
Private Sub OK_Click()
Dim PlantList As String
  'Changes document properties to values of userform. Values are linked in documents and will update automatically
  ' FOUND HERE: https://wordmvp.com/FAQs/MacrosVBA/MixedDocProps.htm
    Call WriteProp(sPropName:="Subject", sValue:=Subject)
    Call WriteProp(sPropName:="Company", sValue:=Company)
    Call WriteProp(sPropName:="Date completed", sValue:=DateComplete)
    Call WriteProp(sPropName:="NoOfStages", sValue:=NoOfStages)
    Call WriteProp(sPropName:="Stage1Process", sValue:=Stage1Process)
    Call WriteProp(sPropName:="TrackSpeed", sValue:=TrackSpeed)
    Call WriteProp(sPropName:="Temperature_Controller_Type", sValue:=Temperature_Controller_Type)
    Call WriteProp(sPropName:="Temperature_Indicator", sValue:=Temperature_Indicator)
    Call WriteProp(sPropName:="Product_Height", sValue:=Product_Height)
    Call WriteProp(sPropName:="Product_Width", sValue:=Product_Width)
    Call WriteProp(sPropName:="Product_Length", sValue:=Product_Length)
    Call WriteProp(sPropName:="Customer Address1", sValue:=Customer_Address1)
    Call WriteProp(sPropName:="Customer Address2", sValue:=Customer_Address2)
    Call WriteProp(sPropName:="Customer Address3", sValue:=Customer_Address3)
    Call WriteProp(sPropName:="Customer Address4", sValue:=Customer_Address4)
    Call WriteProp(sPropName:="Customer Address5", sValue:=Customer_Address5)
    Call WriteProp(sPropName:="Customer Address6", sValue:=Customer_Address6)
    ActiveDocument.Fields.Update
    Unload DocProperties
End Sub


Public Sub WriteProp(sPropName As String, 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




''''READING DOCUMENT PROPERTIES
Function ReadProp(sPropName As String) As Variant


Dim bCustom As Boolean
Dim sValue As String


  On Error GoTo ErrHandlerReadProp
  'Try the built-in properties first
  'An error will occur if the property doesn't exist
  sValue = ActiveDocument.BuiltInDocumentProperties(sPropName).Value
  ReadProp = sValue
  Exit Function


ContinueCustom:
  bCustom = True


Custom:
  sValue = ActiveDocument.CustomDocumentProperties(sPropName).Value
  ReadProp = sValue
  Exit Function


ErrHandlerReadProp:
  Err.Clear
  'The boolean bCustom has the value False, if this is the first
  'time that the errorhandler is runned
  If Not bCustom Then
    'Continue to see if the property is a custom documentproperty
    Resume ContinueCustom
  Else
    'The property wasn't found, return an empty string
    ReadProp = ""
    Exit Function
  End If

End Function

[gmayor]

I am not sure of the point of reading the values twice e.g.

PropVal = ReadProp("Subject")
Subject = ReadProp("Subject")

and if Subject has no value, what's the point of reading any further values? The following reads the docproperties almost instantaneously (when present)
I don't like to rely on error conditions in order to progress. The following does not use error handling to read or write values.

Option Explicit

'''READ VARIABLES TO FILE PROPERTIES (ON LOAD)
Private Sub UserForm_Initialize()
Dim PropVal As String
    PropVal = ReadProp("Subject")
    If PropVal = "" Then Exit Sub
    Subject = PropVal
    DateComplete = ReadProp("Date Completed")
    Company = ReadProp("Company")
    NoOfStages = ReadProp("NoOfStages")
    Stage1Process = ReadProp("Stage1Process")
    TrackSpeed = ReadProp("TrackSpeed")
    Temperature_Controller_Type = ReadProp("Temperature_Controller_Type")
    Temperature_Indicator = ReadProp("Temperature_Indicator")
    Product_Height = ReadProp("Product_Height")
    Product_Width = ReadProp("Product_Width")
    Product_Length = ReadProp("Product_Length")
    Customer_Address1 = ReadProp("Customer Address1")
    Customer_Address2 = ReadProp("Customer Address2")
    Customer_Address3 = ReadProp("Customer Address3")
    Customer_Address4 = ReadProp("Customer Address4")
    Customer_Address5 = ReadProp("Customer Address5")
    Customer_Address6 = ReadProp("Customer Address6")
End Sub

'''WRITE VARIABLES TO FILE PROPERTIES
Private Sub OK_Click()
Dim PlantList As String
    'Changes document properties to values of userform. Values are linked in documents and will update automatically
    ' FOUND HERE: https://wordmvp.com/FAQs/MacrosVBA/MixedDocProps.htm
    Call WriteProp(sPropName:="Subject", sValue:=Subject)
    Call WriteProp(sPropName:="Company", sValue:=Company)
    Call WriteProp(sPropName:="Date completed", sValue:=DateComplete)
    Call WriteProp(sPropName:="NoOfStages", sValue:=NoOfStages)
    Call WriteProp(sPropName:="Stage1Process", sValue:=Stage1Process)
    Call WriteProp(sPropName:="TrackSpeed", sValue:=TrackSpeed)
    Call WriteProp(sPropName:="Temperature_Controller_Type", sValue:=Temperature_Controller_Type)
    Call WriteProp(sPropName:="Temperature_Indicator", sValue:=Temperature_Indicator)
    Call WriteProp(sPropName:="Product_Height", sValue:=Product_Height)
    Call WriteProp(sPropName:="Product_Width", sValue:=Product_Width)
    Call WriteProp(sPropName:="Product_Length", sValue:=Product_Length)
    Call WriteProp(sPropName:="Customer Address1", sValue:=Customer_Address1)
    Call WriteProp(sPropName:="Customer Address2", sValue:=Customer_Address2)
    Call WriteProp(sPropName:="Customer Address3", sValue:=Customer_Address3)
    Call WriteProp(sPropName:="Customer Address4", sValue:=Customer_Address4)
    Call WriteProp(sPropName:="Customer Address5", sValue:=Customer_Address5)
    Call WriteProp(sPropName:="Customer Address6", sValue:=Customer_Address6)
    ActiveDocument.Fields.Update
    Unload DocProperties
End Sub

Private Sub WriteProp(sPropName As String, sValue As String, Optional lType As Long = msoPropertyTypeString)
Dim oProp As DocumentProperty
Dim bBuilt As Boolean, bCust As Boolean
    For Each oProp In ActiveDocument.BuiltInDocumentProperties
        If oProp.Name = sPropName Then
            oProp.Value = sValue
            bBuilt = True
            Exit For
        End If
        DoEvents
    Next oProp
    If Not bBuilt Then
        For Each oProp In ActiveDocument.CustomDocumentProperties
            If oProp.Name = sPropName Then
                oProp.Value = sValue
                bCust = True
                Exit For
            End If
            DoEvents
        Next oProp
        If Not bCust Then
            ActiveDocument.CustomDocumentProperties.Add Name:=sPropName, _
                                                        LinkToContent:=False, _
                                                        Type:=lType, _
                                                        Value:=sValue
        End If
    End If
lbl_Exit:
    Set oProp = Nothing
    Exit Sub
End Sub

Private Function ReadProp(strName As String) As Variant
Dim oProp As DocumentProperty
Dim bBuilt As Boolean, bCust As Boolean
    For Each oProp In ActiveDocument.BuiltInDocumentProperties
        If oProp.Name = strName Then
            ReadProp = oProp.Value
            bBuilt = True
            Exit For
        End If
        DoEvents
    Next oProp
    If Not bBuilt Then
        For Each oProp In ActiveDocument.CustomDocumentProperties
            If oProp.Name = strName Then
                ReadProp = oProp.Value
                bCust = True
                Exit For
            End If
            DoEvents
        Next oProp
        If Not bCust Then ReadProp = ""
    End If
lbl_Exit:
    Exit Function
End Function

[Chas Kenyon]

Just a side note. Why are you using document properties rather than document variables?

Document properties can be accessed and changed through the user interface looking at advanced properties.
Document variables require vba or some utility most users will not have. Both can be displayed using fields in the document.

[gmaxey]

Graham,

Not sure I understand your aversion to error handling. In this case it can eliminate all of the looping.

Private Sub UserForm_Initialize()
  If ReadProp("Subject") = vbNullString Then Exit Sub
  Subject = PropVal
  Company = ReadProp("Company")
  DateComplete = ReadProp("Date Completed")
  NoOfStages = ReadProp("NoOfStages")
  'and so on ...
lbl_Exit:
  Exit Sub
End Sub

Private Sub OK_Click()
  WriteProp "Subject", Subject
  WriteProp "Company", Company
  WriteProp "Date completed", DateComplete
  WriteProp "NoOfStages", NoOfStages
  WriteProp "Stage1Process", Stage1Process
  'and so on ...
  Hide
    'Unload DocProperties - do this is the calling procedure.
lbl_Exit:
  Exit Sub
End Sub

Private Sub WriteProp(sPropName As String, sValue As String, Optional lType As Long = msoPropertyTypeString)
Dim oProp As DocumentProperty
  Set oProp = Nothing
  On Error Resume Next
  Set oProp = ActiveDocument.BuiltInDocumentProperties(sPropName)
  If Not oProp Is Nothing Then
    oProp.Value = sValue
  Else
    Set oProp = ActiveDocument.CustomDocumentProperties(sPropName)
    If Not oProp Is Nothing Then
      oProp.Value = sValue
    Else
      ActiveDocument.CustomDocumentProperties.Add _
        sPropName, False, lType, sValue
    End If
  End If
lbl_Exit:
  Set oProp = Nothing
  Exit Sub
End Sub

Private Function ReadProp(strName As String) As Variant
Dim oProp As DocumentProperty
  Set oProp = Nothing
  ReadProp = vbNullString
  On Error Resume Next
  Set oProp = ActiveDocument.BuiltInDocumentProperties(strName)
  If Not oProp Is Nothing Then
    ReadProp = oProp.Value
  Else
    Set oProp = ActiveDocument.CustomDocumentProperties(strName)
    If Not oProp Is Nothing Then ReadProp = oProp.Value
  End If
lbl_Exit:
  Exit Function
End Function

[Paul_Hossler]

Not tested, but wouldn't something like this be simpler?

Option Explicit


Private Function ReadProp(strName As String) As Variant
    On Error GoTo lbl_Exit
    ReadProp = ActiveDocument.BuiltInDocumentProperties(strName).Value
    Exit Function


lbl_Exit:
    ReadProp = vbNullString
End Function

[gmaxey]

Paul,
Well yes, but as we are also calling the function for custom properties then I suppose it could be (again like yours, not tested):

Private Function ReadProp(strName As String) As Variant
  On Error Resume Next
  Set ReadProp = ActiveDocument.BuiltInDocumentProperties(strName)
  If ReadProp = Empty Then
    Set ReadProp = ActiveDocument.CustomDocumentProperties(strName)
  End If
lbl_Exit:
  Exit Function
End Function