Consulting

Results 1 to 6 of 6

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

  1. #1

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

    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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Contributor
    Joined
    Jul 2020
    Location
    Sun Prairie
    Posts
    118
    Location
    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.

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  5. #5
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  6. #6
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •