Polygon zeichnen + Flächenberechnung nach Gauss Dieses Beispiel zeigt, wie sich mit der Maus beliebige Polygone zeichnen und abschließend deren Flächeninhalte mit Hilfe des Gauss'schen Algorithmus berechnen lassen.
Autor:   Malte Treckmann	Bewertung:     [ Jetzt bewerten ]	Views:  35.614
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 42 Bewertung insgesamt: sehr gut Durchschnittliche Bewertung: 4.7 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Erst vor kurzem wurde im Forum gefragt, wie man mit der Maus ein Polygon zeichnen kann und abschließend dann den Flächeninhalt berechnet.

Erstellen Sie ein neues Projekt und platzieren auf die Form eine PictureBox. Setzen Sie die PictureBox-Eigenschaft AutoRedraw auf den Wert True. Per Linksklick sollen die einzelne Eckpunkte des Polygons gesetzt werden. Die jeweiligen Verbindungslinien werden dann autom. gezeichnet. Per Rechtsklick soll das Polygon geschlossen werden. Anschließend erfolgt noch die Berechnung des Flächeninhaltes und wird in der Titelzeile der Form ausgegeben.

Fügen Sie folgenden Code in den Codeteil der Form ein:

Option Explicit
 
' G A U S S - F L Ä C H E
' =======================
' 
' Malte Treckmann
' 
' Berechnug von Polygonflächen, deren Eckpunkte koordinatenmässig bekannt sind
' mit Hilfe der Trapezformel von Gauss.
' Siehe:
' Witte/Schmidt, Vermessungskunde und Grundlagen der Statistik für das Bauwesen, S. 241
' Hagebusch, Fachkunde für Vermessungstechniker, S. 78
' 
' Die Trapezformel befindet sich im Modul mod_gauss_area.
' Mit dem Programm können mit der Maus Polygone gezeichnet werden
' (Schliessen eines Polygons mit rechter Maustaste) und die eingeschlossene
' Fläche wird ermittelt.
' Zur eigenen Kontrolle werden die Seitenlängen des Polygons ausgegeben.
 
Dim punkte() As Double   ' Polygonkoordinaten
Dim zeichnet As Boolean  ' Status-Flag
Dim x_s, y_s As Double   ' Startpunkt
Dim x_m, y_m As Double   ' Mausposition
Dim x_p, y_p As Double   ' letzter gezeichneter Punkt

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _
  X As Single, Y As Single)
 
  Select Case zeichnet
    Case False
      If Button = vbLeftButton Then
        ' eine neue Zeichnung beginnt
        zeichnet = True
 
        ' Koordinaten des Startpunktes
        x_s = X
        y_s = Y
 
        ' zum Zeichnen
        x_p = X
        y_p = Y
 
        ' zum Rechnen
        anz_punkte = 0
        ReDim punkte(1, anz_punkte)
        punkte(0, 0) = X
        punkte(1, 0) = Y
      End If
 
    Case True
      If Button = vbLeftButton Then
        ' eine Zeichnung wird weitergeführt
 
        ' zum Zeichnen
        Picture1.Line (x_p, y_p)-(X, Y)
        x_p = X
        y_p = Y
 
        ' zum Rechnen
        anz_punkte = anz_punkte + 1
        ReDim Preserve punkte(1, anz_punkte)
        punkte(0, anz_punkte) = X
        punkte(1, anz_punkte) = Y
      End If
 
      If Button = vbRightButton Then
        ' eine Zeichnung wird beendet
        zeichnet = False
 
        ' löscht die aktuell angezeigte Linie
        Picture1.Line (x_p, y_p)-(X, Y), &H8000000F
 
        ' schliesst das Polygon
        Picture1.Line (x_p, y_p)-(x_s, y_s)
 
        ' Ausgabe der Polygonfläche
        Me.Caption = Format(gauss_area(punkte()), "###0.00")
      End If
  End Select
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _
  X As Single, Y As Single)
 
  Dim s As String
 
  Select Case zeichnet
    Case True
      ' alte Linie löschen
      Picture1.Line (x_p, y_p)-(x_m, y_m), &H8000000F
 
      x_m = X
      y_m = Y
 
      ' neue Linie zeichnen
      Picture1.Line (x_p, y_p)-(x_m, y_m)
 
      ' Länge der aktuellen Linie
      s = "Länge: " + Format(CStr(Sqr((x_p - x_m) ^ 2 + (y_p - y_m) ^ 2)), "###0.00")
      Me.Caption = s
 
    Case False
      ' es passiert nix
  End Select
End Sub

Private Sub Form_DblClick()
  ' Zeichnung löschen
  Picture1.Cls
  Me.Caption = ""
End Sub

Fehlt jetzt nur noch die Funktion gauss_area zum Berechnen des Flächeninhaltes des Polygons:

Im Modul:

Option Explicit
 
Public anz_punkte As Integer       ' Zähler

Public Function gauss_area(punkte() As Double) As Double
  ' Berechnet die Fläche eines Polygons, das durch
  ' Punktkoordinaten gegeben ist
  Dim i As Integer
  Dim Area As Double
  Dim xs, ys, xa, ya As Double
 
  xs = punkte(0, 0)
  ys = punkte(1, 0)
 
  For i = 0 To anz_punkte
    xa = punkte(0, i)
    ya = punkte(1, i)
 
    Area = Area + (ys + ya) * (xs - xa)
 
    xs = xa
    ys = ya
  Next i
 
  ' der letzte Punkt ist wieder der erste Punkt
  xa = punkte(0, 0)
  ya = punkte(1, 0)
 
  Area = Area + (ys + ya) * (xs - xa)
 
  ' Rückgabewert
  gauss_area = Abs(Area) / 2
End Function