11 Replies Latest reply on Nov 30, 2012 1:00 AM by Keith Rice

    Traverse Tree in Order for Unique Components

    Eric Finan

      Hi All,

       

      I'm trying to write a macro to solve an issue that surely others have: print out all of the drawings related to an assembly in order.  I have spent quite some time looking around for a macro that can do this, but haven't had any success, so I decided to write one.  I am new to VBA, but I'm familiar with some other programming languages.

       

      I have two macros right now that each do half of what I ultimately want in the final macro:

      1. The first macro opens up all of the unique drawings related to the assembly (all parts/drawings are in the same directory), but doesn't print them in order shown in the tree.
      2. The second macro is able to identify the top level components in the tree in order and print the names to the immediate window, but prints all instances of each component.

       

      What I'm thinking is that I can use the logic from the second macro (opening components in order) and apply that to the first macro, which is opening and printing unique drawings related to the assembly.  Can anybody else provide some insight to solving this?  It would be greatly appreciated and I will certainly post the final working macro here, as I have had enormous help from others' posts.

       

      Macro One:


      Sub ShowAllOpenFiles()

       

      Dim swDoc As SldWorks.ModelDoc2

      Dim swAllDocs As EnumDocuments2

      Dim FirstDoc As SldWorks.ModelDoc2

      Dim dummy As Boolean

      Dim NumDocsReturned As Long

      Dim DocCount As Long

      Dim i As Long

      Dim sMsg As String

      Dim swApp As SldWorks.SldWorks

      Dim bDocWasVisible As Boolean

      Dim OpenWarnings As Long

      Dim OpenErrors As Long

      Dim DwgPath As String

      Dim myDwgDoc As SldWorks.ModelDoc2

      Dim swPageSetup As SldWorks.PageSetup

      Dim swDocName As String

      Dim swDwgName As String

      Dim CurrentDoc As SldWorks.ModelDoc2

      Dim CurrentDocQuit As SldWorks.ModelDoc2

       

       

      Set swApp = Application.SldWorks

      Set swAllDocs = swApp.EnumDocuments2

      Set FirstDoc = swApp.ActiveDoc

       

       

      DocCount = 0

      swAllDocs.Reset

      swAllDocs.Next 1, swDoc, NumDocsReturned

      While NumDocsReturned <> 0

          bDocWasVisible = swDoc.Visible

          swApp.ActivateDoc swDoc.GetPathName

          DwgPath = swDoc.GetPathName

          If (LCase(Right(DwgPath, 3)) <> "drw") And (DwgPath <> "") Then

              DwgPath = Left(DwgPath, Len(DwgPath) - 3) & "drw"

              Debug.Print "Drawing =  " & DwgPath

              Set myDwgDoc = swApp.OpenDoc6(DwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)

              If Not myDwgDoc Is Nothing Then 'If a drawing exists for this part, then:

                  swApp.ActivateDoc myDwgDoc.GetPathName

                  Set myDwgDoc = Nothing

                 

                  '--PRINT SECTION--

                  Set CurrentDoc = swApp.ActiveDoc

                  Set swPageSetup = CurrentDoc.PageSetup

                  swPageSetup.ScaleToFit = True 'Scale sheet to size

                  swPageSetup.PrinterPaperSize = 1 'Print on Ledger (3) size or Letter (1) size

                  CurrentDoc.PrintDirect 'Print to default printer

              End If

              '--CLOSE DOCUMENT--

              Set CurrentDocQuit = swApp.ActiveDoc

              swDwgName = CurrentDocQuit.GetTitle

              swApp.QuitDoc swDwgName 'Close drawing sheet

              swDocName = swDoc.GetTitle

              swApp.QuitDoc swDocName 'Close model

          End If

          swAllDocs.Next 1, swDoc, NumDocsReturned

          DocCount = DocCount + 1

      Wend

       

       

      End Sub

       

      Macro 2:


      'Written Feb 1, 09

      'This Traverse the Manager tree and prints the components

      'Out put is print to Immediate window of Folder names, Component names.

       

       

      Dim swApp As SldWorks.SldWorks

      Dim Part As SldWorks.ModelDoc2

      Dim SelMgr As SldWorks.SelectionMgr

       

       

      Sub main()

      Dim RootNode As SldWorks.TreeControlItem

      Set swApp = Application.SldWorks

      Set Part = swApp.ActiveDoc

      Set SelMgr = Part.SelectionManager

      Set FeatureMgr = Part.FeatureManager

      Set RootNode = FeatureMgr.GetFeatureTreeRootItem()

      Traverse_Nodes RootNode, 1

       

       

       

      End Sub

       

       

      Sub Traverse_Nodes(node As SldWorks.TreeControlItem, Level As Integer)

      Dim Childnode As SldWorks.TreeControlItem

      Dim Cnode As SldWorks.TreeControlItem

      Dim Feat As SldWorks.Feature

      Dim FeatTypeName As String

      Dim comp As SldWorks.Component2

      Dim CompDoc As SldWorks.ModelDoc2

      Dim Indent As String

      Indent = Space(Level * 4)

       

       

      Set Childnode = node.GetFirstChild

      If Childnode Is Nothing Then

          'An empty folder causes an empty node

          Debug.Print "      Empty Folder"

      End If

      While Not Childnode Is Nothing

          'If the node is a feature type is 1

          If Childnode.ObjectType = 1 Then

             

              Set Feat = Childnode.Object

              FeatTypeName = Feat.GetTypeName

              'If the feature is a folder with part in it or a pattern with parts in it

              If FeatTypeName = "FtrFolder" Or InStr(FeatTypeName, "Pattern") > 0 Then

              'Prints the name of the folder and goes through the components

              Debug.Print Childnode.Text

                  Traverse_Nodes Childnode, Level + 1

              End If

             

          'If the node is a component

          ElseIf Childnode.ObjectType = 2 Then

              Set comp = Childnode.Object

              Debug.Print Indent & comp.Name2

              Set Cnode = Childnode.GetFirstChild

           Set CompDoc = comp.GetModelDoc

              'This get parts and mates in subassemblies

              If Not CompDoc Is Nothing Then

                  If CompDoc.GetType = 2 Then

                      'This loops through subassemblies

                      'To get Sub Comps unremark next line.

                      'Traverse_Nodes Childnode, Level + 1  'XXXXXXXXXXXXXXXXXXXXXXXXX

                  End If

              End If

          Else

              Debug.Print Indent & "Not Sure of node type"

       

       

         End If

      NoSubs:

          Set Childnode = Childnode.GetNext

      Wend

      End Sub

       


        • Re: Traverse Tree in Order for Unique Components
          Roland Schwarz

          http://esoxrepublic.com/freeware/BlankDatums2.php

           

          Macro at link above traverses tree to find unique component/configuration usage.  Feel free to use what you can.

          • Re: Traverse Tree in Order for Unique Components
            Keith Rice

            Hi Eric,

             

            Welcome to the forums. If you are new to VBA or the SolidWorks API, I would recommend you check out the free SolidWorks API tutorials at my web site. They'll get you up to speed.

             

            Anyway, this macro I believe will accomplish what you need. Let me know.

             

            ========

             

            Dim swApp As SldWorks.SldWorks

            Dim swModel As SldWorks.ModelDoc2

            Dim swFeat As SldWorks.Feature

            Dim swComp As SldWorks.Component2

            Dim strstrDwgPath As String

            Dim swDrawToPrint As SldWorks.ModelDoc2

             

            Sub main()

                Set swApp = Application.SldWorks

                Set swModel = swApp.ActiveDoc

                Set swFeat = swModel.FirstFeature

                While Not swFeat Is Nothing

                    If swFeat.GetTypeName2 = "Reference" Then

                        Set swComp = swFeat.GetSpecificFeature2

                        If UCase(Right(swComp.GetPathName, 3)) = "ASM" Then

                            strDwgPath = Replace(UCase(swComp.GetPathName), "SLDASM", "SLDDRW")

                            Set swDrawToPrint = swApp.OpenDoc6(strDwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", Empty, Empty)

                            If Not swDrawToPrint Is Nothing Then

                                swApp.ActivateDoc swDrawToPrint.GetPathName

                                Set swPageSetup = swDrawToPrint.PageSetup

                                swPageSetup.ScaleToFit = True

                                swPageSetup.PrinterPaperSize = 1

                                CurrentDoc.PrintDirect

                            End If

                            swApp.QuitDoc swDrawToPrint.GetTitle

                        End If

                    End If

                    Set swFeat = swFeat.GetNextFeature

                Wend

            End Sub

             

            ========

             

            Keith

            Video Tutorials for the SolidWorks API

              • Re: Traverse Tree in Order for Unique Components
                Eric Finan

                Keith,

                 

                Thanks for your prompt and thorough response. Your macro is close to what I'm looking for--at least much closer than anything I've done.

                 

                I should have denoted this earlier, but I would like the macro to also print out the drawings associated with parts in any subassemblies in the assembly.  For example, I would like it to print out drawings for all of the following unique parts in order:

                 

                • MasterAssembly
                  • Subassembly1
                    • Part1
                    • Part2
                    • Part3
                  • Subassmbly2
                    • Part4
                    • Part5
                    • Part6
                  • Part7
                  • Part8

                 

                As of right now, your provided macro only opens the drawings associated with the top level components of the assembly.

                 

                Thank you for your gracious time and help--it is deeply appreciated.

                 

                Eric

                  • Re: Traverse Tree in Order for Unique Components
                    Eric Finan

                    Keith,

                     

                    Thanks again for your quick response.  By removing the lines per your suggestion, the macro still only traverses the top level components in the assembly.

                     

                    Eric

                      • Re: Traverse Tree in Order for Unique Components
                        Keith Rice

                        Try this:

                         

                        =====

                         

                        Dim swApp As SldWorks.SldWorks

                        Dim swModel As SldWorks.ModelDoc2

                        Dim swFeat As SldWorks.Feature

                        Dim swComp As SldWorks.Component2

                        Dim strstrDwgPath As String

                        Dim swDrawToPrint As SldWorks.ModelDoc2

                         

                        Sub main()

                            Set swApp = Application.SldWorks

                            Set swModel = swApp.ActiveDoc

                            Set swFeat = swModel.FirstFeature

                            While Not swFeat Is Nothing

                                If swFeat.GetTypeName2 = "Reference" Then

                                    Set swComp = swFeat.GetSpecificFeature2

                                    If UCase(Right(swComp.GetPathName, 3)) = "ASM" Then strDwgPath = Replace(UCase(swComp.GetPathName), "SLDASM", "SLDDRW")

                                    If UCase(Right(swComp.GetPathName, 3)) = "PRT" Then strDwgPath = Replace(UCase(swComp.GetPathName), "SLDASM", "SLDPRT")

                                    Set swDrawToPrint = swApp.OpenDoc6(strDwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", Empty, Empty)

                                    If Not swDrawToPrint Is Nothing Then

                                        swApp.ActivateDoc swDrawToPrint.GetPathName

                                        Set swPageSetup = swDrawToPrint.PageSetup

                                        swPageSetup.ScaleToFit = True

                                        swPageSetup.PrinterPaperSize = 1

                                        CurrentDoc.PrintDirect

                                    End If

                                    swApp.QuitDoc swDrawToPrint.GetTitle

                                End If

                                Set swFeat = swFeat.GetNextFeature

                            Wend

                        End Sub

                         

                        =====

                          • Re: Traverse Tree in Order for Unique Components
                            Eric Finan

                            I tried this same method earlier using slightly different syntax, but it still won't pull up the parts nested in the subassemblies. 

                             

                            Thanks again for your continued help with this. I know that it's possible, I have just had a difficult time accessing the tree in the correct order to get what I want.

                              • Re: Traverse Tree in Order for Unique Components
                                Keith Rice

                                Sorry, I should have noted that this macro only works at the top level. You will need to take the appropriate portions of my code and combine it with this API Help Example, which will traverse all levels.

                                  • Re: Traverse Tree in Order for Unique Components
                                    Eric Finan

                                    Keith,

                                     

                                    Thanks for your continued help.  I watched the "Taking Macros to the People" video on your website this morning--it was very good.  Thanks for that basic introduction.

                                     

                                    I now have the code as shown below, but keep getting Run-time error '91': Object variable or With block variable not set when my code runs the following line:

                                     

                                         Set swDrawToPrint = swApp.OpenDoc6(strDwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", Empty, Empty)

                                     

                                    Under the Sub TraverseComponent procedure.

                                     

                                    Could you perhaps provide any insight?  I keep thinking that I have declared everything that's necessary, but I just can't get it to work.

                                     

                                    =====

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

                                     

                                    Dim vChildComp                  As Variant

                                    Dim swChildComp                 As SldWorks.Component2

                                    Dim swSubFeat                   As SldWorks.Feature

                                    Dim sPadStr                     As String

                                    Dim i                           As Long

                                    Dim strDwgPath                  As String

                                    Dim swDrawToPrint               As SldWorks.ModelDoc2

                                    Dim swApp                       As SldWorks.SldWorks

                                       

                                       For i = 0 To nLevel - 1

                                            sPadStr = sPadStr + "  "

                                        Next i

                                       vChildComp = swComp.GetChildren

                                         For i = 0 To UBound(vChildComp)

                                            Set swChildComp = vChildComp(i)

                                            Set swSubFeat = swChildComp.FirstFeature

                                                While Not swSubFeat Is Nothing

                                                If swSubFeat.GetTypeName2 = "Reference" Then

                                                    Set swChildComp = swSubFeat.GetSpecificFeature2

                                                    If UCase(Right(swChildComp.GetPathName, 3)) = "ASM" Then _

                                                    strDwgPath = Replace(UCase(swChildComp.GetPathName), "SLDASM", "SLDDRW")

                                                    If UCase(Right(swChildComp.GetPathName, 3)) = "PRT" Then _

                                                    strDwgPath = Replace(UCase(swChildComp.GetPathName), "SLDPRT", "SLDDRW")

                                                    Set swDrawToPrint = swApp.OpenDoc6(strDwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", Empty, Empty)

                                                    If Not swDrawToPrint Is Nothing Then

                                                        swApp.ActivateDoc swDrawToPrint.GetPathName

                                                        Set swPageSetup = swDrawToPrint.PageSetup

                                                        swPageSetup.ScaleToFit = True

                                                        swPageSetup.PrinterPaperSize = 1

                                                        'swDrawToPrint.PrintDirect

                                                        Debug.Print strDwgPath

                                                    End If

                                                    swApp.QuitDoc swDrawToPrint.GetTitle

                                                   

                                                    End If

                                                    Set swSubFeat = swSubFeat.GetNextFeature

                                                Wend

                                     

                                            TraverseComponent swChildComp, nLevel + 1

                                         Next i

                                    End Sub

                                     

                                     

                                    Sub main()

                                     

                                    Dim swApp                       As SldWorks.SldWorks

                                    Dim swModel                     As SldWorks.ModelDoc2

                                    Dim swFeat                      As SldWorks.Feature

                                    Dim swComp                      As SldWorks.Component2

                                    Dim strDwgPath                  As String

                                    Dim swDrawToPrint               As SldWorks.ModelDoc2

                                    Dim swRootComp                  As SldWorks.Component2

                                    Dim swConfMgr                   As SldWorks.ConfigurationManager

                                    Dim swConf                      As SldWorks.Configuration

                                       

                                        Set swApp = Application.SldWorks

                                        Set swModel = swApp.ActiveDoc

                                        Set swFeat = swModel.FirstFeature

                                        Set swConfMgr = swModel.ConfigurationManager

                                        Set swConf = swConfMgr.ActiveConfiguration

                                        Set swRootComp = swConf.GetRootComponent3(True)

                                        While Not swFeat Is Nothing

                                            If swFeat.GetTypeName2 = "Reference" Then

                                                Set swComp = swFeat.GetSpecificFeature2

                                                If UCase(Right(swComp.GetPathName, 3)) = "ASM" Then _

                                                strDwgPath = Replace(UCase(swComp.GetPathName), "SLDASM", "SLDDRW")

                                                If UCase(Right(swComp.GetPathName, 3)) = "PRT" Then _

                                                strDwgPath = Replace(UCase(swComp.GetPathName), "SLDPRT", "SLDDRW")

                                                Set swDrawToPrint = swApp.OpenDoc6(strDwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", Empty, Empty)

                                                If Not swDrawToPrint Is Nothing Then

                                                    swApp.ActivateDoc swDrawToPrint.GetPathName

                                                    Set swPageSetup = swDrawToPrint.PageSetup

                                                    swPageSetup.ScaleToFit = True

                                                    swPageSetup.PrinterPaperSize = 1

                                                    'swDrawToPrint.PrintDirect

                                                    Debug.Print strDwgPath

                                                End If

                                                swApp.QuitDoc swDrawToPrint.GetTitle

                                               

                                                'Divert to TraverseComponent if component is assembly

                                                If swModel.GetType = SwConst.swDocASSEMBLY Then

                                                    TraverseComponent swRootComp, 1

                                                End If

                                           

                                            End If

                                            Set swFeat = swFeat.GetNextFeature

                                        Wend

                                    End Sub

                                     

                                    =====

                                    • Re: Traverse Tree in Order for Unique Components
                                      Eric Finan

                                      Ignore my post above.....I overlooked having the following line in my code:

                                       

                                           Set swApp = Application.SldWorks

                                       

                                      Anyway, getting close to having this macro working.  Thanks for your help so far and I will post the final code for anyone else looking to automate the same process.

                                    • Re: Traverse Tree in Order for Unique Components
                                      Bnaya Livne

                                      Hey Eric,

                                       

                                      In order to traverse the sub-assemblies you will have to get the ModelDoc2 from the assembly component (using IComponent2::GetModelDoc2) and then you can traverse this modeldoc2 object as you did to your main assembly.

                                      I think that you will have to a recursion function that called for ModelDoc2 or Root components.

                                       

                                      Check out this nice example from SolidWorks API help:

                                      http://help.solidworks.com/2012/English/api/sldworksapi/traverse_assembly_at_component_and_feature_levels_using_recursion_example_vb.htm

                                       

                                      Cheers,

                                      Bnaya