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

Edit ArticleEdit Article
More 'Goodies'

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.


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()

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

    ColorsMap.CompareMode = vbTextCompare


    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
            Err.Raise vbError, "", "Only part document is supported"
        End If
        Err.Raise vbError, "", "Open part document"
    End If
    GoTo finally_
    MsgBox Err.Description, vbCritical
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)
                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
        End If
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
    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()
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
    ElseIf feat.GetTypeName2() = "CutListFolder" Then
        If Not Contains(cutLists, feat) Then
            If (Not cutLists) = -1 Then
                ReDim cutLists(0)
                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
    Contains = False
End Function

Product of Xarial Product of Xarial