Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0767: Polygon Clipping mit dem Algorithmus von Sutherland&Hodgman

VB 5/6-Tipp 0767: Polygon Clipping mit dem Algorithmus von Sutherland&Hodgman

 von OlimilO

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [7.74 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Kombinationsliste "Combo2"
' Steuerelement: Kombinationsliste "Combo1"
' Steuerelement: Schaltfläche "CmdClip"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit
Private m_Poly    As Polygon2F
'Um die Beispiele zu vereinfachen werden nur Vierecke (Quad2F) verwendet
Private m_Q()     As Quad2F
Private m_QIndex1 As Integer
Private m_QIndex2 As Integer

Private Sub Form_Load()
    
    Dim i As Long
    With Picture1
        .BackColor = vbWhite
        .AutoRedraw = True
    End With
    
    ReDim m_Q(0 To 5)
    'ein paar Beispiel-Vierecke anlegen
    m_Q(i) = MQuad2F.New_Quad2F(20#, 50#, 50#, 50#, 50#, 20#, 20#, 20#): i = i + 1
    m_Q(i) = MQuad2F.New_Quad2F(15#, 35#, 35#, 55#, 55#, 35#, 35#, 15#): i = i + 1
    m_Q(i) = MQuad2F.New_Quad2F(40#, 40#, 50#, 40#, 50#, 30#, 15#, 15#): i = i + 1
    m_Q(i) = MQuad2F.New_Quad2F(20#, 30#, 20#, 40#, 30#, 40#, 55#, 15#): i = i + 1
    m_Q(i) = MQuad2F.New_Quad2F(15#, 30#, 30#, 50#, 45#, 30#, 30#, 10#): i = i + 1
    m_Q(i) = MQuad2F.New_Quad2F(50#, 50#, 40#, 30#, 50#, 10#, 20#, 30#)
    
    For i = 0 To 6
        'das sechste Quad ist konkav und deshalb als Clipper nicht geeignet
        If i < 6 Then Call Me.Combo1.AddItem(CStr(i))
        Call Me.Combo2.AddItem(CStr(i))
    Next
    Combo1.ListIndex = 1
    Combo2.ListIndex = 2
    Call Draw
End Sub

Private Sub Combo1_Click()
    m_QIndex1 = Combo1.List(Combo1.ListIndex) - 1
    m_Poly = ErasePolygon2F
    Call Draw
End Sub
Private Sub Combo2_Click()
    m_QIndex2 = Combo2.List(Combo2.ListIndex) - 1
    m_Poly = ErasePolygon2F
    Call Draw
End Sub

Private Sub CmdClip_Click()
    If m_QIndex1 >= 0 And m_QIndex2 >= 0 Then
        If MGeo.SutherlandHodgmanClip(m_Q(m_QIndex1).P, m_Q(m_QIndex2).P, m_Poly) Then
            Call Draw
        End If
    End If
End Sub

Private Sub Form_Resize()
    Dim L As Single, T As Single, W As Single, H As Single, m As Single
    L = Picture1.Left:              T = Picture1.Top
    W = Me.ScaleWidth - L - 8 * 15: H = Me.ScaleHeight - T - 8 * 15
    m = IIf(W < H, W, H)
    If W > 0 And H > 0 Then Picture1.Move L, T, m, m
End Sub
Private Sub Picture1_Resize()
    Picture1.Scale (-10#, 85#)-(85#, -10#)
    Call Draw
End Sub

Private Sub Picture1_Click()
    CmdClip_Click
End Sub

Private Sub Draw()

    Picture1.Cls
    Picture1.ForeColor = vbBlack
    Picture1.DrawWidth = 1
    'Koordinatenachsen zeichnen
    With Picture1
        'X-Achse zeichnen
        Picture1.Line (.ScaleLeft + 5, 0)-(.ScaleWidth + .ScaleLeft - 5, 0)
        Picture1.Print "x"
        'Y-Achse zeichnen
        Picture1.Line (0, .ScaleHeight + .ScaleTop + 5)-(0, .ScaleTop - 5)
        Picture1.Print " y"
    End With
    'das Quad zeichnen das clippt
    Picture1.ForeColor = vbGreen
    If m_QIndex1 >= 0 Then
        Call MQuad2F.Draw(m_Q(m_QIndex1), Picture1)
    End If
    
    'das Quad zeichnen das geclippt wird
    Picture1.ForeColor = vbBlack
    If m_QIndex2 >= 0 Then
        Call MQuad2F.Draw(m_Q(m_QIndex2), Picture1)
    End If
    
    'das resultierende Polygon zeichnen
    Picture1.DrawWidth = 2
    Picture1.ForeColor = vbRed
    If m_Poly.Count > 0 Then
        Call MPolygon2F.Draw(m_Poly, Picture1)
    End If
    
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------------ Anfang Modul "MGeo" alias MGeo.bas ------------
Option Explicit

'Geometrie-Typen
'für die Typen braucht man ein eigenes Modul,
'da sonst der Fehler auftritt: "gegenseitige Abhängigkeit von Modulen"
'2 = 2-dimensional; F = Float (Double)

'stellt einen 2D-Punkt dar
'wird oft auch mit Vertex bezeichnet
Public Type Point2F
    X As Double
    Y As Double
End Type

'stellt eine 2D-Strecke dar
Public Type LineSegment2F
    P(0 To 1) As Point2F
End Type

'stellt ein 2D-Viereck dar
Public Type Quad2F
    P(0 To 3) As Point2F
End Type
Public EraseQuad2F As Quad2F

'stellt ein 2D-Polygon dar
Public Type Polygon2F
    Count As Long
    P()   As Point2F
End Type
Public ErasePolygon2F As Polygon2F

Public Enum Position2
    RightPosition = -1
    Collinear = 0
    LeftPosition = 1
End Enum
Private Const eps As Double = 0.00000000000001

Public Function IntersectionPoint(ByVal x1 As Double, ByVal y1 As Double, _
                                  ByVal x2 As Double, ByVal y2 As Double, _
                                  ByVal x3 As Double, ByVal y3 As Double, _
                                  ByVal x4 As Double, ByVal y4 As Double) As Point2F
    'gibt den Schnittpunkt zweier Geraden G1, G2 zurück
    'G1 gegeben durch die Punkte G1:{{x1, y1}, {x2, y2}}
    'G2 gegeben durch die Punkte G2:{{x3, y3}, {x4, y4}}
    Dim Dx1 As Double, Dx2 As Double, Dx3 As Double
    Dim Dy1 As Double, Dy2 As Double, Dy3 As Double
    Dim det As Double, Ratio As Double
    
    Dx1 = x1 - x2
    Dx2 = x3 - x4
    Dx3 = x4 - x2
    Dy1 = y1 - y2
    Dy2 = y3 - y4
    Dy3 = y4 - y2
    
    det = (Dx2 * Dy1) - (Dy2 * Dx1)
    
    If Abs(det) <= eps Then
        det = (Dx2 * Dy3) - (Dy2 * Dx3)
        If Abs(det) <= eps Then
            IntersectionPoint.X = x3
            IntersectionPoint.Y = y3
            Exit Function
        End If
    End If
    Ratio = ((Dx1 * Dy3) - (Dy1 * Dx3)) / det
    IntersectionPoint.X = (Ratio * Dx2) + x4
    IntersectionPoint.Y = (Ratio * Dy2) + y4
End Function
Public Function Position2(ByVal x1 As Double, ByVal y1 As Double, _
                          ByVal x2 As Double, ByVal y2 As Double, _
                          ByVal Px As Double, ByVal Py As Double) As Position2
    'gibt zurück auf welcher Seite sich ein Punkt P relativ zu einer Geraden G befindet
    'Gerade: G:{{x1, y1}, {x2, y2}}
    'Punkt : P: {Px, Py}
    Dim det As Double
    'Determinante aus den 3 Punkten
    det = (x2 - x1) * (Py - y1) - (Px - x1) * (y2 - y1)
    If Abs(det) <= eps Then
        Position2 = Collinear
    ElseIf det > 0# Then
        Position2 = LeftPosition
    ElseIf det < 0# Then
        Position2 = RightPosition
    End If
End Function
Private Function IsInsideClippingRegion(P As Point2F, s As LineSegment2F) As Boolean
    'bei der Computer-Geometrie taucht immer wieder eine wichtige Frage auf:
    'wo befindet sich ein Punkt relativ zu einer Geraden bzw auf welcher Seite der Geraden
    'liegt ein Punkt. Hier ist ein kartesisches KO-System definiert.
    'Außerdem ist die Umfahrungsrichtung eines Polygons rechts herum definiert.
    
    'RightHandside oder Collinear ist inside
    'ist das KO-System anders definiert so muß hier angepasst werden
    IsInsideClippingRegion = _
        ( _
            MGeo.Position2(s.P(0).X, s.P(0).Y, _
                           s.P(1).X, s.P(1).Y, _
                           P.X, P.Y _
                           ) <> LeftPosition _
        )
End Function
Public Function SutherlandHodgmanClip(Clipper() As Point2F, _
                                      ClippingPoly() As Point2F, _
                                      PolyOut As Polygon2F _
                                      ) As Boolean
    'Clippt ein beliebiges Polygon (konkav oder konvex) an einem konvexen Polygon
    'gibt zurück ob eine Verschneidung geklappt hat
    'Clipper       ein konvexes Polygon das clippt
    'ClippingPoly  das Polygon das geclippt wird
    'PolyOut       das Polygon das zurückgegeben wird
    'konkav: nach innen  gewölbt  ], >, u, v
    'konvex: nach aussen gewölbt  0, o, O,
    
    'Achtung:
    'bevor die Funktion angewendet wird, muß sichergestellt werden
    'daß der Datenbereich der Arrays der Polygone Clipper und ClippingPoly
    'nur so groß ist wie die Anzahl Ihrer Punkte ist.
    '
    Dim ClippedPoly As Polygon2F
    Dim CS As LineSegment2F 'ein Segment aus Clipper
    Dim PS As LineSegment2F 'ein Segment aus ClippingPoly
    Dim SP As Point2F   'ein Schnittpunkt aus CS und PS
    Dim i  As Long, i0 As Long, i1 As Long
    Dim j  As Long
    Dim uC As Long
    Dim uP As Long
    uC = UBound(Clipper)
    With PolyOut
        .Count = UBound(ClippingPoly) + 1
        .P = ClippingPoly
    End With
    For j = 0 To uC
        If j < uC Then i0 = j: i1 = j + 1 Else i0 = uC: i1 = 0
        CS.P(0) = Clipper(i0):  CS.P(1) = Clipper(i1)
        'das alte Polygon löschen, alle Punkte werden neu hinzugefügt
        'das hat den Vorteil daß die Punkte später nicht sortiert werden müssen
        ClippedPoly = MGeo.ErasePolygon2F
        uP = PolyOut.Count - 1
        For i = 0 To uP
            If i < uP Then i0 = i: i1 = i + 1 Else i0 = uP: i1 = 0
            PS.P(0) = PolyOut.P(i0):  PS.P(1) = PolyOut.P(i1)
            If IsInsideClippingRegion(PS.P(0), CS) Then
                If IsInsideClippingRegion(PS.P(1), CS) Then
                    'beide drinnen, den zweiten hinzufügen
                    Call MPolygon2F.Add(ClippedPoly, PS.P(1))
                Else
                    'der erste drinnen, der zweite nicht drinnen,
                    'dann den Schnittpunkt berechnen
                    Call MPolygon2F.Add(ClippedPoly, MLineSegment2F.LineIntersection(CS, PS))
                End If
            Else
                'der erste nicht drinnen
                If IsInsideClippingRegion(PS.P(1), CS) Then
                    'der zweite drinnen,
                    'dann den Schnittpunkt berechnen
                    Call MPolygon2F.Add(ClippedPoly, MLineSegment2F.LineIntersection(CS, PS))
                    'und den zweiten hinzufügen
                    Call MPolygon2F.Add(ClippedPoly, PS.P(1))
                End If
            End If
        Next
        'das geclippte Polygon wird der Input für den nächsten Schritt
        PolyOut = ClippedPoly
    Next
    If PolyOut.Count > 0 Then SutherlandHodgmanClip = True
End Function
'------------- Ende Modul "MGeo" alias MGeo.bas -------------
'------ Anfang Modul "MPolygon2F" alias MPolygon2F.bas ------
Option Explicit
Private Const C_InitPolygonSize As Long = 16 '3

Public Sub Add(this As Polygon2F, newPoint2F As Point2F)
    'fügt einem Polygon einen Punkt hinzu
    'Achtung durch den Listen-Algorithmus hat das Polygon immer eine
    'größere Kapazität (UBound) als Punkte vorhanden sind (Count)
    With this
        If .Count = 0 Then
            ReDim .P(0 To C_InitPolygonSize)
        Else
            Dim u As Long: u = UBound(.P)
            If .Count > u Then
                ReDim Preserve .P(0 To 2 * u - 1)
            End If
        End If
        .P(.Count) = newPoint2F
        .Count = .Count + 1
    End With
End Sub

Public Sub Draw(this As Polygon2F, aPB As PictureBox)
    'zeichnet ein Polygon auf eine PictureBox, inkl. Punktnummern
    Dim i As Long
    With this
        For i = 0 To .Count - 1
            aPB.PSet (.P(i).X, .P(i).Y)
            aPB.Print CStr(i + 1)
            If i < .Count - 1 Then
                aPB.Line (.P(i).X, .P(i).Y)-(.P(i + 1).X, .P(i + 1).Y)
            Else
                aPB.Line (.P(i).X, .P(i).Y)-(.P(0).X, .P(0).Y)
            End If
        Next
    End With
End Sub
'------- Ende Modul "MPolygon2F" alias MPolygon2F.bas -------
'--- Anfang Modul "MLineSegment2F" alias MLineSegment2F.bas ---
Option Explicit

Public Function New_LineSegment2F(P1 As Point2F, P2 As Point2F) As LineSegment2F
    'erzeugt eine neues LineSegment (Strecke)
    With New_LineSegment2F
        .P(0) = P1
        .P(1) = P2
    End With
End Function

Public Function LineIntersection(S1 As LineSegment2F, S2 As LineSegment2F) As Point2F
    'berechnet den Schnittpunkt zweier Geraden gegeben durch die Strecken S1, S2
    LineIntersection = MGeo.IntersectionPoint( _
        S1.P(0).X, S1.P(0).Y, S1.P(1).X, S1.P(1).Y, _
        S2.P(0).X, S2.P(0).Y, S2.P(1).X, S2.P(1).Y)
End Function

Public Function ToString(this As LineSegment2F) As String
    'ganz hilfreich für Debug-Zwecke
    With this
        ToString = "{" & MPoint2F.ToString(.P(0)) & "; " & MPoint2F.ToString(.P(1)) & "}"
    End With
End Function

'--- Ende Modul "MLineSegment2F" alias MLineSegment2F.bas ---
'-------- Anfang Modul "MPoint2F" alias MPoint2F.bas --------
Option Explicit

Public Function New_Point2F(ByVal X As Double, _
                            ByVal Y As Double) As Point2F
    'erzeugt einen neuen Punkt
    With New_Point2F
        .X = X
        .Y = Y
    End With
End Function

Public Function ToString(this As Point2F) As String
    'ganz hilfreich für Debug-Zwecke
    With this
        ToString = "{" & CStr(.X) & ", " & CStr(.Y) & "}"
    End With
End Function

Public Function Position2(this As Point2F, LineSegment As LineSegment2F) As Position2
    'ermittelt die Position des Punktes relative zu einer Strecke
    With LineSegment
        Position2 = MGeo.Position2(.P(0).X, .P(0).Y, .P(1).X, .P(1).Y, this.X, this.Y)
    End With
End Function


'--------- Ende Modul "MPoint2F" alias MPoint2F.bas ---------
'--------- Anfang Modul "MQuad2F" alias MQuad2F.bas ---------
Option Explicit

Public Function New_Quad2F(ParamArray coords()) As Quad2F
    'erzeugt ein neues Viereck
    Dim i As Long, u As Long: u = UBound(coords)
    With New_Quad2F
        For i = 0 To ((u + 1) / 2) - 1
            .P(i) = MPoint2F.New_Point2F(coords(i * 2), coords(i * 2 + 1))
            If i = 7 Then Exit Function
        Next
    End With
End Function

Public Sub Draw(this As Quad2F, aPB As PictureBox)
    Dim i As Long
    'zeichnet das Viereck auf die PictureBox
    With this
        For i = 0 To 3
            aPB.PSet (.P(i).X, .P(i).Y)
            aPB.Print CStr(i + 1)
            If i < 3 Then
                aPB.Line (.P(i).X, .P(i).Y)-(.P(i + 1).X, .P(i + 1).Y)
            Else
                aPB.Line (.P(i).X, .P(i).Y)-(.P(0).X, .P(0).Y)
            End If
        Next
    End With
End Sub
'---------- Ende Modul "MQuad2F" alias MQuad2F.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------