Creat a Macro to Add colors to each feature in a a part

[Craig Makarowski]

Hi All I 'm not sure where to look on how to Add a unique color to each Feature in a part, the reason is that when i export the part to Unreal it would then allow me to assign Unreal texture a lot more easier, This would also be useful with surfaces on the part. It has been a while since i made some macros and i know there is a API list of all the functions for parts etc.

I usually export the part as a step file, then import into Unreal using the Data Smith tool inside Unreal.
In the past i manually colored the parts in SolidWorks. In this macro I would automate this for each feature in the part and assign it a unique color.
Thanks for your input.

[Stefan Sterk]

Hi @Craig Makarowski, See code below.

Code: Select all

Option Explicit

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swDoc As SldWorks.ModelDoc2
    Dim swFeat As SldWorks.Feature
    Dim R() As Double, G() As Double, B() As Double
    Dim vMatVal(8) As Double
    Dim i As Long: i = -1
    
    Set swApp = Application.SldWorks
    Set swDoc = swApp.ActiveDoc
    If swDoc Is Nothing Then End
    If swDoc.GetType <> swDocPART Then End
    
    Set swFeat = swDoc.FirstFeature
    While Not swFeat Is Nothing
        If swFeat.GetFaceCount <> 0 Then
            
            i = i + 1
            ReDim Preserve R(i)
            ReDim Preserve G(i)
            ReDim Preserve B(i)
            GenUniqueColor R, G, B
 
            vMatVal(0) = R(i)    ' R
            vMatVal(1) = G(i)    ' G
            vMatVal(2) = B(i)    ' B
            vMatVal(3) = 1       ' Ambient
            vMatVal(4) = 1       ' Diffuse
            vMatVal(5) = 0.5     ' Specular
            vMatVal(6) = 0.3125  'Shininess
            vMatVal(7) = 0       'Transparency
            vMatVal(8) = 0        'Emission
            
            swFeat.SetMaterialPropertyValues2 vMatVal, swInConfigurationOpts_e.swAllConfiguration, Nothing

        End If
        Set swFeat = swFeat.GetNextFeature()
    Wend
    
    'swDoc.GraphicsRedraw2
    
End Sub

Function GenUniqueColor(ByRef arrR() As Double, ByRef arrG() As Double, ByRef arrB() As Double)
reset:

    Dim R As Double, G As Double, B As Double
    R = Rnd: G = Rnd: B = Rnd
    
    Dim i As Integer
    For i = LBound(arrR) To UBound(arrR)
        If Int(arrR(i) * 254) = Int(R * 254) Then
            If Int(arrG(i) * 254) = Int(G * 254) Then
                If Int(arrB(i) * 254) = Int(B * 254) Then
                    GoTo reset
                End If
             End If
        End If
    Next i
    
    arrR(UBound(arrR)) = R
    arrG(UBound(arrG)) = G
    arrB(UBound(arrB)) = B
    
End Function

[Craig Makarowski]

Thank you very much that works excellent!!

[Craig Makarowski]

Hi @Craig Makarowski, See code below.
2023-11-24-01-16-35.gif

Code: Select all

Option Explicit

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swDoc As SldWorks.ModelDoc2
    Dim swFeat As SldWorks.Feature
    Dim R() As Double, G() As Double, B() As Double
    Dim vMatVal(8) As Double
    Dim i As Long: i = -1
    
    Set swApp = Application.SldWorks
    Set swDoc = swApp.ActiveDoc
    If swDoc Is Nothing Then End
    If swDoc.GetType <> swDocPART Then End
    
    Set swFeat = swDoc.FirstFeature
    While Not swFeat Is Nothing
        If swFeat.GetFaceCount <> 0 Then
            
            i = i + 1
            ReDim Preserve R(i)
            ReDim Preserve G(i)
            ReDim Preserve B(i)
            GenUniqueColor R, G, B
 
            vMatVal(0) = R(i)    ' R
            vMatVal(1) = G(i)    ' G
            vMatVal(2) = B(i)    ' B
            vMatVal(3) = 1       ' Ambient
            vMatVal(4) = 1       ' Diffuse
            vMatVal(5) = 0.5     ' Specular
            vMatVal(6) = 0.3125  'Shininess
            vMatVal(7) = 0       'Transparency
            vMatVal(8) = 0        'Emission
            
            swFeat.SetMaterialPropertyValues2 vMatVal, swInConfigurationOpts_e.swAllConfiguration, Nothing

        End If
        Set swFeat = swFeat.GetNextFeature()
    Wend
    
    'swDoc.GraphicsRedraw2
    
