I created this so that my models are guaranteed to have one material for every appearance p2m file when exported using the Free_SolidWorks_OBJ_Exporter_v2.0 for blender.
replaceAppearance.swp
Code: Select all
'add reference to microsoft scripting runtime
'create the class module and populate
'requires "option link display states to configurations" to be off.
'if the part is mirrored the config may need to been opened. maybe need to do rebuild of all configs before calling
'This macro allows for global appearances by reloading appearance data from disk.
'To use:
'1. Create create a folder to store your custom appearances. Set variable -> "yourApperanceLibrary"
'2. Save a p2m file into this folder. The name of the p2m file can never change for this script to work.
'3. Apply your custom p2m file to multiple parts, bodies, faces.
'4. Now edit or overwrite your p2m file inside "yourApperanceLibrary"
'5. Run this script
'
'The script will traverse the assembly tree and compile a list of entities with unique appearances.
'It will then check if the appearance name is a file inside "yourApperanceLibrary"
'Finally it will replace the material properties of the solidworks entity with the material properties of the original p2m file
Dim yourApperanceLibrary As String
Dim swApp As Object
Dim swAssy As ModelDoc2
Sub main()
yourApperanceLibrary = "Z:\Video & images\Appearances\Material Standards\"
Set swApp = Application.SldWorks
Set swAssy = swApp.ActiveDoc
Set apperanceTree = getApperancesUsed(swAssy) 'scan assembly for appearances
For Each clr In apperanceTree 'print the entire assembly appearance tree
Debug.Print (clr)
For Each ent In apperanceTree.Item(clr)
Debug.Print (vbTab & ent)
Next
Next
For Each clr In apperanceTree 'perform appearance swap
p2mFile = yourApperanceLibrary & clr & ".p2m"
out = replaceAppearance(apperanceTree, clr, p2mFile)
Next
End Sub
Function replaceAppearance(appearanceSet, searchAppearance, newAppearance)
Set appSubSet = appearanceSet.Item(searchAppearance)
If Not Dir(newAppearance, vbDirectory) = vbNullString Then 'p2m file still exists inside your library so swap material
Debug.Print (vbCrLf & "Color Swap : " & searchAppearance)
For Each appEntity In appSubSet 'iterate over entities that match the search appearance
Set replaceMatObj = appSubSet.Item(appEntity).swModel.Extension.CreateRenderMaterial(newAppearance) 'create a new render material that will have the current values from the p2m file. this might not need to be created local to the entity, but oh well
'Debug.Print (replaceMatObj.fileName)
Debug.Print (vbTab & appEntity)
priColor = replaceMatObj.PrimaryColor
r = priColor And &HFF
g = (priColor And &HFF00&) \ 256 'edited to force long
b = (priColor And &HFF0000) \ 65536
existVals = appSubSet.Item(appEntity).matProp
If Not IsEmpty(existVals) Then
existVals(0) = r / 255
existVals(1) = g / 255
existVals(2) = b / 255
existVals(3) = replaceMatObj.Ambient
existVals(4) = replaceMatObj.Diffuse
existVals(5) = replaceMatObj.Specular
existVals(6) = replaceMatObj.Glossy
existVals(7) = replaceMatObj.Transparency
existVals(8) = replaceMatObj.Emission
'Debug.Print (appSubSet.Item(appEntity).mode)
'edited to only allow single method. i think SetMaterialPropertyValues2 corrupts
'If (appSubSet.Item(appEntity).mode = 1) Then
' out = appSubSet.Item(appEntity).swEntity.SetMaterialPropertyValues2(existVals, swInConfigurationOpts_e.swAllConfiguration)
'Else
appSubSet.Item(appEntity).swEntity.MaterialPropertyValues = existVals
'End If
Else ' this should not happen
Debug.Print ("Empty existing apperance for : " & appEntity)
End If
Next
End If
End Function
Function getApperancesUsed(m, Optional displayState = "", Optional config = "") As Scripting.Dictionary
Dim matList As New Scripting.Dictionary
If Not m Is Nothing Then
If (m.GetType = swDocumentTypes_e.swDocASSEMBLY) Then 'recurse into assembly
For Each comp In m.GetComponents(True)
Set lsub = getApperancesUsed(comp.GetModelDoc, comp.ReferencedDisplayState, comp.ReferencedConfiguration) 'results will bubble up
If Not lsub Is Nothing Then
For Each clr In lsub.keys
If matList.Exists(clr) Then 'need to do careful merge
For Each node In lsub(clr)
If Not matList.Item(clr).Exists(node) Then 'unique
matList.Item(clr).Add node, lsub.Item(clr).Item(node)
End If
Next
Else 'new color was found
matList.Add clr, lsub(clr)
End If
Next
End If
Next
ElseIf (m.GetType = swDocumentTypes_e.swDocPART) Then 'gather a list of materials applied to the part
Title = m.GetTitle
Dim loopIndex As Integer
loopIndex = 0
For Each mat In m.Extension.GetRenderMaterials2(swDisplayStateOpts_e.swAllDisplayState)
Set fso = CreateObject("Scripting.FileSystemObject")
fnNe = UCase(Replace(fso.GetFilename(mat.fileName), ".p2m", ""))
Dim newPossibleVals As New Scripting.Dictionary
For Each ent In mat.GetEntities()
loopIndex = loopIndex + 1 'loop index is needed because when multiple configs are used in the same assembly it will only swap one of them
uniqueKey = UCase(Title & "\" & config & "\" & displayState & "\" & ent.GetType & "\" & loopIndex) 'tried to come up with a good key that will catch all uniques and hopefully not redundant.
'get the material properties of the entity
If (ent.GetType = swSelectType_e.swSelBODYFEATURES) Then
MatProps = ent.GetMaterialPropertyValues2(swInConfigurationOpts_e.swAllConfiguration)
mode = 1
Else
MatProps = ent.MaterialPropertyValues
mode = 2
End If
If VarType(MatProps) = 0 Then 'above failed so assume it is body
MatProps = ent.MaterialPropertyValues2
mode = 3
End If
If VarType(MatProps) = 0 Then
MsgBox ("this type not supported" & ent.GetType)
End If
'log local findings
Dim propObj As New lookupNode
Set propObj.swModel = m
Set propObj.swEntity = ent
propObj.matProp = MatProps
propObj.swType = ent.GetType
propObj.mode = mode
If Not newPossibleVals.Exists(uniqueKey) Then 'cull duplicates
newPossibleVals.Add uniqueKey, propObj
End If
Next
'global merge
If Not matList.Exists(fnNe) Then 'new appearance here so direct copy
matList.Add fnNe, newPossibleVals
Else 'color already existed so careful merge
For Each key In newPossibleVals
If Not matList.Item(fnNe).Exists(key) Then 'cull duplicates
matList.Item(fnNe).Add key, newPossibleVals(key)
End If
Next
End If
Next
End If
End If
Set getApperancesUsed = matList
End Function
Code: Select all
Public matProp As Variant
Public swModel As ModelDoc2
Public swEntity As Variant
Public swType As Integer
Public mode As Integer