Macro to colorize SOLIDWORKS sheet metal and weldment cut-list items

This VBA macro allows to assign a unique color for each group of cut-list items (sheet metal or weldment) based on the value of the custom property.

The most common use of this macro will be to differentiate different type of weldment items based on the profile size.

Macro will automatically assign random color to the specific group. It is possible to specify the constant colors to use for the specific group instead of random colors.

Configuration

In order to specify the name of the custom property to read the value from and group cut-list items, change the value of the PRP_NAME constant

Const PRP_NAME As String = "Description" 'Change the value of Description to select different custom property

In order to specify colors it is required to modify the values within the InitColors method.

Sub InitColors(Optional dummy As Variant = Empty)

    ColorsMap.Add "SB BEAM 80 X 6", RGB(255, 0, 0)
    ColorsMap.Add "TUBE, RECTANGULAR 50 X 30 X 2.60", RGB(0, 255, 0)
    
End Sub

To add new color to the map add the following line

ColorsMap.Add "[PROPERTY VALUE]", RGB([Red], [Green], [Blue])

For example to add the blue (RGB = 0, 0, 255) color to the weldment profile "50 X 50", it is required to add the following line

ColorsMap.Add "50 X 50", RGB(0, 0, 255)

Const PRP_NAME As String = "Description"

Dim swApp As SldWorks.SldWorks
Dim ColorsMap As Object

Sub main()

try_:
    
    On Error GoTo catch_
    
    Set ColorsMap = CreateObject("Scripting.Dictionary")

    ColorsMap.CompareMode = vbTextCompare

    InitColors

    Set swApp = Application.SldWorks
    
    Dim swModel As SldWorks.ModelDoc2
    
    Set swModel = swApp.ActiveDoc
    
    If Not swModel Is Nothing Then
        If swModel.GetType() = swDocumentTypes_e.swDocPART Then
            Dim vCutLists As Variant
            vCutLists = GetCutLists(swModel)
            ColorizeCutLists vCutLists
            swModel.GraphicsRedraw2
        Else
            Err.Raise vbError, "", "Only part document is supported"
        End If
    Else
        Err.Raise vbError, "", "Open part document"
    End If
    
    GoTo finally_
    
catch_:
    MsgBox Err.Description, vbCritical
finally_:
    
End Sub

Sub InitColors(Optional dummy As Variant = Empty)

    ColorsMap.Add "SB BEAM 80 X 6", RGB(255, 0, 0)
    ColorsMap.Add "TUBE, RECTANGULAR 50 X 30 X 2.60", RGB(0, 255, 0)
    
End Sub

Sub ColorizeCutLists(vCutLists As Variant)
    
    Dim i As Integer
    
    For i = 0 To UBound(vCutLists)
        
        Dim swCutList As SldWorks.Feature
        Set swCutList = vCutLists(i)
        
        Dim swBodyFolder As SldWorks.BodyFolder
        Set swBodyFolder = swCutList.GetSpecificFeature2
        
        If swBodyFolder.GetBodyCount() > 0 Then
            
            Dim swCustPrpsMgr As SldWorks.CustomPropertyManager
            Set swCustPrpsMgr = swCutList.CustomPropertyManager
            Dim prpVal As String
            swCustPrpsMgr.Get5 PRP_NAME, True, "", prpVal, False
            
            Dim color As Long
            
            If ColorsMap.Exists(prpVal) Then
                color = ColorsMap(prpVal)
            Else
                color = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
                ColorsMap.Add prpVal, color
            End If
            
            Dim j As Integer
            
            Dim vBodies As Variant
            vBodies = swBodyFolder.GetBodies
            
            For j = 0 To UBound(vBodies)
            
                Dim swBody As SldWorks.Body2
                Set swBody = vBodies(j)
                
                Dim RGBHex As String

                RGBHex = Right("000000" & Hex(color), 6)
                
                Dim dMatPrps(8) As Double
                
                dMatPrps(0) = CInt("&H" & Mid(RGBHex, 5, 2)) / 255
                dMatPrps(1) = CInt("&H" & Mid(RGBHex, 3, 2)) / 255
                dMatPrps(2) = CInt("&H" & Mid(RGBHex, 1, 2)) / 255
                dMatPrps(3) = 1
                dMatPrps(4) = 1
                dMatPrps(5) = 0.5
                dMatPrps(6) = 0.3125
                dMatPrps(7) = 0
                dMatPrps(8) = 0
                
                swBody.MaterialPropertyValues2 = dMatPrps
            Next
            
        End If
        
    Next
    
End Sub

Function GetCutLists(model As SldWorks.ModelDoc2) As Variant

    Dim swFeat As SldWorks.Feature
    
    Dim swCutLists() As SldWorks.Feature
    
    Set swFeat = model.FirstFeature
    
    While Not swFeat Is Nothing
        
        If swFeat.GetTypeName2 <> "HistoryFolder" Then
        
            ProcessFeature swFeat, swCutLists
            
            TraverseSubFeatures swFeat, swCutLists
        
        End If
        
        Set swFeat = swFeat.GetNextFeature
        
    Wend
    
    GetCutLists = swCutLists
    
End Function

Sub TraverseSubFeatures(parentFeat As SldWorks.Feature, cutLists() As SldWorks.Feature)
    
    Dim swChildFeat As SldWorks.Feature
    Set swChildFeat = parentFeat.GetFirstSubFeature
    
    While Not swChildFeat Is Nothing
        ProcessFeature swChildFeat, cutLists
        Set swChildFeat = swChildFeat.GetNextSubFeature()
    Wend
    
End Sub

Sub ProcessFeature(feat As SldWorks.Feature, cutLists() As SldWorks.Feature)
    
    If feat.GetTypeName2() = "SolidBodyFolder" Then
        Dim swBodyFolder As SldWorks.BodyFolder
        Set swBodyFolder = feat.GetSpecificFeature2
        swBodyFolder.UpdateCutList
    ElseIf feat.GetTypeName2() = "CutListFolder" Then
        
        If Not Contains(cutLists, feat) Then
            If (Not cutLists) = -1 Then
                ReDim cutLists(0)
            Else
                ReDim Preserve cutLists(UBound(cutLists) + 1)
            End If
            
            Set cutLists(UBound(cutLists)) = feat
        End If
        
    End If
    
End Sub

Function Contains(arr As Variant, item As Object) As Boolean
    
    Dim i As Integer
    
    For i = 0 To UBound(arr)
        If arr(i) Is item Then
            Contains = True
            Exit Function
        End If
    Next
    
    Contains = False
    
End Function