End Sub

Function GenUniqueColor(ByRef arrR() As Double, ByRef arrG() As Double, ByRef arrB() As Double)
reset:

    Dim R As Double, G As Double, B As Double
    R = Rnd: G = Rnd: B = Rnd
    
    Dim i As Integer
    For i = LBound(arrR) To UBound(arrR)
        If Int(arrR(i) * 254) = Int(R * 254) Then
            If Int(arrG(i) * 254) = Int(G * 254) Then
                If Int(arrB(i) * 254) = Int(B * 254) Then
                    GoTo reset
                End If
             End If
        End If
    Next i
    
    arrR(UBound(arrR)) = R
    arrG(UBound(arrG)) = G
    arrB(UBound(arrB)) = B
    
End Function
[/quote]

Thank you very much :-)

[Stefan Sterk]

Hi Craig, the code below will give a unique color to each component in a assembly. Thought I'd drop it here since you asked about it in our PMs.

Code: Select all

' ###################################################
' # Title: Random Colorize Components               #
' # Version: 24.1.26                                #
' # Author: Stefan Sterk                            #
' ###################################################
Option Explicit

Dim R() As Double, G() As Double, B() As Double

Sub main()
 
    Dim swApp As SldWorks.SldWorks
    Dim swDoc As SldWorks.ModelDoc2
    Dim swAsm As SldWorks.AssemblyDoc
    Dim swCmpDoc As SldWorks.ModelDoc2
    Dim Components() As SldWorks.Component2
    Dim Component As Variant
 
    Set swApp = Application.SldWorks
    Set swDoc = swApp.ActiveDoc
    If swDoc Is Nothing Then End
    If swDoc.GetType <> swDocASSEMBLY Then End
    Set swAsm = swDoc
    If swAsm.ResolveAllLightWeightComponents(True) <> 0 Then End
    
    ' Initilize color array
    ReDim Preserve R(0)
    ReDim Preserve G(0)
    ReDim Preserve B(0)

    Components() = swAsm.GetComponents(False)
    For Each Component In Components
        Set swCmpDoc = Component.GetModelDoc2
        If swCmpDoc.GetType <> swDocASSEMBLY Then ColorComp Component
    Next Component
    
    swDoc.GraphicsRedraw2
 
End Sub

Function ColorComp(vComp As Variant)

    Dim swComp As SldWorks.Component2
    Set swComp = vComp

    Dim Index As Long
    If UBound(R) <> 0 Then
        Index = UBound(R) + 1
        ReDim Preserve R(Index)
        ReDim Preserve G(Index)
        ReDim Preserve B(Index)
    End If
    
    GenUniqueColor R, G, B
    
    Dim vMatVal(8) As Double
    vMatVal(0) = R(Index)    ' R
    vMatVal(1) = G(Index)    ' G
    vMatVal(2) = B(Index)    ' B
    vMatVal(3) = 1       ' Ambient
    vMatVal(4) = 1       ' Diffuse
    vMatVal(5) = 0.5     ' Specular
    vMatVal(6) = 0.3125  'Shininess
    vMatVal(7) = 0       'Transparency
    vMatVal(8) = 0        'Emission
    
    swComp.SetMaterialPropertyValues2 vMatVal, swInConfigurationOpts_e.swAllConfiguration, Nothing
    
End Function

Function GenUniqueColor(ByRef arrR() As Double, ByRef arrG() As Double, ByRef arrB() As Double)
reset:

    Dim R As Double, G As Double, B As Double
    R = Rnd: G = Rnd: B = Rnd
    
    Dim i As Integer
    For i = LBound(arrR) To UBound(arrR)
        If Int(arrR(i) * 254) = Int(R * 254) Then
            If Int(arrG(i) * 254) = Int(G * 254) Then
                If Int(arrB(i) * 254) = Int(B * 254) Then
                    GoTo reset
                End If
             End If
        End If
    Next i
    
    arrR(UBound(arrR)) = R
    arrG(UBound(arrG)) = G
    arrB(UBound(arrB)) = B
    
End Function