OberonPlace.com Forums

OberonPlace.com Forums (http://forum.oberonplace.com/index.php)
-   Macros/Add-ons (http://forum.oberonplace.com/forumdisplay.php?f=21)
-   -   New macro to clip curves w.r.t. a border (http://forum.oberonplace.com/showthread.php?t=159)

Gerard Hermans 09-06-2003 07:50

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. :D

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



All times are GMT -5. The time now is 15:42.

Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2021, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com