11 Replies Latest reply on Sep 7, 2018 11:33 AM by Deepak Gupta

    Macro for converting splines to 3pt arcs

    John Christensen

      I've put together a macro for converting a spline to 3pt arcs.  Either a spline edge, or a sketched spline is picked, reference points are created along the spline, and 3pt arcs are created along the spline in the form of a new sketch.  The problem I'm having is that the reference points seem accurate (are placed along the spline with appropriate spacings etc), and their locations can be verified, yet the points used to create the 3pt arcs are not accurate.  Some kind of issue is creating either a rounding or conversion error, or something else I'm not aware of. What could be causing the locations errors.

      Clipboard02.jpg

        • Re: Macro for converting splines to 3pt arcs
          John Christensen

          'ReArc splines with 3ptArcs
          'Version 3
          '   -added check for closed curve, open curve
          '   -added sketch transformation from model space to sketch space
          '   -added move reference points to seperate folder
          '   -added hide reference points after created
          '
          ' Preconditions:
          '         1)Exit sketchs before using macro
          '         2)Sketch spline is selected
          '         3)Sketch plane is either oriented with default front, right, top, or parrallel to these
          '
          ' Postconditions:
          '         1) New sketch is created with 3pt arcs overlaid on spline
          '         2) Original sketch spline now construction geometry
          '
          '--------------------------------------------------

          Option Explicit
          Type DoubleRec
              dValue As Double
          End Type
          Type Long2Rec
              iLower As Long
              iUpper As Long
          End Type
          ' Extract two integer values from a single double value
          ' by assigning a DoubleRec to the double value,
          ' copying the value to a Long2Rec, and
          ' extracting the integer values
          Function ExtractFields( _
              ByVal dValue As Double, _
              iLower As Long, _
              iUpper As Long _
          )
              Dim dr                          As DoubleRec
              Dim i2r                         As Long2Rec
              ' Set the double value
              dr.dValue = dValue
              ' Copy the values
              LSet i2r = dr
              ' Extract the values
              iLower = i2r.iLower
              iUpper = i2r.iUpper
          End Function

          '------------
          '---Add 3pt arcs
          '
          Sub Add3PtArcs( _
              startpt As Variant, _
              endpt As Variant, _
              PtArray2 As Variant, _
              NumofPoints As Integer, _
              bIsClosed As Boolean _
          )
             
          Dim swApp       As SldWorks.SldWorks
          Dim Part        As SldWorks.modelDoc2
          Dim skSegment   As SldWorks.SketchSegment
          Dim boolstatus  As Boolean
          Dim I           As Integer

              Set swApp = Application.SldWorks
              Set Part = swApp.ActiveDoc
              Part.SketchManager.AddToDB = True
              Set skSegment = Part.SketchManager.Create3PointArc _
                  (startpt(0), startpt(1), 0#, _
                  PtArray2(2, 0), PtArray2(2, 1), 0#, _
                  PtArray2(1, 0), PtArray2(1, 1), 0#)
                 
              'modify end segment for closed loop condition
              If bIsClosed = False Then               'loop is open
                  Set skSegment = Part.SketchManager.Create3PointArc _
                      (endpt(0), endpt(1), 0#, _
                      PtArray2(NumofPoints - 1, 0), PtArray2(NumofPoints - 1, 1), 0#, _
                      PtArray2(NumofPoints, 0), PtArray2(NumofPoints, 1), 0#)
              Else                                    'loop is closed
                  Set skSegment = Part.SketchManager.Create3PointArc _
                      (endpt(0), endpt(1), 0#, _
                      PtArray2(NumofPoints - 2, 0), PtArray2(NumofPoints - 2, 1), 0#, _
                      PtArray2(NumofPoints - 1, 0), PtArray2(NumofPoints - 1, 1), 0#)
              End If
                     
              If NumofPoints < 4 Then
                  'Debug.Print "2 loops only"
              Else
                  For I = 2 To (NumofPoints - 3) Step 2
                      Set skSegment = Part.SketchManager.Create3PointArc _
                         (PtArray2(I, 0), PtArray2(I, 1), 0#, _
                         PtArray2(I + 2, 0), PtArray2(I + 2, 1), 0#, _
                         PtArray2(I + 1, 0), PtArray2(I + 1, 1), 0#)
                  Part.ClearSelection2 True
                  Next
              End If
             
              Part.ClearSelection2 True
              Part.SketchManager.InsertSketch True
              Part.SketchManager.AddToDB = False

          End Sub

          Sub main()
              Dim swApp                       As SldWorks.SldWorks
              Dim swModel                     As SldWorks.modelDoc2
              Dim swSelMgr                    As SldWorks.SelectionMgr
              Dim swSketchSeg                 As SldWorks.SketchSegment
              Dim swCurve                     As SldWorks.Curve
              Dim nStartParam                 As Double
              Dim nEndParam                   As Double
              Dim bIsClosed                   As Boolean
              Dim bIsPeriodic                 As Boolean
              Dim vStart                      As Variant
              Dim vEnd                        As Variant
              Dim nDummy                      As Long
              Dim nStartSuccess               As Long
              Dim nEndSuccess                 As Long
              Dim I                           As Long
              Dim bRet                        As Boolean
              Dim swFeatMgr                   As SldWorks.FeatureManager
              Dim vFeatArr                    As Variant
              Dim vFeat                       As Variant
              Dim swFeat                      As SldWorks.Feature
              Dim swRefPt                     As SldWorks.RefPoint
              Dim swRefPtData                 As SldWorks.RefPointFeatureData
              Dim swMathPt                    As SldWorks.MathPoint
              Dim nStatus                     As Long
              Dim swSketch                    As SldWorks.Sketch
              Dim swMathUtil                  As SldWorks.MathUtility
              Dim swXform                     As SldWorks.MathTransform
              Dim swTransPt                   As SldWorks.MathPoint
              Dim nRefPt(2)                   As Double
              Dim vRefPt                      As Variant

              Set swApp = Application.SldWorks
              Set swModel = swApp.ActiveDoc
              Set swSelMgr = swModel.SelectionManager
              Set swFeatMgr = swModel.FeatureManager
              Set swSketchSeg = swSelMgr.GetSelectedObject5(1)
              Set swCurve = swSketchSeg.GetCurve
              Set swSketch = swSketchSeg.GetSketch
             
              swSketchSeg.ConstructionGeometry = True
              bRet = swCurve.GetEndParams(nStartParam, nEndParam, bIsClosed, bIsPeriodic)
              Debug.Assert bRet
              vStart = swCurve.Evaluate(nStartParam)
              vEnd = swCurve.Evaluate(nEndParam)
              ExtractFields vStart(6), nStartSuccess, nDummy
              ExtractFields vEnd(6), nEndSuccess, nDummy
              Debug.Assert nStartSuccess
              Debug.Assert nEndSuccess
             
              'determine length, number of points to add, and start and end points
              Dim length As Double
              length = swCurve.GetLength2(nStartParam, nEndParam) * 1000 / 25.4
              Dim NumofPoints As Integer
             
              'determine number of points and bump if even
              NumofPoints = length * 16
              Dim valueiseven As Boolean
              valueiseven = NumofPoints Mod 2
                  If bIsClosed = False Then   'check for open curve
                     If valueiseven = False Then
                          NumofPoints = NumofPoints + 1
                     End If
                  Else                        'curve is closed
                      If valueiseven = True Then
                          NumofPoints = NumofPoints + 1
                     End If
                  End If
             
              'add reference points evenly distributed
              vFeatArr = swFeatMgr.InsertReferencePoint(swRefPointAlongCurve, swRefPointAlongCurveEvenlyDistributed, 0#, NumofPoints)
             
              'Create folder to insert points
              Dim swFolder As SldWorks.Feature
              Set swFolder = swModel.FeatureManager.InsertFeatureTreeFolder2(swFeatureTreeFolderType_e.swFeatureTreeFolder_EmptyBefore)
              swFolder.Name = "RefPts"
             
             
              'create array for storing ref points
              Dim PtArray2(1000, 3) As Variant
              Dim X As Double
              X = 1
              For Each vFeat In vFeatArr
                  Set swFeat = vFeat
                  Set swRefPt = swFeat.GetSpecificFeature2
                 
                  Set swMathPt = swRefPt.GetRefPoint
                  PtArray2(X, 0) = swMathPt.ArrayData(0)
                  PtArray2(X, 1) = swMathPt.ArrayData(1)
                  PtArray2(X, 2) = swMathPt.ArrayData(2)
                  'Debug.Print PtArray2(X, 0) * 1000 / 25.4; ","; PtArray2(X, 1) * 1000 / 25.4; "," & PtArray2(X, 2) * 1000 / 25.4
                     
                      nRefPt(0) = swMathPt.ArrayData(0)
                      nRefPt(1) = swMathPt.ArrayData(1)
                      nRefPt(2) = swMathPt.ArrayData(2)
                      vRefPt = nRefPt
                      Set swMathUtil = swApp.GetMathUtility
                      Set swXform = swSketch.ModelToSketchTransform
                      'Set swXform = swXform.Inverse
                      Set swTransPt = swMathUtil.CreatePoint(vRefPt)
                      Set swTransPt = swTransPt.MultiplyTransform(swXform)
                     
                  PtArray2(X, 0) = swTransPt.ArrayData(0)
                  PtArray2(X, 1) = swTransPt.ArrayData(1)
                  PtArray2(X, 2) = swTransPt.ArrayData(2)
                  X = X + 1
                 
                  'move each ref point to folder "RefPts"
                  Dim modelDoc2 As SldWorks.modelDoc2
                  Dim modelDocExt As SldWorks.ModelDocExtension
                  Set modelDoc2 = swApp.ActiveDoc
                  Set modelDocExt = modelDoc2.Extension
                  bRet = modelDocExt.ReorderFeature(swFeat.Name, "RefPts", swMoveToFolder)
                  bRet = swFeat.Select2(False, 0): Debug.Assert bRet
                  swModel.BlankRefGeom
                  bRet = swFeat.Select2(True, 0): Debug.Assert bRet
              Next
             
              'create reference plane coincident with spline
              Dim myRefPlane As Feature
              swSketchSeg.Select4 True, Nothing
              swSelMgr.SetSelectedObjectMark 2, 1, swSelectionMarkAction_e.swSelectionMarkSet
              Set myRefPlane = swModel.FeatureManager.InsertRefPlane(0, 0, swRefPlaneReferenceConstraints_e.swRefPlaneReferenceConstraint_Coincident, 0, 0, 0)
              myRefPlane.Name = "Plane1"
             
              'pick ref plane to sketch on
              swModel.ClearSelection2 True
              swModel.Extension.SelectByID2 myRefPlane.Name, "PLANE", 0, 0, 0, False, 0, Nothing, 0
             
               'send points array to 3ptarc sub
              Add3PtArcs vStart, vEnd, PtArray2, NumofPoints, bIsClosed
             
          End Sub

            • Re: Macro for converting splines to 3pt arcs
              Feroz Mahomed

              John,

               

              I have 2 further questions:

              a) How do I reduce the number of points? I wish to have larger and fewer radii.

              b) Can you add code so that all the points in the feature tree are added to a new folder called " Points". This would shorten the feature tree.

               

              Thank you

                • Re: Macro for converting splines to 3pt arcs
                  John Christensen

                  This is the code determining number of points:

                   

                  'determine number of points and bump if even

                      NumofPoints = length * 16

                      Dim valueiseven As Boolean

                      valueiseven = NumofPoints Mod 2

                    

                   

                  “Length *16” would give 16pts per inch.  Change 16 to 8
                  would be 8pts per inch.

                   

                  • Re: Macro for converting splines to 3pt arcs
                    John Christensen

                    Can you add code so that all the points in the feature tree are added to a new folder called " Points". This would shorten the feature tree.

                     

                    The following changes will create a folder called "Points", and move newly created reference points to that folder:

                     

                    Existing code

                        'add reference points evenly distributed

                        vFeatArr = swFeatMgr.InsertReferencePoint(swRefPointAlongCurve, swRefPointAlongCurveEvenlyDistributed, 0#, NumofPoints)

                    Added code   

                        'Create folder to insert points

                        Dim swFolder As SldWorks.Feature

                        Set swFolder = swModel.FeatureManager.InsertFeatureTreeFolder2(swFeatureTreeFolderType_e.swFeatureTreeFolder_EmptyBefore)

                        swFolder.Name = "Points"

                     

                    Existing code

                            Set swTransPt = swTransPt.MultiplyTransform(swXform)    

                            PtArray2(X, 0) = swTransPt.ArrayData(0)

                            PtArray2(X, 1) = swTransPt.ArrayData(1)

                            PtArray2(X, 2) = swTransPt.ArrayData(2)

                            X = X + 1

                     

                     

                    Added code       

                            'move each ref point to folder "Points"

                            Dim modelDoc2 As SldWorks.modelDoc2

                            Dim modelDocExt As SldWorks.ModelDocExtension

                            Set modelDoc2 = swApp.ActiveDoc

                            Set modelDocExt = modelDoc2.Extension

                            bRet = modelDocExt.ReorderFeature(swFeat.Name, "Points", swMoveToFolder)

                      • Re: Macro for converting splines to 3pt arcs
                        Feroz Mahomed

                        John,

                         

                        The macro works well now. What code can be added to Hide all the points in the folder called " Points" ?

                         

                        Thank you for all the help.

                          • Re: Macro for converting splines to 3pt arcs
                            John Christensen

                            What code can be added to Hide all the points in the folder called " Points" ?

                             

                            Added code       

                                    'move each ref point to folder "Points"

                                    Dim modelDoc2 As SldWorks.modelDoc2

                                    Dim modelDocExt As SldWorks.ModelDocExtension

                                    Set modelDoc2 = swApp.ActiveDoc

                                    Set modelDocExt = modelDoc2.Extension

                                    bRet = modelDocExt.ReorderFeature(swFeat.Name, "Points", swMoveToFolder)

                               

                                    'hide each ref point

                                    bRet = swFeat.Select2(False, 0): Debug.Assert bRet

                                    swModel.BlankRefGeom

                                    bRet = swFeat.Select2(True, 0): Debug.Assert bRet

                    • Re: Macro for converting splines to 3pt arcs
                      Wayne Schafer

                      I tried running this macro on the below part and I got the following message. Any suggestions would be helpful.

                       

                      Capture1.JPG

                       

                      Capture.JPG