Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0709: Polygon in Dreiecke zerlegen

VB 5/6-Tipp 0709: Polygon in Dreiecke zerlegen

 von Philipp Burch

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [4,49 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 "frmMain" alias Form1.frm  --------
' Steuerelement: Schaltfläche "cmdClear"
' Steuerelement: Schaltfläche "cmdSplit"
' Steuerelement: Schaltfläche "cmdDraw"
' Steuerelement: Bildfeld-Steuerelement "picDisplay"
' Steuerelement: Figur-Steuerelement "shpPoint" (Index von 0 bis 17) auf picDisplay

Option Explicit

'Dieser Code ist in der Lage, beliebige flächige Polygone (ohne überlappende
'Kanten) in Dreiecke zu zerlegen.
'Quelle:
'http://www.siggraph.org/education/materials/HyperGraph/hypergraph.htm
'
'Hinweis: Bitte beachten Sie, dass das Polygon NICHT auf sich kreuzende
'Kanten untersucht wird!
'
'Autor: Philipp Burch


'Struktur zur Speicherung eines Punkts
Private Type Pt2D
    x As Long
    y As Long
    Active As Boolean
End Type

'Struktur zur Speicherung eines Dreiecks
Private Type Tri
    pt1 As Pt2D
    pt2 As Pt2D
    pt3 As Pt2D
End Type

Private Polygon() As Pt2D
Private SelectedPt As Integer


'Zerlegt Polygon in einzelne Dreiecke
Private Function SplitPoly() As Tri()
    Dim tris() As Tri
    
    'Es gibt immer genau zwei Dreiecke weniger als Eckpunkte
    ReDim tris(UBound(Polygon) - 1)

    Dim e As Boolean
    Dim i As Integer
    Dim it As Integer, p As Integer, n As Integer
    Dim leftdiscard As Integer
    
    For i = 0 To UBound(Polygon)
        Polygon(i).Active = True
    Next i
    
    i = 0
    it = GetLeftMostPt()
    Do
        n = GetPrevPt(it, e)
        If e Then Exit Do
        p = GetNextPt(it, e)
        If e Then Exit Do
        If p = n Then Exit Do
        
        'Überprüfen, ob das Dreieck p-it-n weitere Punkte des Polygons
        'enthält. Falls nein wird it vom Polygon entfernt und das Dreieck
        'p-it-n gespeichert.
        If NoPointInside(p, it, n) Then
            With tris(i)
                .pt1 = Polygon(p)
                .pt2 = Polygon(it)
                .pt3 = Polygon(n)
            End With
            Polygon(it).Active = False

            i = i + 1
            it = GetLeftMostPt()
            leftdiscard = 0
        Else
            leftdiscard = leftdiscard + 1
            it = GetLeftMostPt(leftdiscard)
        End If
    Loop

    SplitPoly = tris
End Function


'=== Hilfsfunktionen ===


'Überprüfen, ob das Dreieck mit diesen drei Punkten
'einen weiteren (aktiven) Eckpunkt des Polygons enthält
Private Function NoPointInside(pt1 As Integer, _
                               pt2 As Integer, _
                               pt3 As Integer) As Boolean
                               
    Dim i As Integer
    Dim e As Boolean
    Dim cnt As Integer
    
    For i = 0 To UBound(Polygon)
        If Polygon(i).Active Then cnt = cnt + 1
    Next i
    cnt = cnt - 3   'Die drei übergebenen Punkte zählen nicht!
    
    i = GetNextPt(0, e)
    Do While cnt
        Do While i = pt1 Or i = pt2 Or i = pt3
            i = GetNextPt(i, e)
        Loop
        
        If PtInsideTri(Polygon(pt1), _
                       Polygon(pt2), _
                       Polygon(pt3), _
                       Polygon(i)) Then
                       
            NoPointInside = False
            Exit Function
        End If
        i = GetNextPt(i, e)
        cnt = cnt - 1
    Loop
    
    NoPointInside = True
End Function

'Überprüfen, ob das Dreieck p1, p2, p3 den Punkt p enthält
Private Function PtInsideTri(p1 As Pt2D, _
                             p2 As Pt2D, _
                             p3 As Pt2D, _
                             p As Pt2D) As Boolean
                             
    If p.x < min3(p1.x, p2.x, p3.x) Or _
       p.x > max3(p1.x, p2.x, p3.x) Or _
       p.y < min3(p1.y, p2.y, p3.y) Or _
       p.y > max3(p1.y, p2.y, p3.y) Then
    
        'Der Punkt liegt nicht innerhalb des Rechtecks, gebildet aus
        'den Eckpunkten des Dreiecks -> Er liegt sicher nicht innerhalb
        'des Dreiecks.
        PtInsideTri = False
        Exit Function
    End If
    
    '         C
    '         /\
    '        /  \
    '       /    \
    '      /      \
    '     /   P    \
    '    /          \
    '   /            \
    ' A/______________\B
    '
    'P liegt dann innerhalb des Dreiecks, wenn er jeweils auf der gleichen
    'Seite einer Dreieckskante liegt wie der gegenüberliegende Eckpunkt.
    'Liegt P also auf der gleichen Seite von AB wie der Punkt C, auf der
    'gleichen Seite von BC wie A und auf der gleichen Seite von CA wie B,
    'dann befindet er sich innerhalb des Dreiecks.
    PtInsideTri = SameSide(p.x, p.y, p1.x, p1.y, p2.x, p2.y, p3.x, p3.y) And _
                  SameSide(p.x, p.y, p2.x, p2.y, p3.x, p3.y, p1.x, p1.y) And _
                  SameSide(p.x, p.y, p3.x, p3.y, p1.x, p1.y, p2.x, p2.y)
End Function

'Liegen die Punkte pt1 und pt2 auf der gleichen Seite der Strecke l1l2?
Private Function SameSide(pt1x As Long, _
                          pt1y As Long, _
                          pt2x As Long, _
                          pt2y As Long, _
                          l1x As Long, _
                          l1y As Long, _
                          l2x As Long, _
                          l2y As Long) As Boolean
                          
    SameSide = CBool(Sgn(((pt1x - l1x) * (l2y - l1y) - _
                          (l2x - l1x) * (pt1y - l1y))) * _
                     Sgn(((pt2x - l1x) * (l2y - l1y) - _
                          (l2x - l1x) * (pt2y - l1y))) > 0)
End Function

Private Function min3(x As Long, y As Long, z As Long) As Long
    If x < y Then
        If x < z Then
            min3 = x
        Else
            min3 = z
        End If
    Else
        If y < z Then
            min3 = y
        Else
            min3 = z
        End If
    End If
End Function

Private Function max3(x As Long, y As Long, z As Long) As Long
    If x > y Then
        If x > z Then
            max3 = x
        Else
            max3 = z
        End If
    Else
        If y > z Then
            max3 = y
        Else
            max3 = z
        End If
    End If
End Function

'Aktiven Punkt mit der kleinsten x-Koordinate holen (Am weitesten links).
Private Function GetLeftMostPt(Optional ByVal discard As Integer = 0) _
                               As Integer
                               
    Dim i As Integer, n As Integer, p As Integer
    Dim e As Boolean
    Dim xmin As Long
    
    xmin = &H7FFFFFFF
    
    For i = 0 To UBound(Polygon)
        If Polygon(i).x < xmin And Polygon(i).Active Then
            GetLeftMostPt = i
            xmin = Polygon(i).x
        End If
    Next i
    
    'Gegebenenfalls nicht den Punkt ganz links nehmen, sondern
    'einen folgenden
    p = GetLeftMostPt
    n = p
    Do While discard > 0
        p = GetPrevPt(p, e)
        n = GetNextPt(n, e)
        
        If Polygon(p).x < Polygon(n).x And (discard And 1) Then
            GetLeftMostPt = p
        Else
            GetLeftMostPt = n
        End If
        discard = discard - 2
    Loop
End Function

'Vorhergehenden aktiven Punkt holen
Private Function GetPrevPt(index As Integer, _
                           ByRef Error As Boolean) As Integer
                           
    Dim i As Integer
    If index = 0 Then
        i = UBound(Polygon)
    Else
        i = index - 1
    End If
    
    Error = False
    Dim count As Integer
    Do While (Not Polygon(i).Active) And _
             count < UBound(Polygon) + 1 And _
             i <> index
             
        i = i - 1
        count = count + 1
        If i < 0 Then i = UBound(Polygon)
    Loop
    GetPrevPt = i
    If count = UBound(Polygon) + 1 Then Error = True
End Function

'Nächsten aktiven Punkt holen
Private Function GetNextPt(index As Integer, _
                           ByRef Error As Boolean) As Integer
                           
    Dim i As Integer
    If index = UBound(Polygon) Then
        i = 0
    Else
        i = index + 1
    End If
    
    Error = False
    Dim count As Integer
    Do While (Not Polygon(i).Active) And _
             count < UBound(Polygon) + 1 _
             And i <> index
             
        i = i + 1
        count = count + 1
        If i > UBound(Polygon) Then i = 0
    Loop
    GetNextPt = i
    If count = UBound(Polygon) + 1 Then Error = True
End Function

Private Sub UpdatePolygon()
    Dim i As Integer
    
    ReDim Polygon(shpPoint.LBound To shpPoint.UBound)
    
    For i = shpPoint.LBound To shpPoint.UBound
        Polygon(i).x = shpPoint(i).Left + shpPoint(i).Width / 2
        Polygon(i).y = shpPoint(i).Top + shpPoint(i).Height / 2
    Next i
End Sub


'=== Ereignisprozeduren ===


Private Sub Form_Load()
    Call UpdatePolygon
    Call cmdDraw_Click
    
    'Startpunkt hervorheben
    shpPoint(shpPoint.LBound).FillColor = vbGreen
End Sub

Private Sub cmdDraw_Click()
    Dim i As Long
    Dim x As Long, y As Long
    
    Call picDisplay.Cls
    
    x = Polygon(0).x
    y = Polygon(0).y
    For i = 1 To UBound(Polygon)
        picDisplay.Line (x, y)-(Polygon(i).x, Polygon(i).y), vbMagenta
        x = Polygon(i).x
        y = Polygon(i).y
    Next i
    picDisplay.Line (x, y)-(Polygon(0).x, Polygon(0).y), vbMagenta
End Sub

Private Sub cmdSplit_Click()
    Dim tris() As Tri
    Dim i As Integer
        
'    Call picDisplay.Cls

    tris = SplitPoly()
    
    For i = 0 To UBound(tris)
        With tris(i)
            picDisplay.Line (.pt1.x, .pt1.y)-(.pt2.x, .pt2.y), vbBlack
            picDisplay.Line (.pt2.x, .pt2.y)-(.pt3.x, .pt3.y), vbBlack
            picDisplay.Line (.pt3.x, .pt3.y)-(.pt1.x, .pt1.y), vbBlack
        End With
    Next i
End Sub

Private Sub cmdClear_Click()
    Call picDisplay.Cls
End Sub

Private Sub picDisplay_MouseDown(Button As Integer, _
                                 Shift As Integer, _
                                 x As Single, _
                                 y As Single)
                                 
    If Button = vbLeftButton Then
        Dim i As Integer
        
        Call picDisplay.Cls
        SelectedPt = -1
        For i = shpPoint.LBound To shpPoint.UBound
            With shpPoint(i)
                If x > .Left And x < .Left + .Width And _
                   y > .Top And y < .Top + .Height Then
                   
                    SelectedPt = i
                    Exit For
                End If
            End With
        Next i
    End If
End Sub

Private Sub picDisplay_MouseMove(Button As Integer, _
                                 Shift As Integer, _
                                 x As Single, _
                                 y As Single)
                                 
    Dim i As Integer
    
    If Button <> vbLeftButton Or SelectedPt = -1 Then
        SelectedPt = -1
        Exit Sub
    End If
    
    shpPoint(SelectedPt).Left = x - shpPoint(SelectedPt).Width / 2
    shpPoint(SelectedPt).Top = y - shpPoint(SelectedPt).Height / 2
    Call UpdatePolygon
    Call cmdDraw_Click
End Sub
'--------- Ende Formular "frmMain" alias Form1.frm  ---------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 5 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.