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?

 

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

Attachments

Outcomes