7 Replies Latest reply on Jan 23, 2017 7:47 PM by John Bamber

    How to rename pasted sketch (VBA)?

    John Bamber

      I need to paste a sketch which has specifically named attributes on multiple planes.  I would like to rename each pasted sketch instance as it is created, but haven't found a way to select the sketch just pasted, since the sequential sketch names can vary in various models.  Please help!

       

      I've attached a SW macro that I wish would work.  It would if the sketch were still selected after the paste operation, but it isn't.

        • Re: How to rename pasted sketch (VBA)?
          Raghvendra Bhargava

          Hi John,

          I have modified some code part. Look at the attachment.

          Cheers

            • Re: How to rename pasted sketch (VBA)?
              John Bamber

              Hi,

              Thanks for looking into this, but unfortunately, the modified code only renames the existing sketch.  I don't want that - here is an example scenario:

              • I have a sketch named "NS_2". 
              • I have planes named "S_2", "S_4", "S_6",.....to "S_30".
              • I want to paste copies of the "NS_2" sketch on each of of the "S_x" planes, then rename each resulting sketch "NS_x" (with x corresponding to the suffix of the plane name).

              Thanks for helping!

            • Re: How to rename pasted sketch (VBA)?
              John Bamber

              I realized the code I posted with my original question was incorrect.  Here is the code I would like to work:

                • Re: How to rename pasted sketch (VBA)?
                  Raghvendra Bhargava

                  This Code is the same as Last one. Could you attach the latest code..

                    • Re: How to rename pasted sketch (VBA)?
                      John Bamber

                      Oops.  I changed the file, but not the name, so the previously zipped file was probably uploaded. Here is the text:

                      Option Explicit

                      Dim swApp As Object

                      Dim Part As Object

                      Dim boolstatus As Boolean

                      Dim longstatus As Long, longwarnings As Long

                      Dim sketchName As String

                      Dim swFeat As SldWorks.Feature

                      Dim swSketch As SldWorks.Sketch

                       

                      Sub main()

                       

                      Set swApp = _

                      Application.SldWorks

                      sketchName = "NS_4"

                      Set Part = swApp.ActiveDoc

                      boolstatus = Part.Extension.SelectByID2("NS_2", "SKETCH", 0, 0, 0, False, 0, Nothing, 0) '<<<the sketchname changed in this line.

                      Part.EditCopy

                      boolstatus = Part.Extension.SelectByID2("Plane4", "PLANE", 0, 0, 0, False, 0, Nothing, 0)

                      Part.Paste

                       

                      'macro runs fine without the following 3 lines

                      Set swSketch = Part.GetActiveSketch2

                      Set swFeat = swSketch

                      swFeat.Name = sketchName

                       

                      Part.ClearSelection2 True

                      End Sub

                       

                      Also note this code doesn't contain the desired looping - I consider that part of the problem trivial, and am only using the code above to create the desired results of one iteration of the eventual loop.

                        • Re: How to rename pasted sketch (VBA)?
                          Raghvendra Bhargava

                          I think What I am Getting the problem is we are not able to get the object of Sketch after Copy Paste.

                          I got the solution, You need to do debug the code to understand. As in Short, I am taking all 2D sketch name before and after Copy paste and then Getting the newly copied Sketch Feature.

                          Just open your part and hit the code. You have to change the Name String

                          Let me know if you have any query ..

                           

                          Dim swApp As Object

                          Dim Part As ModelDoc2

                          Dim boolstatus As Boolean

                          Dim longstatus As Long, longwarnings As Long

                          Dim Cnt As Integer

                           

                          Sub main()

                          Set swApp = Application.SldWorks

                          Set Part = swApp.ActiveDoc

                           

                          Dim FeatCnt1 As Integer

                          FeatCnt1 = Part.FeatureManager.GetFeatureCount(True)

                           

                          Dim FeatArr1 As Variant

                          FeatArr1 = Part.FeatureManager.GetFeatures(True)

                           

                          Dim FeatNmeArr1() As String

                          Dim ArrSize1 As Integer

                          ArrSize1 = 0

                          For Cnt = 1 To FeatCnt1 - 1

                              Dim Feat1 As Feature

                              Set Feat1 = FeatArr1(Cnt)

                              If Feat1.GetTypeName = "ProfileFeature" Then '>>>Checking only For 2D Sketch Type

                                  ArrSize1 = ArrSize1 + 1

                                  ReDim Preserve FeatNmeArr1(1 To ArrSize1)

                                  FeatNmeArr1(ArrSize1) = Feat1.Name '>>>Getting all Top Level ONLY 2D Sketch Name before Copy Paste.

                              End If

                          Next Cnt

                           

                          'Doing Copy Paste--------

                          boolstatus = Part.Extension.SelectByID2("NS_2", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)

                          Dim swFeat1 As Feature

                          Set swFeat1 = Part.SelectionManager.GetSelectedObject6(1, -1)

                          Dim SkecthNme As String

                          SkecthNme = swFeat1.Name

                          Part.EditCopy

                           

                          boolstatus = Part.Extension.SelectByID2("S_4", "PLANE", 0, 0, 0, False, 0, Nothing, 0)

                          Dim swFeat2 As Feature

                          Set swFeat2 = Part.SelectionManager.GetSelectedObject6(1, -1)

                          Dim PlaneNme As String

                          PlaneNme = swFeat2.Name

                          Part.Paste

                           

                          Part.ClearSelection2 True

                          '------------------------------------

                           

                          Dim FeatCnt2 As Integer

                          FeatCnt2 = Part.FeatureManager.GetFeatureCount(True)

                           

                          Dim FeatNmeArr2() As String

                           

                          If FeatCnt2 = FeatCnt1 + 1 Then

                              Dim FeatArr2 As Variant

                              FeatArr2 = Part.FeatureManager.GetFeatures(True)

                            

                              Dim ArrSize2 As Integer

                              ArrSize2 = 0

                              For Cnt = 1 To FeatCnt2 - 1

                                  Dim Feat2 As Feature

                                  Set Feat2 = FeatArr2(Cnt)

                                  If Feat2.GetTypeName = "ProfileFeature" Then

                                      ArrSize2 = ArrSize2 + 1

                                      ReDim Preserve FeatNmeArr2(1 To ArrSize2)

                                      FeatNmeArr2(ArrSize2) = Feat2.Name 'Getting all Top Level ONLY 2D Sketch Name After Copy Paste.

                                  End If

                              Next Cnt

                            

                              ReDim Preserve FeatNmeArr1(1 To UBound(FeatNmeArr2))

                              Dim FeatCnt As Integer

                              Dim AllSketchCnt As Integer

                              AllSketchCnt = 0

                              For Cnt = 1 To UBound(FeatNmeArr2)

                                  For FeatCnt = 1 To UBound(FeatNmeArr2)

                                

                                  If FeatNmeArr2(Cnt) <> FeatNmeArr1(FeatCnt) Then AllSketchCnt = AllSketchCnt + 1

                                

                                      If AllSketchCnt = UBound(FeatNmeArr2) Then

                                          Dim PasteSkh As Feature

                                          Dim Model As PartDoc

                                          Set Model = Part

                                          Set PasteSkh = Model.FeatureByName(FeatNmeArr2(Cnt))

                                          PasteSkh.Name = Left(SkecthNme, 3) + Right(PlaneNme, 1) 'Changing Name Of New Pasted Sketch.

                                      End If

                                    

                                  Next FeatCnt

                                  AllSketchCnt = 0

                              Next Cnt

                            

                          End If

                          End Sub