Hello all,
I wrote a VBA macro that clips a given curve w.r.t. a closed curve of some border.
I needed such a macro because I wanted my (calculated) geometry-plots inside a given rectangle.
So the parts that stick out should be erased.
I do not have a web-site, therefore copied the code in here to share the macro with you and of course to receive helpfull feedback.
To test/use this macro create a closed curve (a rectangle should be converted to a curve) with only 1 subpath, and another arbitrary curve.
Call the macro in VBA code with variables that refer to these shapes (the macro could be changed to include a pick-tool to select these shapes with a mouse-click): 8)
Code:
Private Sub Clip(ByVal Border As Shape, ByRef ShapeToClip As Shape)
Dim csp As CrossPoints, cp As CrossPoint
Dim sp As SubPath
Dim n As Node
Dim s As Shape
Dim srIn As ShapeRange
Dim i As Integer, j As Integer
Dim crv As Curve
Dim sgm As Segment
Dim x As Double, y As Double
Dim NrDeleted As Integer
Dim NrTotal As Integer
Dim Repeat As Boolean
' Validation
If Border.Curve.Subpaths.Count > 1 Or Border.Curve.Closed = False Then _
Err.Raise vbObjectError + 513, "Clip", _
"This macro supports a closed border with 1 subpath"
If ShapeToClip.Type <> cdrCurveShape Then _
Err.Raise vbObjectError + 514, "Clip", _
"This macro supports CurveShapes"
Set crv = ShapeToClip.Curve
Repeat = False
' Repetition is a workaround, see below
clip_repetition:
For j = crv.Subpaths.Count To 1 Step -1
' Add nodes on the intersections with the border
Set csp = crv.Subpaths(j).GetIntersections(Border.Curve.Subpaths(1), cdrRelativeSegmentOffset)
For Each cp In csp
crv.Subpaths(j).AddNodeAt cp.Offset, cdrRelativeSegmentOffset
Next cp
' Clip all nodes outside the border
NrDeleted = 0
NrTotal = crv.Subpaths(j).Nodes.Count
For i = NrTotal To 1 Step -1
Set n = crv.Subpaths(j).Nodes(i)
Select Case Border.Curve.IsOnCurve(n.PositionX, n.PositionY)
Case cdrInsideShape, cdrOnMarginOfShape
Case cdrOutsideShape
n.Delete
NrDeleted = NrDeleted + 1
' Deletion of second last node deletes last node as well
If (NrTotal - NrDeleted) < 2 Then Exit For
End Select
Next i
Next j
' Break apart segments that do not have a node outside the border
' First intersection with the border
For j = crv.Subpaths.Count To 1 Step -1
For i = crv.Subpaths(j).Segments.Count To 1 Step -1
Set sgm = crv.Subpaths(j).Segments(i)
Call sgm.GetPointPositionAt(x, y, 0.5, cdrRelativeSegmentOffset)
Select Case Border.Curve.IsOnCurve(x, y)
Case cdrInsideShape, cdrOnMarginOfShape
Case cdrOutsideShape
sgm.BreakApartAt 0, cdrRelativeSegmentOffset
End Select
Next i
Next j
' Second intersection with the border
For j = crv.Subpaths.Count To 1 Step -1
For i = crv.Subpaths(j).Segments.Count To 1 Step -1
Set sgm = crv.Subpaths(j).Segments(i)
Call sgm.GetPointPositionAt(x, y, 0.5, cdrRelativeSegmentOffset)
Select Case Border.Curve.IsOnCurve(x, y)
Case cdrInsideShape, cdrOnMarginOfShape
Case cdrOutsideShape
sgm.BreakApartAt 1, cdrRelativeSegmentOffset
End Select
Next i
Next j
' Break all subpaths of the curve apart
Set srIn = ShapeToClip.BreakApartEx
' Delete the subpaths outside of the border
For Each s In srIn
Call s.Curve.Subpaths(1).GetPointPositionAt(x, y, 0.5, cdrRelativeSegmentOffset)
Select Case Border.Curve.IsOnCurve(x, y)
Case cdrInsideShape, cdrOnMarginOfShape
Case cdrOutsideShape
s.Delete
End Select
Next s
' Combine the remaining subpaths again
Set ShapeToClip = srIn.Combine
' Workaround:
' Sometimes the clip must be repeated to complete everything (..?)
Set crv = ShapeToClip.Curve
Repeat = Not Repeat
If Repeat Then GoTo clip_repetition
' Release objects
Set s = Nothing
Set srIn = Nothing
Set crv = Nothing
Set sp = Nothing
Set n = Nothing
Set cp = Nothing
Set csp = Nothing
Set sgm = Nothing
End Sub