Macro to assign random color to sketches in the document

This VBA macro assigns the random color to all sketches of active parts or assemblies.

Macro can be configured to skip sketches with already assigned colors and select only unabsorbed sketches (e.g. sketches which are not used in other features)

Const SKIP_ASSIGNED As Boolean = False 'Processes all sketches (including the sketches with assigned colors)
Const UNABSORBED_ONLY As Boolean = False 'Process all sketches (absorbed and unabsorbed)

Color will be assigned on the feature appearance level.

Const SKIP_ASSIGNED As Boolean = True
Const UNABSORBED_ONLY As Boolean = True

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2

Sub main()

    Set swApp = Application.SldWorks

    Set swModel = swApp.ActiveDoc
    
    Dim vFeats As Variant
    vFeats = CollectAllSketchFeatures(swModel.FirstFeature)
    
    If Not IsEmpty(vFeats) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vFeats)
            
            Dim swFeat As SldWorks.Feature
            Set swFeat = vFeats(i)
            
            If Not SKIP_ASSIGNED Or Not HasAppearence(swFeat) Then
                
                If Not UNABSORBED_ONLY Or Not IsAbsorbed(swFeat) Then
                    
                    Dim dMatPrps(8) As Double
                    dMatPrps(0) = Rnd(): dMatPrps(1) = Rnd(): dMatPrps(2) = Rnd()
                    dMatPrps(3) = 1: dMatPrps(4) = 1: dMatPrps(5) = 0.5
                    dMatPrps(6) = 0.4: dMatPrps(7) = 0: dMatPrps(8) = 0
                    
                    Debug.Print "Assigning color " & dMatPrps(0) * 255 & ";" & dMatPrps(1) * 255 & ";" & dMatPrps(2) * 255 & " to " & swFeat.Name
                    
                    swFeat.SetMaterialPropertyValues2 dMatPrps, swInConfigurationOpts_e.swThisConfiguration, Empty
                    
                End If
                
            End If
            
        Next
        
    End If

End Sub

Function IsAbsorbed(feat As SldWorks.Feature) As Boolean
    
    Dim vFeatChildren As Variant
    vFeatChildren = feat.GetChildren()
    
    IsAbsorbed = Not IsEmpty(vFeatChildren)
    
End Function

Function HasAppearence(feat As SldWorks.Feature) As Boolean
    
    Dim vMatPrpVals As Variant
    vMatPrpVals = feat.GetMaterialPropertyValues2(swInConfigurationOpts_e.swThisConfiguration, Empty)
            
    HasAppearence = vMatPrpVals(0) <> -1 And vMatPrpVals(1) <> -1 And vMatPrpVals(2) <> -1
    
End Function

Function CollectAllSketchFeatures(firstFeat As SldWorks.Feature) As Variant
    
    Const SKETCH_FEAT_TYPE_NAME As String = "ProfileFeature"
    Const SKETCH_3D_FEAT_TYPE_NAME As String = "3DProfileFeature"

    Dim swFeats() As SldWorks.Feature

    Dim swFeat As SldWorks.Feature
    Set swFeat = firstFeat
    
    While Not swFeat Is Nothing
    
        If swFeat.GetTypeName2 = SKETCH_FEAT_TYPE_NAME Or _
            swFeat.GetTypeName2 = SKETCH_3D_FEAT_TYPE_NAME Then
            
            If (Not swFeats) = -1 Then
                ReDim swFeats(0)
            Else
                ReDim Preserve swFeats(UBound(swFeats) + 1)
            End If
            
            Set swFeats(UBound(swFeats)) = swFeat
            
        End If
        
        Set swFeat = swFeat.GetNextFeature
        
    Wend
    
    If (Not swFeats) = -1 Then
        CollectAllSketchFeatures = Empty
    Else
        CollectAllSketchFeatures = swFeats
    End If
    
End Function

Line Colors

This is an alternative version of the macro which assigns the color as a line color instead of the feature appearance.

This macro will assign the random color for all selected sketches or all sketches if no sketches are selected. UNABSORBED_ONLY option is only considered when no sketches are selected.

Const UNUBSORBED_ONLY As Boolean = True

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc

Sub main()

    Set swApp = Application.SldWorks

    Set swModel = swApp.ActiveDoc
        
    Set swPart = swModel
        
    Dim vFeats As Variant
    
    vFeats = CollectSelectedSketches(swModel)
    
    If IsEmpty(vFeats) Then
        vFeats = CollectAllSketchFeatures(swModel.FirstFeature)
    End If
    
    If Not IsEmpty(vFeats) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vFeats)
            
            Dim swFeat As SldWorks.Feature
            Set swFeat = vFeats(i)
                        
            If False <> swFeat.Select2(False, -1) Then
                swPart.SetLineColor RGB(CInt(255 * Rnd()), CInt(255 * Rnd()), CInt(255 * Rnd()))
            Else
                Err.Raise vbError, "", "Failed to select " & swFeat.Name
            End If
            
        Next
        
    End If
    
    swModel.ClearSelection2 True

End Sub

Function IsAbsorbed(feat As SldWorks.Feature) As Boolean
    
    Dim vFeatChildren As Variant
    vFeatChildren = feat.GetChildren()
    
    IsAbsorbed = Not IsEmpty(vFeatChildren)
    
End Function

Function CollectSelectedSketches(model As SldWorks.ModelDoc2) As Variant
    
    Dim swFeats() As SldWorks.Feature

    Dim swSelMgr As SldWorks.SelectionMgr
    
    Set swSelMgr = model.SelectionManager
    
    Dim i As Integer
    
    For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
        
        If swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelSKETCHES Then
            
            If (Not swFeats) = -1 Then
                ReDim swFeats(0)
            Else
                ReDim Preserve swFeats(UBound(swFeats) + 1)
            End If
            
            Set swFeats(UBound(swFeats)) = swSelMgr.GetSelectedObject6(i, -1)
            
        End If
        
    Next
    
    If (Not swFeats) = -1 Then
        CollectSelectedSketches = Empty
    Else
        CollectSelectedSketches = swFeats
    End If

End Function

Function CollectAllSketchFeatures(firstFeat As SldWorks.Feature) As Variant
    
    Const SKETCH_FEAT_TYPE_NAME As String = "ProfileFeature"
    Const SKETCH_3D_FEAT_TYPE_NAME As String = "3DProfileFeature"

    Dim swFeats() As SldWorks.Feature

    Dim swFeat As SldWorks.Feature
    Set swFeat = firstFeat
    
    While Not swFeat Is Nothing
    
        If swFeat.GetTypeName2 = SKETCH_FEAT_TYPE_NAME Or _
            swFeat.GetTypeName2 = SKETCH_3D_FEAT_TYPE_NAME Then
            
            If Not UNUBSORBED_ONLY Or Not IsAbsorbed(swFeat) Then
            
                If (Not swFeats) = -1 Then
                    ReDim swFeats(0)
                Else
                    ReDim Preserve swFeats(UBound(swFeats) + 1)
                End If
                
                Set swFeats(UBound(swFeats)) = swFeat
            
            End If
            
        End If
        
        Set swFeat = swFeat.GetNextFeature
        
    Wend
    
    If (Not swFeats) = -1 Then
        CollectAllSketchFeatures = Empty
    Else
        CollectAllSketchFeatures = swFeats
    End If
    
End Function