#1
|
|||
|
|||
sort custom document properties
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 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 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 |
#2
|
||||
|
||||
Your code could be greatly simplified. For example, to produce an alpha-sorted Custom Document Property list:
Code:
Sub Sort_Custom_Document_Properties() Dim DocProp As DocumentProperty, CustPropArr() As String ReDim Preserve CustPropArr(0): CustPropArr(0) = "" ' Add Custom Document Properties to Array For Each DocProp In ActiveDocument.CustomDocumentProperties With DocProp If InStr(1, .Name, "contenttype", vbTextCompare) = 0 Then ReDim Preserve CustPropArr(UBound(CustPropArr) + 1) CustPropArr(UBound(CustPropArr)) = .Name & "|" & .Type & "|" & .Value End If End With Next DocProp WordBasic.SortArray CustPropArr MsgBox Join(CustPropArr, vbCr) End Sub I'm not convinced there's much to be gained by reinserting them in the sorted order, though.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
Thanks Paul, as always
I'm getting the properties and then putting them back into the document in alpha order |
#4
|
||||
|
||||
Quote:
Quote:
Code:
Sub Sort_Custom_Document_Properties() Dim DocProp As DocumentProperty, CustPropArr() As String, i As Long ReDim Preserve CustPropArr(0): CustPropArr(0) = "" With ActiveDocument For Each DocProp In .CustomDocumentProperties With DocProp If InStr(1, .Name, "contenttype", vbTextCompare) = 0 Then ReDim Preserve CustPropArr(UBound(CustPropArr) + 1) CustPropArr(UBound(CustPropArr)) = .Name & "|" & .Type & "|" & .Value & "|" & .LinkToContent & "|" & .LinkSource End If End With Next DocProp For i = 1 To UBound(CustPropArr) .CustomDocumentProperties(Split(CustPropArr(i), "|")(0)).Delete Next WordBasic.SortArray CustPropArr For i = 1 To UBound(CustPropArr) .CustomDocumentProperties.Add _ Name:=Split(CustPropArr(i), "|")(0), _ Type:=Split(CustPropArr(i), "|")(1), _ Value:=Split(CustPropArr(i), "|")(2), _ LinkToContent:=Split(CustPropArr(i), "|")(3), _ LinkSource:=Split(CustPropArr(i), "|")(4) CustPropArr(i) = Split(CustPropArr(i), "|")(0) Next End With MsgBox "The following Custom Document Properties have been sorted:" & vbCr & Join(CustPropArr, vbCr) End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
Thanks again Paul, always good to see how the experts do it!
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Phantom fields (custom document properties)- where do they come from - and how can they be stopped?! | andiekit | Word | 13 | 03-18-2021 07:02 AM |
Adding Custom Document Properties | NicoleJones | Word VBA | 3 | 03-10-2021 08:43 PM |
Create Custom Document Properties with Content Control | kschmidt | Word VBA | 7 | 02-04-2019 03:09 PM |
Updating Document Properties without using advanced properties dialogue | thedr9wningman | Word VBA | 3 | 01-20-2014 05:56 PM |
Add custom document properties into document | NicBodkin | Word | 8 | 05-05-2011 09:09 AM |