Solidworks VBA help

[Yogibear]

I've got a macro that colorizes an assembly. I can get it to colorize it the first time but it should keep randomly appling colors, everytime you run the macro.

'Dim swApp As Object
'Set swApp = Application.SldWorks


Public CompNames As New Collection
Public CompColors As New Collection
Public ComponentName As String
Public R As Double
Public G As Double
Public B As Double
Sub main()

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim nStart As Single
Dim bRet As Boolean

Set swApp = GetObject(, "SldWorks.Application")
Set swModel = swApp.ActiveDoc
Set swConf = swModel.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent

R = 145
G = 241
B = 135

TraverseComponent swRootComp, 1
swModel.EditRebuild3
MsgBox ("Process Complete")
End Sub

Sub ColorComp(swComp As Component2, swFeat As feature, RVAL As Double, GVAL As Double, Bval As Double)
Dim BoolRes As Boolean
Dim swCompModel As ModelDoc2

If swFeat.Name <> "" Then
MaterialProp = swFeat.GetMaterialPropertyValues
If IsEmpty(MaterialProp) = False Then

MaterialProp(0) = RVAL / 255
MaterialProp(1) = GVAL / 255
MaterialProp(2) = Bval / 255
BoolRes = swFeat.SetMaterialPropertyValues(MaterialProp)

Else
Set swCompModel = swComp.GetModelDoc
MaterialProp = swCompModel.MaterialPropertyValues
MaterialProp(0) = RVAL / 255
MaterialProp(1) = GVAL / 255
MaterialProp(2) = Bval / 255
swComp.MaterialPropertyValues = MaterialProp

End If

End If

End Sub
Sub TraverseFeatureFeatures(swComp As Component2, swFeat As SldWorks.feature, nLevel As Long)

Dim swSubFeat As SldWorks.feature
Dim swSubSubFeat As SldWorks.feature
Dim swSubSubSubFeat As SldWorks.feature
Dim I As Integer
Dim Colors
Dim ColorFound As Boolean

ColorFound = False

While Not swFeat Is Nothing
If swFeat.GetTypeName = "DetailCabinet" Then
For I = 1 To CompColors.Count

Colors = Split(CompColors.Item(I), "/")
If Colors(0) = ComponentName Then
R = Colors(1)
G = Colors(2)
B = Colors(3)
ColorFound = True
Exit For
End If
Next
If ColorFound = False Then
CompColors.Add ComponentName & "/" & R & "/" & G & "/" & B
End If
'sbr.Panels(1).Text = ComponentName
ColorComp swComp, swFeat, R, G, B

End If
Set swFeat = swFeat.GetNextFeature
Wend
R = R + 100
G = G - 50
B = B + 120
End Sub

Sub TraverseComponentFeatures(swComp As SldWorks.Component2, nLevel As Long)

Dim swFeat As SldWorks.feature

Set swFeat = swComp.FirstFeature
' MsgBox swFeat.Name & " - " & swFeat.GetTypeName
TraverseFeatureFeatures swComp, swFeat, nLevel

End Sub

Sub TraverseComponent(swComp As SldWorks.Component2, nLevel As Long)

Dim vChildComp As Variant
Dim swChildComp As SldWorks.Component2
Dim swCompConfig As SldWorks.Configuration
Dim sPadStr As String
Dim I As Long
Dim J As Integer
Dim SwChildCompDoc As ModelDoc2
Dim NameFound As Boolean

NameFound = False

vChildComp = swComp.GetChildren

For I = 0 To UBound(vChildComp)

Set swChildComp = vChildComp(I)
Set SwChildCompDoc = swChildComp.GetModelDoc
If Not SwChildCompDoc Is Nothing Then 'I added this line to prevent an error - D Schuman

If SwChildCompDoc.GetType = swDocPART Then
For J = 1 To CompNames.Count
If CompNames.Item(J) = swChildComp.Name2 Then
NameFound = True
End If
Next
If NameFound = False Then
CompNames.Add swChildComp.Name2
ComponentName = SwChildCompDoc.GetTitle
' MsgBox (ComponentName)
TraverseComponentFeatures swChildComp, nLevel
End If
End If
TraverseComponent swChildComp, nLevel + 1
End If
Next I

End Sub

 

[cowski]

The method you use to pick colors seems to be deterministic rather than random (ie the program picks the same colors every time you run it). You may want to look into the 'randomize' and 'rnd' statements.

 

[Yogibear]

I'm going to have to readup on how to do that. I'm pretty new to programming. I stumbled across this and it kind-of worked like I wanted. Thanks for the advice.