9 Replies Latest reply on Feb 7, 2017 4:21 PM by Asa Eckert-Erdheim

    GetComponents Unique List

    Asa Eckert-Erdheim

      I'm looking to modify a macro to assign colors to parts (Paint A Rainbow On Your SolidWorks Assembly. Multi-Colored Macro Follow-up. - SolidSmack - ) to color all identical parts the same rather than just assign a new color to each part. Is there a good method to create a list of all the unique parts rather than every part as GetComponents does?

       

      Thanks.

        • Re: GetComponents Unique List
          Josh Brady

          If I were to approach this, just off the top of my head, I would probably:

           

          Start a new collection or array or something

          Put the first component in there

          Look at the next component.  Same modeldoc2.getpathname and getrefrerencedconfiguration as any in the collection? If not, add it.

          Repeat for all the rest of the components.

          • Re: GetComponents Unique List
            Ivana Kolin
            Option Explicit
            'You need to have reference to Microsoft Scripting Runtime first.
            Sub main()
                Dim swApp                                     As SldWorks.SldWorks
                Dim swMainModel                               As SldWorks.ModelDoc2
                Dim vComponents                               As Variant
                Dim swAssy                                    As SldWorks.AssemblyDoc
                Dim swComponent                               As SldWorks.Component2
                Dim i                                         As Integer
                Dim vMatProp                                  As Variant
                Dim dict                                      As Dictionary
                Set dict = CreateObject("Scripting.Dictionary")
                Set swApp = Application.SldWorks
                Set swMainModel = swApp.ActiveDoc
                If swMainModel.GetType <> swDocASSEMBLY Then
                    MsgBox "Macro works only with assembly"
                    Exit Sub
                End If
                Set swAssy = swMainModel
                vComponents = swAssy.GetComponents(False)
                If IsEmpty(vComponents) Then
                    Exit Sub
                End If
                Randomize
                vMatProp = swMainModel.MaterialPropertyValues
                For i = 0 To UBound(vComponents)
                    Set swComponent = vComponents(i)
                    'Get all elements
                    If UBound(swComponent.GetChildren) Then
                        If dict.Exists(UCase(swComponent.GetPathName)) Then
                            vMatProp = dict.Item(UCase(swComponent.GetPathName))
                        Else
                            vMatProp(0) = Rnd                          'Red
                            vMatProp(1) = Rnd                          'Green
                            vMatProp(2) = Rnd                          'Blue
                            dict.Add UCase(swComponent.GetPathName), vMatProp
                        End If
                        swComponent.MaterialPropertyValues = vMatProp
                    End If
                Next i
                'Redraw to see new color
                swMainModel.GraphicsRedraw2
            End Sub
            
              • Re: GetComponents Unique List
                Amen Allah Jlili

                Looks good! You forgot to include configuration names as a coloring criteria.

                • Re: GetComponents Unique List
                  Asa Eckert-Erdheim

                  Thanks Ivana (and all others) for the help. That code worked well with a few tweaks, primarily "If UBound(swComponent.GetChildren) = -1" as Amen suggested, otherwise the assembly color overwrites the underlying part colors. I've added a bit more to make the color selection slightly cleaner using the golden ratio method described here: http://martin.ankerl.com/2009/12/09/how-to-create-random-colors-programmatically/

                   

                  The other option would be to count all the parts and pick that many colors equally spaced, but this yielded good enough results. One limiting factor right now is the order the parts get colored means many of my parts end up similar colors. Is there a good way to randomly re-order the list returned by GetComponents? That would let me run the macro a few times until the colors were a bit better distributed.

                   

                  Code in its current state is below.

                   

                  Option Explicit
                  'You need to have reference to Microsoft Scripting Runtime first.
                  
                  
                  Type RGBColor
                       Red As Byte
                       Green As Byte
                       Blue As Byte
                  End Type
                  
                  
                  Type HSBColor
                       Hue As Double
                       Saturation As Double
                       Brightness As Double
                  End Type
                  
                  
                  Public Function FMod(a As Double, b As Double) As Double
                      FMod = a - Fix(a / b) * b
                  
                  
                      'http://en.wikipedia.org/wiki/Machine_epsilon
                      'Unfortunately, this function can only be accurate when `a / b` is outside [-2.22E-16,+2.22E-16]
                      'Without this correction, FMod(.66, .06) = 5.55111512312578E-17 when it should be 0
                      If FMod >= -2 ^ -52 And FMod <= 2 ^ -52 Then '+/- 2.22E-16
                          FMod = 0
                      End If
                  End Function
                  
                  
                  Function HSBToRGB(hsb As HSBColor) As RGBColor
                  
                  
                      Dim h, s, b As Double
                           h = hsb.Hue
                           s = hsb.Saturation
                           b = hsb.Brightness
                           
                      Dim i As Long
                      Dim f, p, q, t As Double
                  
                  
                      If s = 0 Then
                            HSBToRGB.Red = 0
                            HSBToRGB.Green = 0
                            HSBToRGB.Blue = 0
                      End If
                      
                      h = h / 60
                      i = Int(h)
                      f = h - i
                      p = b * (1 - s)
                      q = b * (1 - s * f)
                      t = b * (1 - s * (1 - f))
                      
                      Select Case i
                          Case 0
                              HSBToRGB.Red = b * 255
                              HSBToRGB.Green = t * 255
                              HSBToRGB.Blue = p * 255
                              
                          Case 1
                              HSBToRGB.Red = q * 255
                              HSBToRGB.Green = b * 255
                              HSBToRGB.Blue = p * 255
                              
                          Case 2
                              HSBToRGB.Red = p * 255
                              HSBToRGB.Green = b * 255
                              HSBToRGB.Blue = t * 255
                              
                          Case 3
                              HSBToRGB.Red = p * 255
                              HSBToRGB.Green = q * 255
                              HSBToRGB.Blue = b * 255
                              
                          Case 4
                              HSBToRGB.Red = t * 255
                              HSBToRGB.Green = p * 255
                              HSBToRGB.Blue = b * 255
                              
                          Case 5
                              HSBToRGB.Red = b * 255
                              HSBToRGB.Green = p * 255
                              HSBToRGB.Blue = q * 255
                              
                      End Select
                            
                       
                  End Function
                  
                  
                  Sub main()
                      Dim swApp                                     As SldWorks.SldWorks
                      Dim swMainModel                               As SldWorks.ModelDoc2
                      Dim vComponents                               As Variant
                      Dim swAssy                                    As SldWorks.AssemblyDoc
                      Dim swComponent                               As SldWorks.Component2
                      Dim i                                         As Integer
                      Dim vMatProp                                  As Variant
                      Dim dict                                      As Dictionary
                      Dim h                                         As Double
                      Dim golden_ratio                              As Double
                      Dim newRGB                                    As RGBColor
                      Dim newHSB                                    As HSBColor
                      
                      golden_ratio = 0.618033988749895
                      
                      Set dict = CreateObject("Scripting.Dictionary")
                      Set swApp = Application.SldWorks
                      Set swMainModel = swApp.ActiveDoc
                      If swMainModel.GetType <> swDocASSEMBLY Then
                          MsgBox "Macro works only with assembly"
                          Exit Sub
                      End If
                      Set swAssy = swMainModel
                      vComponents = swAssy.GetComponents(False)
                      If IsEmpty(vComponents) Then
                          Exit Sub
                      End If
                      
                      Randomize 'Initializes new random number
                      h = Rnd
                      vMatProp = swMainModel.MaterialPropertyValues
                      
                      For i = 0 To UBound(vComponents)
                          Set swComponent = vComponents(i)
                          'Get all elements
                          
                          If UBound(swComponent.GetChildren) = -1 Then
                              If dict.Exists(UCase(swComponent.GetPathName)) Then
                                  vMatProp = dict.Item(UCase(swComponent.GetPathName))
                              Else
                                  h = h + golden_ratio
                                  h = FMod(h, 1)
                                  
                                  newHSB.Hue = h * 360
                                  newHSB.Brightness = 0.75
                                  newHSB.Saturation = 0.75
                                  
                                  newRGB = HSBToRGB(newHSB)
                                  
                                  Debug.Print newRGB.Blue, newRGB.Green, newRGB.Blue
                                  
                                  vMatProp(0) = newRGB.Red                          'Red
                                  vMatProp(1) = newRGB.Green                          'Green
                                  vMatProp(2) = newRGB.Blue                          'Blue
                                  dict.Add UCase(swComponent.GetPathName), vMatProp
                              End If
                              swComponent.MaterialPropertyValues = vMatProp
                          End If
                      Next i
                      'Redraw to see new color
                      swMainModel.GraphicsRedraw2
                  End Sub
                  
                    • Re: GetComponents Unique List
                      Asa Eckert-Erdheim

                      Actually managed to answer my own question. Its a bit of a hack, but I generated an array that counted from zero to the number of components, did a random arrangement of that array (courtesy of Shuffle Array ), and then used that array as the indices to loop through all the components. It didn't have as big of an impact as I was hoping, but it does help. I can cycle through a few times until I avoid clusters of similar colors.

                       

                      I also added a quick hard-coded variable for my fastener path to avoid running this on my fasteners. Mostly, this is to reduce the number of components with the aim of having a slightly cleaner color spread.

                       

                      Any thoughts on improvements would be helpful.

                       

                      Option Explicit
                      'You need to have reference to Microsoft Scripting Runtime first.
                      
                      
                      Type RGBColor
                           Red As Byte
                           Green As Byte
                           Blue As Byte
                      End Type
                      
                      
                      Type HSBColor
                           Hue As Double
                           Saturation As Double
                           Brightness As Double
                      End Type
                      
                      
                      Public Function FMod(a As Double, b As Double) As Double
                          FMod = a - Fix(a / b) * b
                      
                      
                          'http://en.wikipedia.org/wiki/Machine_epsilon
                          'Unfortunately, this function can only be accurate when `a / b` is outside [-2.22E-16,+2.22E-16]
                          'Without this correction, FMod(.66, .06) = 5.55111512312578E-17 when it should be 0
                          If FMod >= -2 ^ -52 And FMod <= 2 ^ -52 Then '+/- 2.22E-16
                              FMod = 0
                          End If
                      End Function
                      
                      
                      Sub ShuffleArrayInPlace(InArray As Variant)
                      ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                      ' ShuffleArrayInPlace
                      ' This shuffles InArray to random order, randomized in place.
                      ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                          Dim N As Long
                          Dim Temp As Variant
                          Dim J As Long
                         
                          Randomize
                          For N = LBound(InArray) To UBound(InArray)
                              J = CLng(((UBound(InArray) - N) * Rnd) + N)
                              If N <> J Then
                                  Temp = InArray(N)
                                  InArray(N) = InArray(J)
                                  InArray(J) = Temp
                              End If
                          Next N
                      End Sub
                      
                      
                      Function HSBToRGB(hsb As HSBColor) As RGBColor
                      
                      
                          Dim h, s, b As Double
                               h = hsb.Hue
                               s = hsb.Saturation
                               b = hsb.Brightness
                               
                          Dim i As Long
                          Dim f, p, q, t As Double
                      
                      
                          If s = 0 Then
                                HSBToRGB.Red = 0
                                HSBToRGB.Green = 0
                                HSBToRGB.Blue = 0
                          End If
                          
                          h = h / 60
                          i = Int(h)
                          f = h - i
                          p = b * (1 - s)
                          q = b * (1 - s * f)
                          t = b * (1 - s * (1 - f))
                          
                          Select Case i
                              Case 0
                                  HSBToRGB.Red = b * 255
                                  HSBToRGB.Green = t * 255
                                  HSBToRGB.Blue = p * 255
                                  
                              Case 1
                                  HSBToRGB.Red = q * 255
                                  HSBToRGB.Green = b * 255
                                  HSBToRGB.Blue = p * 255
                                  
                              Case 2
                                  HSBToRGB.Red = p * 255
                                  HSBToRGB.Green = b * 255
                                  HSBToRGB.Blue = t * 255
                                  
                              Case 3
                                  HSBToRGB.Red = p * 255
                                  HSBToRGB.Green = q * 255
                                  HSBToRGB.Blue = b * 255
                                  
                              Case 4
                                  HSBToRGB.Red = t * 255
                                  HSBToRGB.Green = p * 255
                                  HSBToRGB.Blue = b * 255
                                  
                              Case 5
                                  HSBToRGB.Red = b * 255
                                  HSBToRGB.Green = p * 255
                                  HSBToRGB.Blue = q * 255
                                  
                          End Select
                                
                           
                      End Function
                      
                      
                      Sub main()
                          Dim swApp                                     As SldWorks.SldWorks
                          Dim swMainModel                               As SldWorks.ModelDoc2
                          Dim vComponents                               As Variant
                          Dim swAssy                                    As SldWorks.AssemblyDoc
                          Dim swComponent                               As SldWorks.Component2
                          Dim i                                         As Integer
                          Dim vMatProp                                  As Variant
                          Dim dict                                      As Dictionary
                          Dim h                                         As Double
                          Dim golden_ratio                              As Double
                          Dim newRGB                                    As RGBColor
                          Dim newHSB                                    As HSBColor
                          Dim vComponentsOrder()                        As Integer
                          Dim FastenerPath                              As String
                          Dim Path                                      As String
                          
                          FastenerPath = "C:\Fastener\Path\Here"
                          
                          golden_ratio = 0.618033988749895
                          
                          Set dict = CreateObject("Scripting.Dictionary")
                          Set swApp = Application.SldWorks
                          Set swMainModel = swApp.ActiveDoc
                          If swMainModel.GetType <> swDocASSEMBLY Then
                              MsgBox "Macro works only with assembly"
                              Exit Sub
                          End If
                          Set swAssy = swMainModel
                          vComponents = swAssy.GetComponents(False)
                          If IsEmpty(vComponents) Then
                              Exit Sub
                          End If
                          
                          Randomize 'Initializes new random number
                          h = Rnd
                          vMatProp = swMainModel.MaterialPropertyValues
                          
                          ReDim vComponentsOrder(UBound(vComponents))
                          
                          For i = 0 To UBound(vComponents)
                              vComponentsOrder(i) = i
                          Next i
                          
                          ShuffleArrayInPlace vComponentsOrder
                          
                          For i = 0 To UBound(vComponentsOrder)
                              'Debug.Print vComponentsOrder(i)
                              Set swComponent = vComponents(vComponentsOrder(i))
                              'Get all elements
                              
                              If UBound(swComponent.GetChildren) = -1 Then
                                  Path = Left(swComponent.GetPathName, InStrRev(swComponent.GetPathName, "\"))
                                  
                                  Debug.Print Path = FastenerPath
                                  
                                  If Path <> FastenerPath Then
                                      If dict.Exists(UCase(swComponent.GetPathName)) Then
                                          vMatProp = dict.Item(UCase(swComponent.GetPathName))
                                      Else
                                          h = h + golden_ratio
                                          h = FMod(h, 1)
                                          
                                          newHSB.Hue = h * 360
                                          newHSB.Brightness = 0.85
                                          newHSB.Saturation = 0.85
                                          
                                          newRGB = HSBToRGB(newHSB)
                                          
                                          'Debug.Print newRGB.Blue, newRGB.Green, newRGB.Blue
                                          
                                          vMatProp(0) = newRGB.Red                          'Red
                                          vMatProp(1) = newRGB.Green                          'Green
                                          vMatProp(2) = newRGB.Blue                          'Blue
                                          dict.Add UCase(swComponent.GetPathName), vMatProp
                                      End If
                                  swComponent.MaterialPropertyValues = vMatProp
                                  End If
                              End If
                          Next i
                          'Redraw to see new color
                          swMainModel.GraphicsRedraw2
                      End Sub
                      
                  • Re: GetComponents Unique List
                    Asa Eckert-Erdheim

                    Reviving this post as an unexpected issue has come up.

                     

                    Everything generally works fine with this macro and I can assign colors without a problem. However, if I add new parts to an old assembly and then re-run the macro, it only assigns appearances to new parts, not old. Does anyone have any ideas about why this would happen? It seems to still be iterating through and generating colors for all parts, but they're not sticking.