SOLIDWORKS macro finds intersection points between surface and curve
{ width=300 }
This example demonstrates how to find the intersection points between selected surface (plane or face) with curve (edge or sketch segment) using SOLIDWORKS API.
- Open Part document
- Select plane or any face as first selection object
- Select sketch segment (line, spline or arc) as second selection object
- Run the macro. As the result the 3D Sketch is created with points of intersection between selected objects
ISurface::IntersectCurve2 SOLIDWORKS API method is used to find the intersection points within the specified boundaries of curve and surface.
Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
Dim swSelMgr As SldWorks.SelectionMgr
Set swSelMgr = swModel.SelectionManager
Dim swSurf As SldWorks.Surface
Dim swCurve As SldWorks.curve
Set swSurf = GetSurface(swSelMgr.GetSelectedObject6(1, -1))
Set swCurve = GetCurve(swSelMgr.GetSelectedObject6(2, -1))
If Not swSurf Is Nothing And Not swCurve Is Nothing Then
Dim vStartPt As Variant
Dim vEndPt As Variant
GetCurveEndPoints swCurve, vStartPt, vEndPt
Dim dBounds(5) As Double
dBounds(0) = vStartPt(0): dBounds(1) = vStartPt(1): dBounds(2) = vStartPt(2)
dBounds(3) = vEndPt(0): dBounds(4) = vEndPt(1): dBounds(5) = vEndPt(2)
Dim vPoints As Variant
Dim curveParams As Variant
Dim uvParams As Variant
swSurf.IntersectCurve2 swCurve, dBounds, vPoints, curveParams, uvParams
DrawPoints swModel, vPoints
Else
MsgBox "Please select surface (plane or face) and curve (edge or sketch segment) to find intersection"
End If
Else
MsgBox "Please opent the model"
End If
End Sub
Function GetSurface(swObj As Object) As SldWorks.Surface
Dim swSurf As SldWorks.Surface
If TypeOf swObj Is SldWorks.Face2 Then
Dim swFace As SldWorks.Face2
Set swFace = swObj
Set swSurf = swFace.GetSurface
ElseIf TypeOf swObj Is SldWorks.Feature Then
Dim swFeat As SldWorks.Feature
Set swFeat = swObj
If swFeat.GetTypeName2() = "RefPlane" Then
Dim swRefPlane As SldWorks.refPlane
Set swRefPlane = swFeat.GetSpecificFeature2()
Set swSurf = CreateSurfaceFromRefPlane(swRefPlane)
End If
End If
Set GetSurface = swSurf
End Function
Function CreateSurfaceFromRefPlane(refPlane As SldWorks.refPlane) As SldWorks.Surface
Dim swModeler As SldWorks.Modeler
Dim swMathUtils As SldWorks.MathUtility
Set swModeler = swApp.GetModeler()
Set swMathUtils = swApp.GetMathUtility
Dim dRoot(2) As Double
dRoot(0) = 0: dRoot(1) = 0: dRoot(2) = 0
Dim dNorm(2) As Double
dNorm(0) = 0: dNorm(1) = 0: dNorm(2) = 1
Dim dRef(2) As Double
dRef(0) = 1: dRef(1) = 0: dRef(2) = 0
Dim swRootPt As SldWorks.MathPoint
Dim swNormVec As SldWorks.MathVector
Dim swRefVec As SldWorks.MathVector
Set swRootPt = swMathUtils.CreatePoint(dRoot)
Set swNormVec = swMathUtils.CreateVector(dNorm)
Set swRefVec = swMathUtils.CreateVector(dRef)
Dim swXForm As SldWorks.MathTransform
Set swXForm = refPlane.Transform
Set swRootPt = swRootPt.MultiplyTransform(swXForm)
Set swNormVec = swNormVec.MultiplyTransform(swXForm)
Set swRefVec = swRefVec.MultiplyTransform(swXForm)
Set CreateSurfaceFromRefPlane = swModeler.CreatePlanarSurface2(swRootPt.ArrayData, swNormVec.ArrayData, swRefVec.ArrayData)
End Function
Function GetCurve(swObj As Object) As SldWorks.curve
Dim swCurve As SldWorks.curve
If TypeOf swObj Is SldWorks.Edge Then
Dim swEdge As SldWorks.Edge
Set swEdge = swObj
Set swCurve = swEdge.GetCurve
ElseIf TypeOf swObj Is SldWorks.SketchSegment Then
Dim swSkSeg As SldWorks.SketchSegment
Set swSkSeg = swObj
Set swCurve = GetTrimmedCurveFromSketchSegment(swSkSeg)
End If
Set GetCurve = swCurve
End Function
Function GetTrimmedCurveFromSketchSegment(skSeg As SldWorks.SketchSegment) As SldWorks.curve
Dim swCurve As SldWorks.curve
Set swCurve = skSeg.GetCurve
Dim swStartPt As SldWorks.SketchPoint
Dim swEndPt As SldWorks.SketchPoint
If TypeOf skSeg Is SldWorks.SketchLine Then
Dim swSkLine As SldWorks.SketchLine
Set swSkLine = skSeg
Set swStartPt = swSkLine.GetStartPoint2()
Set swEndPt = swSkLine.GetEndPoint2()
ElseIf TypeOf skSeg Is SldWorks.SketchSpline Then
Dim swSkSpline As SldWorks.SketchSpline
Set swSkSpline = skSeg
Dim vSplinePts As Variant
vSplinePts = swSkSpline.GetPoints2()
Set swStartPt = vSplinePts(0)
Set swEndPt = vSplinePts(UBound(vSplinePts))
ElseIf TypeOf skSeg Is SldWorks.SketchArc Then
Dim swSkArc As SldWorks.SketchArc
Set swSkArc = skSeg
Set swStartPt = swSkArc.GetStartPoint2()
Set swEndPt = swSkArc.GetStartPoint2()
End If
Set swCurve = swCurve.CreateTrimmedCurve2(swStartPt.X, swStartPt.Y, swStartPt.Z, swEndPt.X, swEndPt.Y, swEndPt.Z)
Dim swXForm As SldWorks.MathTransform
Set swXForm = skSeg.GetSketch().ModelToSketchTransform.Inverse
swCurve.ApplyTransform swXForm
Set GetTrimmedCurveFromSketchSegment = swCurve
End Function
Function GetCurveEndPoints(curve As SldWorks.curve, ByRef startPt As Variant, ByRef endPt As Variant)
Dim startParam As Double
Dim endParam As Double
curve.GetEndParams startParam, endParam, False, False
Dim dStartPt(2) As Double
Dim dEndPt(2) As Double
Dim evalRes As Variant
evalRes = curve.Evaluate2(startParam, 1)
dStartPt(0) = evalRes(0): dStartPt(1) = evalRes(1): dStartPt(2) = evalRes(2)
evalRes = curve.Evaluate2(endParam, 1)
dEndPt(0) = evalRes(0): dEndPt(1) = evalRes(1): dEndPt(2) = evalRes(2)
startPt = dStartPt
endPt = dEndPt
End Function
Function DrawPoints(model As SldWorks.ModelDoc2, points As Variant)
model.ClearSelection2 True
model.SketchManager.Insert3DSketch True
model.SketchManager.AddToDB = True
Dim i As Integer
For i = 0 To UBound(points) Step 3
model.SketchManager.CreatePoint points(i), points(i + 1), points(i + 2)
Next
model.SketchManager.AddToDB = False
model.SketchManager.Insert3DSketch True
End Function