View Single Post
  #1  
Old 09-06-2003, 07:50
Gerard Hermans
Guest
 
Posts: n/a
Default New macro to clip curves w.r.t. a border

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
Reply With Quote