Global apperance replacement.

Programming and macros
colt
Posts: 56
Joined: Tue Mar 30, 2021 5:43 pm
Answers: 0
x 14
x 22

Global apperance replacement.

Unread post by colt »

This is a little script that recursively replaces the model appearances of the active document with that of the p2m file of the same name. It will not replace textures.

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
right click on macro and insert>class module. add the following definitions. rename the class to lookupNode

Code: Select all

Public matProp As Variant
Public swModel As ModelDoc2
Public swEntity As Variant
Public swType As Integer
Public mode As Integer
Post Reply