2 Replies Latest reply on Jun 30, 2017 2:18 AM by Andreas Killer

    IntersectCurve in VBA

    Andreas Killer

      I can't get IntersectCurve to work in VBA... which might be due to my sketch items...

       

      I've found some threads in here with a similar subject, but the OP use VB.NET, C# or 3DSketch... but I have a simple 2D sketch.

       

      The code below assumes an active sketch, creates a spline and a line, which are obvious intersect. But curious:

      If I call IntersectCurve to find the intersection from swCurveA to swCurveB i get a RTE -2147417848
      The opposite call works, but did not return any points...

       

      Can please someone with some experience look at the code below and give me a hint?

       

      Andreas.

       

      Option Explicit

       

      Sub Main()
        Dim swApp As SldWorks.SldWorks
        Dim swModel As SldWorks.ModelDoc2
        Dim swSketchMgr As SldWorks.SketchManager

       

        Set swApp = Application.SldWorks
        Set swModel = swApp.ActiveDoc
        Set swSketchMgr = swModel.SketchManager

       

        Dim pointArray As Variant
        Dim Points() As Double
        ReDim Points(0 To 14) As Double
        Points(0) = 0.03
        Points(1) = 0
        Points(2) = 0
        Points(3) = 0
        Points(4) = 0.04
        Points(5) = 0
        Points(6) = 0.03
        Points(7) = 0.08
        Points(8) = 0
        Points(9) = 0.06
        Points(10) = 0.04
        Points(11) = 0
        Points(12) = 0.03
        Points(13) = 0
        Points(14) = 0
        pointArray = Points

       

        Dim Astart() As Variant, Aend() As Variant, Bstart() As Variant, Bend() As Variant
        'Did not work either:
        'Dim Astart() As Double, Aend() As Double, Bstart() As Double, Bend() As Double
       
        Dim swSketchSegA As SldWorks.SketchSegment
        Dim swCurveA As SldWorks.Curve
        Set swSketchSegA = swSketchMgr.CreateSpline(pointArray)
        Set swCurveA = swSketchSegA.GetCurve
        If Not GetStartEndPoint(swSketchSegA, Astart, Aend) Then Exit Sub

       

        Dim swSketchSegB As SldWorks.SketchSegment
        Dim swCurveB As SldWorks.Curve
        Set swSketchSegB = swSketchMgr.CreateLine(0.03, 0.04, 0#, -0.045, 0.08, 0#)
        Set swCurveB = swSketchSegB.GetCurve
        If Not GetStartEndPoint(swSketchSegB, Bstart, Bend) Then Exit Sub

       

        On Error GoTo ErrorHandler
        'Creates a RTE:
        pointArray = swCurveA.IntersectCurve(swCurveB, Astart, Aend, Bstart, Bend)
        'Works, but not points returned:
        pointArray = swCurveB.IntersectCurve(swCurveA, Bstart, Bend, Astart, Aend)

       

        If IsNull(pointArray) Then
          Debug.Print "No intersection"
        Else
          Debug.Print "Points:"
          Debug.Print Join(pointArray)
        End If

       

        Exit Sub
      ErrorHandler:
        Debug.Print Err.Number, Err.Description
        Resume Next
      End Sub

       

      Function GetStartEndPoint(ByRef swSegment As Object, ByRef StartPoint, ByRef EndPoint) As Boolean
        'Based on https://forum.solidworks.com/message/393341
        Dim swSkPoint1 As SketchPoint
        Dim swSkPoint2 As SketchPoint

       

        If TypeOf swSegment Is SketchSegment Then

       

          Select Case swSegment.GetType
            Case swSketchSegments_e.swSketchLINE
              Dim swSkLine As SketchLine
              Set swSkLine = swSegment
              Set swSkPoint1 = swSkLine.GetStartPoint2()
              Set swSkPoint2 = swSkLine.GetEndPoint2()
            Case swSketchSegments_e.swSketchARC
              Dim swSkArc As SketchArc
              Set swSkArc = swSegment
              Set swSkPoint1 = swSkArc.GetStartPoint2()
              Set swSkPoint2 = swSkArc.GetEndPoint2()
            Case swSketchSegments_e.swSketchSPLINE

       

              Dim swSkSpline As SketchSpline
              Set swSkSpline = swSegment
              Dim swSkPoints
              swSkPoints = swSkSpline.GetPoints2
              Set swSkPoint1 = swSkPoints(0)
              Set swSkPoint2 = swSkPoints(UBound(swSkPoints))
            Case swSketchSegments_e.swSketchELLIPSE
              Dim swSkEllipse As SketchEllipse
              Set swSkEllipse = swSegment
              Set swSkPoint1 = swSkEllipse.GetStartPoint2()
              Set swSkPoint2 = swSkEllipse.GetEndPoint2()
            Case swSketchSegments_e.swSketchPARABOLA
              Dim swParabola As SketchParabola
              Set swParabola = swSegment
              Set swSkPoint1 = swParabola.GetStartPoint2()
              Set swSkPoint2 = swParabola.GetEndPoint2()
            Case Else
              Exit Function
          End Select
          ReDim StartPoint(0 To 2)
          StartPoint(0) = swSkPoint1.X
          StartPoint(1) = swSkPoint1.Y
          StartPoint(2) = swSkPoint1.Z
          ReDim EndPoint(0 To 2)
          EndPoint(0) = swSkPoint2.X
          EndPoint(1) = swSkPoint2.Y
          EndPoint(2) = swSkPoint2.Z
        ElseIf TypeOf swSegment Is Edge Then
          Dim swEdge As Edge
          Set swEdge = swSegment
          Dim swCurveParamData As CurveParamData
          swCurveParamData = swEdge.GetCurveParams3
          StartPoint = swCurveParamData.StartPoint
          EndPoint = swCurveParamData.EndPoint
        Else
          Exit Function
        End If
        GetStartEndPoint = True

       

        Debug.Print "Start ", StartPoint(0), StartPoint(1), StartPoint(2)
        Debug.Print "End   ", EndPoint(0), EndPoint(1), EndPoint(2)
      End Function

        • Re: IntersectCurve in VBA
          Andreas Killer

          Short update: The VBA code works, the issue is the closed spline!

           

          For developing purposes I've changed the Main sub a little and now I can select 2 sketch items and the code works and returns the intersection points.

           

          But curious, the documentation says the "k" element in the returned array is the curve intersection type... but I get always 1.1 as value, even if I choose tangent circles as input.

           

          Now I have 2 questions:

          How do I get the intersection with a closed spline?
          How do I get the correct "k" argument of the intersection type?

           

          Andreas.

           

           

          Option Explicit

           

          #Const Develop = True

           

          Sub Main()
            Dim swApp As SldWorks.SldWorks
            Dim swModel As SldWorks.ModelDoc2
            Dim swSketchMgr As SldWorks.SketchManager

           

            Set swApp = Application.SldWorks
            Set swModel = swApp.ActiveDoc
            Set swSketchMgr = swModel.SketchManager
          #If Develop Then
            Dim swSelMgr As SldWorks.SelectionMgr
            Set swSelMgr = swModel.SelectionManager
          #End If

           

            Dim pointArray As Variant
            Dim Points() As Double
            ReDim Points(0 To 14) As Double
            Points(0) = 0.03
            Points(1) = 0
            Points(2) = 0
            Points(3) = 0
            Points(4) = 0.04
            Points(5) = 0
            Points(6) = 0.03
            Points(7) = 0.08
            Points(8) = 0
            Points(9) = 0.06
            Points(10) = 0.04
            Points(11) = 0
            Points(12) = 0.03
            Points(13) = 0
            Points(14) = 0
            pointArray = Points

           

            Dim Astart() As Variant, Aend() As Variant, Bstart() As Variant, Bend() As Variant
           
            Dim swSketchSegA As SldWorks.SketchSegment
            Dim swCurveA As SldWorks.Curve
          #If Develop Then
            If swSelMgr.GetSelectedObjectCount2(-1) <> 2 Then
              MsgBox "Select 2 items in the active sketch and try again"
              Exit Sub
            End If
            Set swSketchSegA = swSelMgr.GetSelectedObject6(1, -1)
          #Else
            Set swSketchSegA = swSketchMgr.CreateSpline(pointArray)
          #End If
           
            Set swCurveA = swSketchSegA.GetCurve
            If Not GetStartEndPoint(swSketchSegA, Astart, Aend) Then Exit Sub

           

            Dim swSketchSegB As SldWorks.SketchSegment
            Dim swCurveB As SldWorks.Curve
          #If Develop Then
            Set swSketchSegB = swSelMgr.GetSelectedObject6(2, -1)
          #Else
            Set swSketchSegB = swSketchMgr.CreateLine(0.03, 0.04, 0#, -0.045, 0.08, 0#)
          #End If
            Set swCurveB = swSketchSegB.GetCurve
            If Not GetStartEndPoint(swSketchSegB, Bstart, Bend) Then Exit Sub

           

            On Error GoTo ErrorHandler
            pointArray = swCurveA.IntersectCurve(swCurveB, Astart, Aend, Bstart, Bend)

           

            If IsNull(pointArray) Then
              Debug.Print "No intersection"
            Else
              Debug.Print "Points:"
              Dim i As Long
              Debug.Print "X", "Y", "Z", "K"
              For i = 0 To UBound(pointArray) Step 4
                Debug.Print pointArray(i), pointArray(i + 1), pointArray(i + 2), pointArray(i + 3)
              Next
            End If

           

            Exit Sub
          ErrorHandler:
            Debug.Print Err.Number, Err.Description
          End Sub

            • Re: IntersectCurve in VBA
              Andreas Killer

              I got it!

               

              There are 2 important things before we can correctly create sketch items AND calculate the intersection points AND create sketch points at these positions:

               

              a) Before we can exactly create sketch items we must switch snapping off, otherwise it is possible (and it really happens) that e.g. the end point of a line near to an other sketch item snaps to that line!

               

              b) We must set AddToDB = True, otherwise IntersectCurve fails!

               

              Now it doesn't matter which curve is passed first to IntersectCurve, the returned results are same... within the accuracy of the IEEE 754 specifications.

               

              But the "k" argument within the returned array is still wrong, seems to be a bug in Solidworks... I don't care.

               

              The Sub Main below needs the Function GetStartEndPoint from above.

              If you execute the sample you'll see that 2 points are created on the spline, one is on the real intersection, the other is at the possible intersection.

               

              So the next question is how can I decide between real and possible intersection points... I'll create a new thread for that.

               

              Andreas.

               

              Option Explicit

               

              #Const Develop = False

               

              Sub Main()
                Dim swApp As SldWorks.SldWorks
                Dim swModel As SldWorks.ModelDoc2
                Dim swSketchMgr As SldWorks.SketchManager

               

                Set swApp = Application.SldWorks
                Set swModel = swApp.ActiveDoc
                Set swSketchMgr = swModel.SketchManager
              #If Develop Then
                Dim swSelMgr As SldWorks.SelectionMgr
                Set swSelMgr = swModel.SelectionManager
              #End If

               

                Dim pointArray As Variant
                Dim Points() As Double
                ReDim Points(0 To 14) As Double
                Points(0) = 0.03
                Points(1) = 0
                Points(2) = 0
                Points(3) = 0
                Points(4) = 0.04
                Points(5) = 0
                Points(6) = 0.03
                Points(7) = 0.08
                Points(8) = 0
                Points(9) = 0.06
                Points(10) = 0.04
                Points(11) = 0
                Points(12) = 0.03
                Points(13) = 0
                Points(14) = 0
                pointArray = Points

               

                Dim Astart() As Variant, Aend() As Variant, Bstart() As Variant, Bend() As Variant
               
                Dim swSketchSegA As SldWorks.SketchSegment
                Dim swCurveA As SldWorks.Curve
               
                'Important:
               
                'Snapping off!
                Dim Snapping
                Snapping = swApp.GetUserPreferenceToggle(swUserPreferenceToggle_e.swSketchInference)
                swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swSketchInference, False
               
                'Add created sketch segments directly to the SOLIDWORKS database!
                swSketchMgr.AddToDB = True

               

              #If Develop Then
                If swSelMgr.GetSelectedObjectCount2(-1) <> 2 Then
                  MsgBox "Select 2 items in the active sketch and try again"
                  Exit Sub
                End If
                Set swSketchSegA = swSelMgr.GetSelectedObject6(1, -1)
              #Else
                Set swSketchSegA = swSketchMgr.CreateSpline(pointArray)
              #End If
               
                Set swCurveA = swSketchSegA.GetCurve
                If Not GetStartEndPoint(swSketchSegA, Astart, Aend) Then Exit Sub

               

                Dim swSketchSegB As SldWorks.SketchSegment
                Dim swCurveB As SldWorks.Curve
              #If Develop Then
                Set swSketchSegB = swSelMgr.GetSelectedObject6(2, -1)
              #Else
                Set swSketchSegB = swSketchMgr.CreateLine(0.03, 0.04, 0#, -0.045, 0.08, 0#)
              #End If
                Set swCurveB = swSketchSegB.GetCurve
                If Not GetStartEndPoint(swSketchSegB, Bstart, Bend) Then Exit Sub
               
                On Error GoTo ErrorHandler
                pointArray = swCurveA.IntersectCurve(swCurveB, Astart, Aend, Bstart, Bend)
               
                If IsNull(pointArray) Then
                  Debug.Print "No intersection"
                Else
                  Debug.Print "Points:"
                  Dim i As Long
                  Debug.Print "X", "Y", "Z", "K"
                  For i = 0 To UBound(pointArray) Step 4
                    Debug.Print pointArray(i), pointArray(i + 1), pointArray(i + 2), pointArray(i + 3)
                    'swSketchMgr.CreatePoint pointArray(i), pointArray(i + 1), 0#
                  Next
                End If
               
                pointArray = swCurveB.IntersectCurve(swCurveA, Bstart, Bend, Astart, Aend)

               

                If IsNull(pointArray) Then
                  Debug.Print "No intersection"
                Else
                  Debug.Print "Points:"
                  Debug.Print "X", "Y", "Z", "K"
                  For i = 0 To UBound(pointArray) Step 4
                    Debug.Print pointArray(i), pointArray(i + 1), pointArray(i + 2), pointArray(i + 3)
                    swSketchMgr.CreatePoint pointArray(i), pointArray(i + 1), 0#
                  Next
                End If
               
                GoTo ExitPoint
               
              ErrorHandler:
                Debug.Print Err.Number, Err.Description
                Resume Next
               
              ExitPoint:
                'Clean up
                swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swSketchInference, Snapping
                swSketchMgr.AddToDB = False
              End Sub