×
INTELLIGENT WORK FORUMS
FOR ENGINEERING PROFESSIONALS

Log In

Come Join Us!

Are you an
Engineering professional?
Join Eng-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!
  • Students Click Here

*Eng-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Students Click Here

Jobs

colorize assembly macro, need assistance.

colorize assembly macro, need assistance.

colorize assembly macro, need assistance.

(OP)
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, as long as you keep running 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

Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

Red Flag Submitted

Thank you for helping keep Eng-Tips Forums free from inappropriate posts.
The Eng-Tips staff will check this out and take appropriate action.

Reply To This Thread

Posting in the Eng-Tips forums is a member-only feature.

Click Here to join Eng-Tips and talk with other members!


Resources