Kreis aus drei Punkten eines Dreiecks berechnen

Kreis aus drei Punkten eines Dreiecks berechnen

Die Mittelsenkrechten eines jeden Dreiecks schneiden sich in einem Punkt, der sich Umkreis-Mittelpunkt nennt. Alle Ecken des Dreieckes sind gleich weit von diesem Mittelpunkt entfernt, liegen also auf dem Kreisumfang.

Den Umkreis eines Dreiecks mittels VBA zu ermitteln, ist gar nicht so einfach, da VBA beispielsweise kein Arkuskosinus kennt. Mich hat aber die Aufgabe gereizt, zumal man dabei immer etwas hinzulernt.

Den folgenden Code in das Klassenmodul eines Tabellenblattes. In B2:C2 sind die X-Y Koordinaten des ersten, in B3:C3 die des zweiten und in B3:C4 die Koordinaten des dritten Punktes.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("B2:C4")) Is Nothing Then Exit Sub
Berechnen
End Sub

Sub Berechnen()
Dim dblXA                     As Double
Dim dblYA                     As Double
Dim dblXB                     As Double
Dim dblYB                     As Double
Dim dblXC                     As Double
Dim dblYC                     As Double
Dim dblXMitte                 As Double
Dim dblYMitte                 As Double
Dim dblDeltaX                 As Double
Dim dblDeltaY                 As Double
Dim dblRadius                 As Double
Dim dblLängeA                 As Double
Dim dblLängeB                 As Double
Dim dblLängeC                 As Double
Dim dblWinkelA                As Double
Dim dblWinkelB                As Double
Dim dblWinkelC                As Double
Dim dblCosWinkel              As Double
Dim dblSteigungAB             As Double
Dim dblSteigungAC             As Double
Dim dblSteigungMPSenkrechtAB  As Double
Dim dblSteigungMPSenkrechtAC  As Double
Dim dblXUrsprungMPAB          As Double
Dim dblYUrsprungMPAB          As Double
Dim dblXUrsprungMPAC          As Double
Dim dblYUrsprungMPAC          As Double

Const Pi = 3.141592654

Application.EnableEvents = False

' Punkt A
dblXA = Me.Range("B2")
dblYA = Me.Range("C2")

' Punkt B
dblXB = Me.Range("B3")
dblYB = Me.Range("C3")

' Punkt C
dblXC = Me.Range("B4")
dblYC = Me.Range("C4")

' Länge Seite a
dblDeltaX = dblXB - dblXC
dblDeltaY = dblYB - dblYC
dblLängeA = Sqr(dblDeltaX ^ 2 + dblDeltaY ^ 2)

' Länge Seite b
dblDeltaX = dblXC - dblXA
dblDeltaY = dblYC - dblYA
dblLängeB = Sqr(dblDeltaX ^ 2 + dblDeltaY ^ 2)

' Länge Seite c
dblDeltaX = dblXB - dblXA
dblDeltaY = dblYB - dblYA
dblLängeC = Sqr(dblDeltaX ^ 2 + dblDeltaY ^ 2)

' Cosinussatz
dblCosWinkel = ((dblLängeA ^ 2 - dblLängeB ^ 2 - dblLängeC ^ 2) / _
   (-2 * dblLängeB * dblLängeC))
dblWinkelA = Arkuskosinus(dblCosWinkel)

dblCosWinkel = ((dblLängeB ^ 2 - dblLängeA ^ 2 - dblLängeC ^ 2) / _
   (-2 * dblLängeA * dblLängeC))
dblWinkelB = Arkuskosinus(dblCosWinkel)

dblCosWinkel = ((dblLängeC ^ 2 - dblLängeA ^ 2 - dblLängeB ^ 2) / _
   (-2 * dblLängeA * dblLängeB))
dblWinkelC = Arkuskosinus(dblCosWinkel)

' Sinussatz
dblRadius = dblLängeA / Sin(dblWinkelA * Pi / 180) / 2
'dblRadius = dblLängeB / Sin(dblWinkelB * Pi / 180) / 2
'dblRadius = dblLängeC / Sin(dblWinkelC * Pi / 180) / 2

' Mittelpunkt Linie AB
dblXUrsprungMPAB = (dblXA + dblXB) / 2
dblYUrsprungMPAB = (dblYA + dblYB) / 2

' Mittelpunkt Linie AC
dblXUrsprungMPAC = (dblXA + dblXC) / 2
dblYUrsprungMPAC = (dblYA + dblYC) / 2

' Steigung Linie AB
dblSteigungAB = (dblYB - dblYA) / (dblXB - dblXA)
If dblSteigungAB = 0 Then dblSteigungAB = 0.0000000001
' Steigung Linie AC
dblSteigungAC = (dblYC - dblYA) / (dblXC - dblXA)
If dblSteigungAC = 0 Then dblSteigungAC = 0.0000000001

' Steigung der jeweiligen Mittelsenkrechten
dblSteigungMPSenkrechtAB = -(1 / dblSteigungAB)
dblSteigungMPSenkrechtAC = -(1 / dblSteigungAC)

' Beide Punkt-Steigungsfunktionen ( Y = m (X - X0) + Y0 )
' gleichsetzen, um den Schnittpunkt zu finden
' und nach x auflösen
dblXMitte = (-dblSteigungMPSenkrechtAC * dblXUrsprungMPAC + _
   dblYUrsprungMPAC - dblYUrsprungMPAB + _
   dblSteigungMPSenkrechtAB * dblXUrsprungMPAB) / _
   (dblSteigungMPSenkrechtAB - dblSteigungMPSenkrechtAC)

' X in eine Punkt-Steigungsfunktionen einsetzen
dblYMitte = dblSteigungMPSenkrechtAC * dblXMitte - _
   dblSteigungMPSenkrechtAC * dblXUrsprungMPAC + dblYUrsprungMPAC


Me.Range("B7") = dblLängeA
Me.Range("B8") = dblLängeB
Me.Range("B9") = dblLängeC

Me.Range("B12") = dblWinkelA
Me.Range("B13") = dblWinkelB
Me.Range("B14") = dblWinkelC

Me.Range("B16") = dblRadius

Me.Range("B17") = dblXMitte
Me.Range("B18") = dblYMitte

Application.EnableEvents = True
Application.Calculate

End Sub

Private Function Arkuskosinus(ByVal dblCosWinkel As Double)
Const Pi = 3.141592654
   dblCosWinkel = dblCosWinkel + (dblCosWinkel = 1) * 0.0000000001
   dblCosWinkel = dblCosWinkel + (dblCosWinkel = -1) * -0.0000000001
   Arkuskosinus = (Atn(-1 * dblCosWinkel / Sqr(-1 * dblCosWinkel * _
      dblCosWinkel + 1)) + 2 * Atn(1)) * 180 / Pi
End Function