0 Replies Latest reply on Jun 30, 2017 4:36 AM by Andreas Killer

    IntersectCurve in VBA - decide between real and possible intersection points

    Andreas Killer

      Alright, maybe someone has an idea to solve this.


      After I found the solution to get IntersectCurve to work here


      I cleaned up my code and have written a universal Function GetIntersection to return the intersection points of 2 sketch segments, works AFAIK pretty good.


      If I look at 2 splines, the function return only the real intersection points.
      But if I look at e.g. a line and a spline, the function returns the real and possible intersection points.


      You can execute Sub Main below with an already opened sketch, it creates a line and a spline and the intersection points between both.

      But only one point really intersect both.

      For completeness (and followers) I attach also my whole code, which includes examples for Spline-Spline, Spline-Arc, two arbitrary items.


      For "normal elements" like lines, arcs, circles, etc. I can think of a method by myself to calculate if a point is really located on the element... a lot of code.

      But I wonder if there is a more simpler way using the API of Solidworks to decide between real and possible intersection points.

      Any ideas?




      Option Explicit

      Sub Main_IntersectCurve_Line_Spline()
        Dim swApp As SldWorks.SldWorks
        Dim swModel As SldWorks.ModelDoc2
        Dim swSketchMgr As SldWorks.SketchManager
        Dim swSketchSegA As SldWorks.SketchSegment
        Dim swSketchSegB As SldWorks.SketchSegment

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

        Dim pointArray As Variant
        Dim Points() As Double
        '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

        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

        Set swSketchSegA = swSketchMgr.CreateSpline(pointArray)
        Set swSketchSegB = swSketchMgr.CreateLine(0.03, 0.04, 0#, -0.045, 0.08, 0#)
        pointArray = GetIntersection(swSketchSegA, swSketchSegB)
        If IsNull(pointArray) Then
          MsgBox "No intersection"
          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#
            swModel.SketchAddConstraints "sgFIXED"
        End If
        swModel.ClearSelection2 True
        'Clean up
        swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swSketchInference, Snapping
        swSketchMgr.AddToDB = False
      End Sub

      Function GetIntersection(ByRef swSketchSegA As SldWorks.SketchSegment, ByRef swSketchSegB As SldWorks.SketchSegment, _
          Optional ByRef RealIntersection, Optional ByRef PossibleIntersection) As Variant
        'Returns an array of doubles containing the x, y, z location of the tessellation points and a code for each point
        '  Null if no intersection is found
        Dim swCurveA As SldWorks.Curve, swCurveB As SldWorks.Curve
        Dim Astart() As Variant, Aend(), Bstart() As Variant, Bend() As Variant
        Dim pointArray As Variant
        'Assume failure
        GetIntersection = Null
        Set swCurveA = swSketchSegA.GetCurve
        If Not GetStartEndPoint(swSketchSegA, Astart, Aend) Then Exit Function
        Set swCurveB = swSketchSegB.GetCurve
        If Not GetStartEndPoint(swSketchSegB, Bstart, Bend) Then Exit Function
        On Error GoTo ExitPoint
        pointArray = swCurveA.IntersectCurve(swCurveB, Astart, Aend, Bstart, Bend)
        GetIntersection = pointArray
        'How can I decide between real and possible intersection points here?
      End Function

      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
          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