4 Replies Latest reply on Jun 21, 2018 9:59 PM by Salman Faiz

    Rename Cut-List Folder Macro

    Salman Faiz

      Hi All,

       

      I have started to write a macro to rename the Cut-List folder. The folder to be renamed by prefix defined as an Input followed by numbers 001,002 and so on..

      The code is below. At the moment, I cannot get this code to go through all the folders and does work only for the first folder. I was wondering if someone could help me on that.

       

      Sub main()

       

      Set swApp = Application.SldWorks

      Set Part = swApp.ActiveDoc

      Set SelMgr = Part.SelectionManager

      Part.ClearSelection2 True

      boolstatus = Part.Extension.SelectByID2("Cut-List-Item1", "SUBWELDFOLDER", 0, 0, 0, False, 0, Nothing, 0)

      Dim prefixName As String

      Dim foldercount As Integer

      foldercount = 1

      prefixName = InputBox("Enter a prefix for the cut-list folder names")

      SelMgr.GetSelectedObject5(1).Name = prefixName + IIf(foldercount < 10, "00" + CStr(foldercount), IIf(foldercount < 100, "0" + CStr(foldercount), CStr(foldercount)))

          foldercount = foldercount + 1

      End Sub

       

      Regards,

       

      Salman

        • Re: Rename Cut-List Folder Macro
          Fifi Riri

          Like this?

          part.jpg

          Option Explicit

          Dim SwApp As SldWorks.SldWorks

          Dim Part As SldWorks.ModelDoc2

          Dim swFeat As SldWorks.Feature

          Dim boolstatus As Long

          Dim foldercount As Integer

          Dim prefixName As String

           

          Sub Main()

              prefixName = InputBox("Enter a prefix for the cut-list folder names")

              foldercount = 0

              Set SwApp = CreateObject("SldWorks.Application")

              Set Part = SwApp.ActiveDoc

              If Part Is Nothing Then

                  MsgBox ("A part must be opened")

                  Exit Sub

              End If

              If Part.GetType <> 1 Then

                  MsgBox ("A part must be opened")

                  Exit Sub

              End If

              Set swFeat = Part.FirstFeature

              TraverseFeatures swFeat, True

              Part.ClearSelection2 (True)

          End Sub

           

          Sub TraverseFeatures(ByVal thisFeat As Feature, ByVal isTopLevel As Boolean)

              Dim curFeat As SldWorks.Feature

              Set curFeat = thisFeat

              While Not curFeat Is Nothing

                  If Not isTopLevel Then DoTheWork curFeat

                  Dim subfeat As SldWorks.Feature

                  Set subfeat = curFeat.GetFirstSubFeature

                  While Not subfeat Is Nothing

                      TraverseFeatures subfeat, False

                      Dim nextSubFeat As SldWorks.Feature

                      Set nextSubFeat = subfeat.GetNextSubFeature

                      Set subfeat = nextSubFeat

                      Set nextSubFeat = Nothing

                  Wend

                  Set subfeat = Nothing

                  Dim nextFeat As SldWorks.Feature

                  If isTopLevel Then

                      Set nextFeat = curFeat.GetNextFeature

                  Else

                      Set nextFeat = Nothing

                  End If

                  Set curFeat = nextFeat

                  Set nextFeat = Nothing

              Wend

          End Sub

           

          Sub DoTheWork(ByVal thisFeat As Feature)

              If thisFeat.GetTypeName = "CutListFolder" Then

                  If thisFeat.GetSpecificFeature2.GetBodyCount = 0 Then Exit Sub

                  foldercount = foldercount + 1

                  boolstatus = Part.Extension.SelectByID2(thisFeat.Name, "SUBWELDFOLDER", 0, 0, 0, False, 0, Nothing, 0)

                  Part.SelectionManager.GetSelectedObject5(1).Name = prefixName & IIf(foldercount < 10, "00" + CStr(foldercount), IIf(foldercount < 100, "0" + CStr(foldercount), CStr(foldercount)))

              End If

          End Sub

           

          => If your cut lists have a custom properties, you could replace DoTheWork function by something like:

           

          Sub DoTheWork(ByVal thisFeat As Feature)

              If thisFeat.GetTypeName = "CutListFolder" Then

                  If thisFeat.GetSpecificFeature2.GetBodyCount = 0 Then Exit Sub

                  foldercount = foldercount + 1

                  boolstatus = Part.Extension.SelectByID2(thisFeat.Name, "SUBWELDFOLDER", 0, 0, 0, False, 0, Nothing, 0)

                  Dim CustomProp As String

                  CustomProp = Part.SelectionManager.GetSelectedObject2(1).CustomPropertyManager.Get("PART NUMBER")

                  Part.SelectionManager.GetSelectedObject5(1).Name = prefixName & IIf(foldercount < 10, "00" + CStr(foldercount), IIf(foldercount < 100, "0" + CStr(foldercount), CStr(foldercount))) & " - " & CustomProp

              End If

          End Sub

          • Re: Rename Cut-List Folder Macro
            Andrzej Kurlapski

            Do you need something like below?

            Przechwytywanie.JPG

            If yes, you can change value of property "Description". This property is combine with name of elements in cut list. Here you have my code for this operation:

            Option Explicit

                Dim swApp               As SldWorks.SldWorks

                Dim swModel             As SldWorks.ModelDoc2

                Dim swFeat              As SldWorks.Feature

                Dim swCustPropMgr       As SldWorks.CustomPropertyManager

                Dim strValue0           As String

                Dim strValue1           As String

                Dim strValue2           As String

                Dim bool                As Boolean

                Dim Name                As String

                Dim z, x                As Integer

                Dim boolstatus          As Boolean

               

            Sub main()

               

                On Error Resume Next

                 

                Set swApp = Application.SldWorks

                Set swModel = swApp.ActiveDoc

                Name = swModel.GetPathName

                Name = Dir(Name)

                Name = Left(Name, Len(Name) - 7)

                If Right(Name, 2) = "00" Then

                Name = Left(Name, Len(Name) - 2)

                Else: Name = Name & "."

                End If

                Set swFeat = swModel.FirstFeature

                z = 1

                x = 0

                    Do While Not swFeat Is Nothing

                        If swFeat.GetTypeName() = "CutListFolder" Then

                            x = x + 1

                        End If

                    Set swFeat = swFeat.GetNextFeature

                    Loop

                Set swFeat = swModel.FirstFeature

                If x > 1 Then

                    Do While Not swFeat Is Nothing

                        If swFeat.GetTypeName() = "CutListFolder" Then

                       

                                Set swCustPropMgr = swFeat.CustomPropertyManager

                                    If z < 10 Then

                                    swCustPropMgr.Add3 "Description", 30, Name & "0" & z, 1

                                    ElseIf z >= 10 Then

                                    swCustPropMgr.Add3 "Description", 30, Name & z, 1

                                    End If

                 'for metalsheet                  

                                    If UCase(swFeat.Name) Like "*SHEET*" Then

                                    swCustPropMgr.Add3 "Description", 30, "Plate", 1

                                    End If                     

                                    z = z + 1

                        End If

                    Set swFeat = swFeat.GetNextFeature

                    Loop

                End If

            boolstatus = swModel.ForceRebuild3(True)

            End Sub