Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

Dieser Tipp zeigt ein Vorgehen, ein beliebig flächiges Polygon in Dreiecke zu zerlegen. Das kann zum Beispiel zur Darstellung im 3D-Raum notwendig sein.
Bitte beachten Sie, dass das Polygon nicht auf sich schneidende Kanten geprüft wird, dies muss vorher geschehen.

Zu diesem Tipp existieren im Tippupload die folgende(n) Aktualisierung(en):
[VB 5/6 Tippvorschlag 0403] Polygon in Dreiecke zerlegen (Erweitert)

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

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 --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

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.

Kommentar von Hans-Jörg Stradtmann am 03.03.2009 um 15:42

Hallo Phillip,

leider kreuzen bei folgendem Bild erzeugte Linien die Kanten des Polygons. http://rapidshare.com/files/204813123/Fehler01.JPG.html%20%20MD5:%20DA921B8FC9161A8FF227EE5280389619

Gibt's da eine Abhilfe

Gruß Hajo

Kommentar von Jörn am 27.08.2008 um 11:10

Hallo,
bei mir leuft das Programm nicht. Beim öffen der Anwendung mit VB5 ist die Zeile "Private Function SplitPoly() As Tri()" rot markiert. Beim Kompilieren erscheint folgende Fehlermeldung: "Fehler beim Komilieren: Erwartet: Anweisungsende".

Ändere ich die Zeile in "Private Function SplitPoly() As Tri" ab, so führt das in der "Private Sub cmdSplit_Click()"
zu folgenden Fehler: "Fehler beim Komilieren: Keine Zuweisung an Datenfeld möglich"

Was kann ich tun um die Sache zum Laufen zu bringen?
Mein Betriebssystem ist XP

Gruß Jörn

Kommentar von H.T.Herrmann am 02.06.2008 um 16:36

Ich entschuldige mich für die wirren Zeichen im letzten Posting. Die ASCII-Zeichnung wurde leider ihrer leerzeichen beraubt nach dem Abschicken des Posts. Es gibt hierzu aber einen Thread im VB5/6 Forum.
http://foren.activevb.de/cgi-bin/foren/view.pl?forum=4&msg=359693&root=359693&page=1

Kommentar von H.T.Herrmann am 29.05.2008 um 10:50

Ich habe mitlerweile den Algorithmus ausprobiert. Er scheint recht solide zu sein, hat aber noch ein Problem mit manchen Polygonen die sich nicht überschneiden, aber wo zum Beispiel ein Punkt weit in die Polygonfläche reicht.
Die folgende Konstellation wurde bei mir falsch verbunden (außerhalb des Polygons), wobei A den grünen Punkt darstellt

O---O O---O
\ \ / |
\ \ / |
\ O |
\ O
\ /
\ -
\ O
\ \
\ \
\ \
\ \
O-- \ O-----O
| --- \ |
| --A |
| |
O O-----O

Kommentar von Holger Herrmann am 18.04.2008 um 13:39

Ich hatte noch nicht die Zeit mich näher mit diesem Tip zu beschäftigen, obwohl er mich sehr interessiert.
Bevor ich mich da reinlesen kann mir vielleicht jemand sagen, ob dieser Code sowohl konvexe als auch konkave Polygone unterstützt (die sich nicht selbst schneiden) und in beiden nur die innerhalb liegenden Dreiecke generiert?