Thank you for the replay, I will try what you suggest.
Meanwhile I settled to use MaterialPropertyValues
, I saw no major drawbacks.
In case anyone is interested, here the code of a macro that, on the active assembly:
- unlink the display states from the configuration
- delete all display states except the ones defined in DEFAULT_DS and RAND_COLOR_DS
- in the display state RAND_COLOR_DS set random colors for each component, giving all the instances of the same component the same color
' PurgeDisplayState
'
' Delete display states (DS) in the active file except the one defined in DEFAULT_DS and RAND_COLOR_DS, set random color for components in RAND_COLOR_DS
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
' Display states to preserve
Const DEFAULT_DS As String = "Default_Display state-1"
Const RAND_COLOR_DS As String = "COLORS"
Dim vMatProp As Variant
Type BomPosition
model As SldWorks.ModelDoc2
comp As SldWorks.Component2
ModelPath As String
Configuration As String
Quantity As Double
Description As String
Price As Double
End Type
Sub main()
Set swApp = Application.SldWorks
try_:
' Comment the line below to avoid error to exit the macro, for debug only
On Error GoTo catch_
Set swModel = swApp.ActiveDoc
' Check if the open file is an assembly and it is saved
If swModel Is Nothing Then
Err.Raise vbError, "", "Open an assembly to run the macro" ' Open an assembly to run the macro
End If
If swModel.GetPathName() = "" Then
Err.Raise vbError, "", "Save the document to run the macro" ' Save the document to run the macro
End If
If Not swModel.GetType() = swDocumentTypes_e.swDocASSEMBLY Then
Err.Raise vbError, "", "Open an assembly to run the macro" ' Open an assembly to run the macro
End If
vMatProp = swModel.MaterialPropertyValues
Dim swAssy As SldWorks.AssemblyDoc
Set swAssy = swApp.ActiveDoc
swAssy.ResolveAllLightWeightComponents True
' Unlink display states from configuration
Dim swConfigMgr As SldWorks.ConfigurationManager
Set swConfigMgr = swModel.ConfigurationManager
swConfigMgr.LinkDisplayStatesToConfigurations = False
Dim vConfs As Variant
vConfs = swModel.GetConfigurationNames
' Get the active configuration of the file
Dim activeConfig As Configuration
Set activeConfig = swConfigMgr.ActiveConfiguration
' Check if default and random display state exists
Dim i As Integer
Dim defaultFound As Boolean
defaultFound = False
Dim randomFound As Boolean
randomFound = False
Dim confName As String
confName = activeConfig.Name
Dim swConf As SldWorks.Configuration
Set swConf = swModel.GetConfigurationByName(confName)
Dim vDispStates As Variant
vDispStates = swConf.GetDisplayStates
Dim j As Integer
For j = 0 To UBound(vDispStates)
Dim dispStateName As String
dispStateName = vDispStates(j)
If dispStateName = DEFAULT_DS Then
defaultFound = True
End If
If dispStateName = RAND_COLOR_DS Then
randomFound = True
End If
Next
Dim retValue As Boolean
' Crete default display state
If defaultFound = False Then
retValue = activeConfig.CreateDisplayState(DEFAULT_DS)
End If
' Create random color display state
If randomFound = False Then
retValue = activeConfig.CreateDisplayState(RAND_COLOR_DS)
End If
' Delete unnecessary display states
vDispStates = swConf.GetDisplayStates
For j = 0 To UBound(vDispStates)
dispStateName = vDispStates(j)
If Not (dispStateName = DEFAULT_DS) And Not (dispStateName = RAND_COLOR_DS) Then
retValue = swConf.DeleteDisplayState(dispStateName)
End If
Next
' Set current display state as random color
swConf.ApplyDisplayState RAND_COLOR_DS
'Get flat bom
Dim bom() As BomPosition
bom = GetFlatBom(swAssy)
' Apply random color to component in flat bom
RandomColor bom, swModel
Dim View As SldWorks.ModelView
Set View = swModel.ActiveView
Dim rect As Variant
Set rect = Nothing
View.GraphicsRedraw (rect)
MsgBox "Macro completed"
GoTo finally_
catch_:
MsgBox Err.Description, vbCritical, "Purge display state"
finally_:
End Sub
Function GetFlatBom(assy As SldWorks.AssemblyDoc) As BomPosition()
Dim bom() As BomPosition
Dim vComps As Variant
vComps = assy.GetComponents(False)
Dim i As Integer
For i = 0 To UBound(vComps)
Dim swComp As SldWorks.Component2
Set swComp = vComps(i)
If swComp.GetSuppression() <> swComponentSuppressionState_e.swComponentSuppressed And Not swComp.ExcludeFromBOM Then
Dim bomPos As Integer
bomPos = FindBomPosition(bom, swComp)
If bomPos = -1 Then
If (Not bom) = -1 Then
ReDim bom(0)
Else
ReDim Preserve bom(UBound(bom) + 1)
End If
bomPos = UBound(bom)
Set bom(bomPos).model = swComp.GetModelDoc2
Set bom(bomPos).comp = swComp
bom(bomPos).ModelPath = swComp.GetPathName()
bom(bomPos).Configuration = swComp.ReferencedConfiguration
bom(bomPos).Quantity = 1
GetProperties swComp, bom(bomPos).Description, bom(bomPos).Price
Else
bom(bomPos).Quantity = bom(bomPos).Quantity + 1
End If
End If
Next
GetFlatBom = bom
End Function
Function FindBomPosition(bom() As BomPosition, comp As SldWorks.Component2) As Integer
FindBomPosition = -1
If (Not bom) <> -1 Then
Dim i As Integer
For i = 0 To UBound(bom)
If LCase(bom(i).ModelPath) = LCase(comp.GetPathName()) And LCase(bom(i).Configuration) = LCase(comp.ReferencedConfiguration) Then
FindBomPosition = i
Exit Function
End If
Next
End If
End Function
Sub GetProperties(comp As SldWorks.Component2, ByRef desc As String, ByRef prc As Double)
Dim swCompModel As SldWorks.ModelDoc2
Set swCompModel = comp.GetModelDoc2()
If swCompModel Is Nothing Then
Err.Raise vbError, "", "Failed to get model from the component"
End If
desc = GetPropertyValue(swCompModel, comp.ReferencedConfiguration, "Description")
Dim prcTxt As String
prcTxt = GetPropertyValue(swCompModel, comp.ReferencedConfiguration, "Price")
If prcTxt <> "" Then
prc = CDbl(prcTxt)
End If
End Sub
Function GetPropertyValue(model As SldWorks.ModelDoc2, conf As String, prpName As String) As String
Dim confSpecPrpMgr As SldWorks.CustomPropertyManager
Dim genPrpMgr As SldWorks.CustomPropertyManager
Set confSpecPrpMgr = model.Extension.CustomPropertyManager(conf)
Set genPrpMgr = model.Extension.CustomPropertyManager("")
Dim prpVal As String
Dim prpResVal As String
confSpecPrpMgr.Get3 prpName, False, "", prpVal
If prpVal = "" Then
genPrpMgr.Get3 prpName, False, prpVal, prpResVal
End If
GetPropertyValue = prpResVal
End Function
Sub RandomColor(bom() As BomPosition, swModel As SldWorks.ModelDoc2)
' Variable declaration
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swDisplayStateSetting As SldWorks.DisplayStateSetting
Dim swAppearanceSetting As SldWorks.AppearanceSetting
' Get model display property and set display settings
Set swModelDocExt = swModel.Extension
Set swDisplayStateSetting = swModelDocExt.GetDisplayStateSetting(swThisDisplayState)
swDisplayStateSetting.Option = swThisDisplayState
swDisplayStateSetting.PartLevel = False
' Get assembly component, with repetition
Dim swAssembly As SldWorks.AssemblyDoc
Set swAssembly = swModel
Dim vElementArr As Variant
vElementArr = swAssembly.GetComponents(True)
Dim swSelMgr As SldWorks.SelectionMgr
Set swSelMgr = swModel.SelectionManager
Dim swSelData As SldWorks.SelectData
Set swSelData = swSelMgr.CreateSelectData
Dim bRet As Boolean
Dim i As Integer
Dim j As Integer
For i = 0 To UBound(bom)
bRet = bom(i).comp.Select4(False, swSelData, False)
Randomize
vMatProp(0) = Rnd 'Red
vMatProp(1) = Rnd 'Green
vMatProp(2) = Rnd 'Blue
vMatProp(3) = Rnd / 2 + 0.5 'Ambient
vMatProp(4) = Rnd / 2 + 0.5 'Diffuse
vMatProp(5) = Rnd 'Specular
vMatProp(6) = Rnd * 0.9 + 0.1 'Shininess
bom(i).comp.MaterialPropertyValues = vMatProp
' Change color for the components with the same filename
For j = 0 To UBound(vElementArr)
' Check if component is suppressed
Dim swArrComponent As SldWorks.Component2
Set swArrComponent = vElementArr(j)
If Not swArrComponent.GetSuppression2 = swComponentSuppressed Then
If bom(i).model.GetPathName = vElementArr(j).GetModelDoc2.GetPathName Then
bRet = vElementArr(j).Select4(True, swSelData, False)
vElementArr(j).MaterialPropertyValues = vMatProp
End If
End If
Next
Set swSelData = swSelMgr.CreateSelectData
Next
'Redraw to see new color
swModel.GraphicsRedraw2
End Sub
Some reference material: