Here’s another little VBA macro that I wrote that might be interesting to some of you. This one takes any sketch curve (circle, arc, spline, ellipse, or elliptical arc) as input, along with the number of segments to break the curve into. It then creates sketch lines along the curve. It also sets the original curve to be construction geometry.
This mostly uses the curve geometry query functionality in the API and also demonstrates creating a sketch. I’ve tried to add comments to the code to help in understanding what it’s doing.
Public Sub CreateSegmentedCurve() ' Check to see that a curved sketch entity is selected. Dim entity As SketchEntity On Error Resume Next Set entity = ThisApplication.ActiveDocument.SelectSet.Item(1) If Err.Number 0 Then MsgBox "A curved sketch entity must be selected." Exit Sub End If On Error GoTo 0 If TypeOf entity Is SketchPoint Or _ TypeOf entity Is SketchLine Then MsgBox "A curved sketch entity must be selected." Exit Sub End If ' Ask for the number of segments to break the curve into. Dim prompt As String prompt = "Enter the number of segments for the curve." Dim segmentCount As Integer segmentCount = Val(InputBox(prompt, "Number of Segments", "10")) If segmentCount = 0 Then MsgBox "Invalid segment count." Exit Sub End If ' Get the parent sketch. Dim sk As sketch Set sk = entity.Parent ' Get the evaluator from the associate geometry. Dim curveEval As Curve2dEvaluator Set curveEval = entity.Geometry.Evaluator Dim minU As Double Dim maxU As Double Call curveEval.GetParamExtents(minU, maxU) ' Determine if the entity is open or closed (circle, ' ellipse, or closed spline) Dim curveIsClosed As Boolean curveIsClosed = False If TypeOf entity Is SketchCircle Or _ TypeOf entity Is SketchEllipse Or _ TypeOf entity Is SketchSpline Or _ TypeOf entity Is SketchOffsetSpline Then If TypeOf entity Is SketchSpline Or _ TypeOf entity Is SketchOffsetSpline Then If entity.Closed Then curveIsClosed = True End If Else curveIsClosed = True End If End If Dim tg As TransientGeometry Set tg = ThisApplication.TransientGeometry ' Determine if start point is at the min or max parameter. Dim startPoint As SketchPoint Dim endPoint As SketchPoint If Not curveIsClosed Then Dim startCoord() As Double Dim endCoord() As Double Call curveEval.GetEndPoints(startCoord, endCoord) If entity.StartSketchPoint.Geometry.IsEqualTo( _ tg.CreatePoint2d(startCoord(0), startCoord(1))) Then Set startPoint = entity.StartSketchPoint Set endPoint = entity.EndSketchPoint Else Set endPoint = entity.StartSketchPoint Set startPoint = entity.EndSketchPoint End If End If ' Get the curve length. Dim length As Double Call curveEval.GetLengthAtParam(minU, maxU, length) ' Determine the length between segments. Dim offset As Double offset = length / segmentCount ' Start a transaction to wrap the sketch creation as a ' single undo operation. On Error GoTo ErrorFound Dim transMgr As TransactionManager Set transMgr = ThisApplication.TransactionManager Dim trans As Transaction Set trans = transMgr.StartTransaction( _ ThisApplication.ActiveDocument, "Segment Curve") ' Defer updates on the sketch while the sketch entities ' are being created. This will significantly improve ' performance. sk.DeferUpdates = True ' Calculate the points and create a sketch ' point at each position. Dim points() As SketchPoint  
; ReDim points(segmentCount) Dim i As Integer Dim currentLength As Double currentLength = 0 For i = 0 To segmentCount Dim currentParam As Double Call curveEval.GetParamAtLength(minU, currentLength, _ currentParam) currentLength = currentLength + offset Dim params(0) As Double params(0) = currentParam Dim coords() As Double Call curveEval.GetPointAtParam(params, coords) If i = 0 Then ' Special case for first point. If Not curveIsClosed Then Set points(i) = startPoint Else Set points(i) = sk.SketchPoints.Add( _ tg.CreatePoint2d(coords(0), coords(1)), False) Set endPoint = points(i) End If ElseIf i = segmentCount Then ' Special case for last point Set points(i) = endPoint Else Set points(i) = sk.SketchPoints.Add( _ tg.CreatePoint2d(coords(0), coords(1)), False) End If Next ' Connect the points with lines. For i = 0 To segmentCount - 1 Call sk.SketchLines.AddByTwoPoints(points(i), points(i + 1)) Next ' Make the selected entity construction geometry. entity.Construction = True ' There's a current problem that when setting the construction ' property, the display isn't updated to reflect this change ' until something causes the sketch to recompute. This performs ' a change on the sketch to kick a recompute. Dim originalPoint As Point2d Set originalPoint = points(0).Geometry Call points(0).MoveTo(tg.CreatePoint2d( _ points(0).Geometry.X + 0.001, _ points(0).Geometry.Y)) Call points(0).MoveTo(originalPoint) ' Turn off the defer to the sketch will recompute normally. sk.DeferUpdates = False trans.End Exit Sub ErrorFound: sk.DeferUpdates = False If Not trans Is Nothing Then trans.Abort End If MsgBox "Unexpected error segmenting curve." End Sub
Leave a Reply