AnsweredAssumed Answered

IntersectCurve in VBA

Question asked by Andreas Killer on Jun 28, 2017
Latest reply on Jun 30, 2017 by 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?




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"
    Debug.Print "Points:"
    Debug.Print Join(pointArray)
  End If


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


Function GetStartEndPoint(ByRef swSegment As Object, ByRef StartPoint, ByRef EndPoint) As Boolean
  'Based on
  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