Tim,
I use the code below. Please see if it is helpful.
' Macro to sort specified main custom properties into a specific
' order for the active document.
'
' Macro will add missing main custom properties to the file.
' Macro will keep and reorder already existing custom properties.
' Custom properties that is not added in method AddMainCustProps
' will be placed last as non-sorted custom properties.
'
' Change (order, add, remove, data type, default value) of main
' custom properties is done in the method (Sub) AddMainCustProps
'
' Macro will change (if possible, otherwise run-time error) data type
' of existing property to the stated ones in method AddMainCustProps
'
' Macro can be freely distributed and edited.
'
' Macro is used at own risk. There are no warranties, expressed or implied,
' that these macros will perform as indicated, perform to users expectations,
' or complete a specific task.
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim vCustPropNames As Variant
Dim vCustPropTypes As Variant
Dim vCustPropVals As Variant
Dim colCurrent As New Collection
Dim colSkip As New Collection
Dim colMain As New Collection
Dim bSkip As Boolean
Dim bDefaultDataType As Boolean
Sub Main()
Dim CustProp As CustProp
Dim curCustProp As CustProp
Dim i As Integer
'Clean up the collections.
Set colCurrent = Nothing
Set colSkip = Nothing
Set colMain = Nothing
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then Exit Sub
Set swCustPropMgr = swModel.Extension.CustomPropertyManager(Empty)
swCustPropMgr.GetAll vCustPropNames, vCustPropTypes, vCustPropVals
If Not IsEmpty(vCustPropNames) Then
For i = 0 To UBound(vCustPropNames) 'Get all current custom properties from the file. Add them to collection colCurrent
Set CustProp = New CustProp
CustProp.cpName = vCustPropNames(i)
CustProp.cpType = vCustPropTypes(i)
CustProp.cpValue = vCustPropVals(i)
colCurrent.Add CustProp
Next
End If
AddMainCustProps 'Add all "main" custom properties to collection colMain with method AddMainCustProps.
'Edit (Sub) AddMainCustProps if needed.
' Use Default Data Types for custom properties that exist in file?
' If bDefaultDatatype is set to True. Means that the macro
' strictly use the stated default data type in AddMainCustProps for the main custom properties.
' This may give run-time error if the macro is trying to convert text/number to date etc.
'
' If bDefaultDatatype is set to False. The macro will keep the data type
' of already existing main custom properties.
bDefaultDataType = False
Do While colCurrent.Count <> 0
For i = 1 To colMain.Count
Set CustProp = colMain.Item(i) 'Set CustProp to the object in collection colMain
Set curCustProp = colCurrent.Item(1) 'Set curCustProp to the object in collection colCurrent
If CustProp.cpName = curCustProp.cpName Then 'If statment to get current data if any was present.
CustProp.cpValue = curCustProp.cpValue 'Push value from current custom property object to main custom property object
If bDefaultDataType = False Then 'If False, keep current data type.
CustProp.cpType = curCustProp.cpType
End If
colCurrent.Remove 1
bSkip = False
If colCurrent.Count = 0 Then Exit For 'Exit For statement if the colCollection runs out of objects.
Else
bSkip = True 'bSkip = True If the custom property was NOT in the colMain collection.
End If
Next
If bSkip = True Then 'This is a custom property that was not found to be in the colMain collection.
colSkip.Add colCurrent.Item(1)
colCurrent.Remove 1
End If
Loop
If Not IsEmpty(vCustPropNames) Then
For i = 0 To UBound(vCustPropNames) 'Delete all current custom properties in the file.
swCustPropMgr.Delete vCustPropNames(i)
Next i
End If
For Each CustProp In colMain 'Add all main custom properties.
swCustPropMgr.Add2 CustProp.cpName, CustProp.cpType, CustProp.cpValue
Next
For Each CustProp In colSkip 'Add back all non-main custom properties.
swCustPropMgr.Add2 CustProp.cpName, CustProp.cpType, CustProp.cpValue
Next
swCustPropMgr.GetAll vCustPropNames, vCustPropTypes, vCustPropVals
For i = 0 To UBound(vCustPropNames)
'If a custom property is of Date type and empty (shorter than 6 chars) a message will be prompted the user.
'If a custom property of Date type is empty (or invalid) the document will fail to save.
'Futher checks of custom property data may be added here with other If statements.
If vCustPropTypes(i) = SwDmCustomInfoType.swDmCustomInfoDate And Len(vCustPropVals(i)) < 6 Then
swApp.SendMsgToUser2 "Custom property: " & vCustPropNames(i) & vbNewLine & vbNewLine & _
"Is of Date format but seems to be empty." & vbNewLine & _
"It is most likely that the document will fail to save." & vbNewLine & vbNewLine & _
"Please check the stated custom property if the documents failes to save.", 1, 2
End If
Next
MsgBox "Custom Properties Added!!!"
End Sub
Sub AddMainCustProps()
' Does it look like a mess?! Do not worry...
' Change order, add or remove lines as you like. The order is the order that will be in the custom property page (File->Properties) in SW.
'
' Syntax: AddCustProp "Name of custom property", Default data type, "Default value"
'
' Data types:
' SwDmCustomInfoType.swDmCustomInfoDate - Date
' SwDmCustomInfoType.swDmCustomInfoNumber - Number
' SwDmCustomInfoType.swDmCustomInfoText - Plain text
' SwDmCustomInfoType.swDmCustomInfoUnknown -
' SwDmCustomInfoType.swDmCustomInfoYesOrNo - Yes / No
AddCustProp "BDY", SwDmCustomInfoType.swDmCustomInfoText, ""
AddCustProp "DPL", SwDmCustomInfoType.swDmCustomInfoText, ""
AddCustProp "BKD", SwDmCustomInfoType.swDmCustomInfoText, ""
AddCustProp "SETUP", SwDmCustomInfoType.swDmCustomInfoText, ""
AddCustProp "DIA", SwDmCustomInfoType.swDmCustomInfoText, ""
AddCustProp "PKT", SwDmCustomInfoType.swDmCustomInfoText, ""
AddCustProp "UNDH", SwDmCustomInfoType.swDmCustomInfoText, ""
AddCustProp "MANH", SwDmCustomInfoType.swDmCustomInfoText, ""
End Sub
Sub AddCustProp(cpName As String, cpType As Long, cpValue As Variant)
Dim CustProp As CustProp
Set CustProp = New CustProp
CustProp.cpName = cpName
CustProp.cpType = cpType
CustProp.cpValue = cpValue
colMain.Add CustProp
End Sub
