Microsoft Office Forums - View Single Post

LQuinn · 03-16-2021, 10:41 PM

where i work there are a number of custom document properties in use, and they can't be sorted in the user interface - they display in the order that they were originally added
this is ok for a handful of properties, but when there are a lot of them...

i've put this together to recreate the custom properties, adding them in alphabetical order - i'm no expert, but i hope this helps someone!

my routine:

Code:

Private Sub Tools_Custom_Document_Properties_Alpha_Sort_Recreate()
'
' get all custom document properties
' sort alphabetically, delete, then recreate
' custom properties display in the order they were added
'
    Dim docCustomProperty As DocumentProperty
    Dim intDeleted As Integer, intCreated As Integer
    Dim arrCustomDocProps() As String
    Dim varCounter As Variant
    
    ReDim Preserve arrCustomDocProps(0)
    arrCustomDocProps(0) = ""
    
    ' get custom properties into array, then delete
    For Each docCustomProperty In ActiveDocument.CustomDocumentProperties
'        Debug.Print docCustomProperty.Name & " value " & docCustomProperty.Value
        ' don't recreate 'sharepoint' type custom properties - ContentType, ContentTypeID
        If InStr(1, docCustomProperty.Name, "contenttype", vbTextCompare) Then
'            Debug.Print "found contenttype property: " & docCustomProperty.Name
        Else
            ReDim Preserve arrCustomDocProps(UBound(arrCustomDocProps) + 1)
            arrCustomDocProps(UBound(arrCustomDocProps)) = docCustomProperty.Name & "^" & docCustomProperty.Value
        End If
        ' uncomment to delete the custom property
'        docCustomProperty.delete
        intDeleted = intDeleted + 1
    Next docCustomProperty
    
    ' sort custom properties alphabetically
    Quicksort arrCustomDocProps, LBound(arrCustomDocProps), UBound(arrCustomDocProps)
    
    ' recreate custom properties from array
    For varCounter = 1 To UBound(arrCustomDocProps)
'        Debug.Print "item: " & varCounter & " " & arrCustomDocProps(varCounter)
'        Debug.Print Split(arrCustomDocProps(varCounter), "^")(0)
'        Debug.Print Split(arrCustomDocProps(varCounter), "^")(1)
        If InStr(1, Split(arrCustomDocProps(varCounter), "^")(0), "date", vbTextCompare) Then
'            Debug.Print "found date property: " & Split(arrCustomDocProps(varCounter), "^")(0)
            updateCustomDocumentProperty (Split(arrCustomDocProps(varCounter), "^")(0)), (Split(arrCustomDocProps(varCounter), "^")(1)), msoPropertyTypeDate
        Else
            updateCustomDocumentProperty (Split(arrCustomDocProps(varCounter), "^")(0)), (Split(arrCustomDocProps(varCounter), "^")(1)), msoPropertyTypeString
        End If
        intCreated = intCreated + 1
    Next varCounter
    
    Set docCustomProperty = Nothing
    Set varCounter = Nothing
    Erase arrCustomDocProps
    
    Debug.Print "deleted " & intDeleted & " and recreated " & intCreated & " custom document properties"
End Sub

borrowed routine to alpha sort the custom properties:

Code:

Private Sub Quicksort(vArray As Variant, arrLbound As Long, arrUbound As Long)
'
' Sorts a one-dimensional VBA array from smallest to largest
' using a very fast quicksort algorithm variant.
'
' https://wellsr.com/vba/2018/excel/vba-quicksort-macro-to-sort-arrays-fast/
'
    Dim pivotVal As Variant, vSwap As Variant
    Dim tmpLow As Long, tmpHi As Long
     
    tmpLow = arrLbound
    tmpHi = arrUbound
    pivotVal = vArray((arrLbound + arrUbound) \ 2)
     
    While (tmpLow <= tmpHi) 'divide
        While (vArray(tmpLow) < pivotVal And tmpLow < arrUbound)
            tmpLow = tmpLow + 1
        Wend
      
        While (pivotVal < vArray(tmpHi) And tmpHi > arrLbound)
            tmpHi = tmpHi - 1
        Wend
     
        If (tmpLow <= tmpHi) Then
            vSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = vSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend
     
    If (arrLbound < tmpHi) Then Quicksort vArray, arrLbound, tmpHi 'conquer
    If (tmpLow < arrUbound) Then Quicksort vArray, tmpLow, arrUbound 'conquer
    
    Set pivotVal = Nothing
    Set vSwap = Nothing
End Sub

borrowed routine to create the custom properties:

Code:

Private Sub updateCustomDocumentProperty(strPropertyName As String, varValue As Variant, docType As Office.MsoDocProperties)
'
' updates custom document property, creates it if it doesn't exist
'
' https://stackoverflow.com/questions/14863250/how-to-add-a-documentproperty-to-customdocumentproperties-in-excel
'
    On Error Resume Next
    ActiveDocument.CustomDocumentProperties(strPropertyName).Value = varValue
    If Err.Number > 0 Then
        ActiveDocument.CustomDocumentProperties.Add _
            Name:=strPropertyName, _
            LinkToContent:=False, _
            Type:=docType, _
            Value:=varValue
    End If
End Sub