Positions Berechnung mit VB6

[Sommer]

Hi,

also es ist mal wieder zum Haare raufen :-)

Ich muss den AscCos ausrechen und ich komm nicht auf das Ergebniss
wie mit den Taschenrechner das allerdings richtig ist!

Arkuskosinus(x) = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)

wäre die Funktion für den AscCos (Invert Cosinus oder Cos-1)

füge ich nun an der Stelle X meine Bsp.-Wert ein 0.4614 kommt immer
1,091223762 raus und nicht die 65.34 ° was rauskommen sollen.

Was mach ich den Bitte falsch :-)

Danke für eure Hilfe.

By Ulli

[Klaus_0168]

Hi Ulli,

ich zitiere mal aus dem BasCom - Handbuch :

ACos
Action

Returns the arccosine of a single in radians.

Zitat Ende

Die Winkelfunktionen werden im BasCom in Radiant berechnet.

Gruß Klaus

[Trabukh]

Vllt noch zur Orientierung: "radiant" heißt im Deutschen "Bogenmaß".
Umrechnen kann man das ganze wie folgt:
Von Bogenmaß nach Grad: Wert mit 57.296 multiplizieren (Genau: 180/Pi)
Von Grad nach Bogenmaß: Wert mit 0.01745 multiplizieren (Genau: Pi/180)

Gruß, Trabukh

[Sommer]

Hi,

ja habe es nun so gemacht.

Point1_Lati = (Text1.Text + (Text2.Text / 60) + (Text3.Text / 3600))
Point1_Longi = -(Text4.Text + (Text5.Text / 60) + (Text6.Text / 3600))

Point2_Lati = (Text7.Text + (Text8.Text / 60) + (Text9.Text / 3600))
Point2_Longi = -(Text10.Text + (Text11.Text / 60) + (Text12.Text / 3600))

L1 = Point1_Lati
L2 = Point1_Longi
G1 = Point2_Lati
G2 = Point2_Longi

Text15.Text = L1
Text16.Text = L2
Text17.Text = G1
Text18.Text = G2


D1 = Sin(L1) * Sin(G1) + Cos(L1) * Cos(G1) * Cos(L2 - G1)
Text19.Text = D1
Text20.Text = Cos(L2 - G1)
D2 = Format(Cos(D1) * 180 / Pi, "0.000")
Text13.Text = D2 * 60 'Entfernung
Text14.Text = D2 'Winkel zum Ziel

Warumn bekomme ich andere Ergebisse als wie mit meinen Taschenrechner?

---> φ1 = 41° 09' 28,0" N = 41,1578°, λ1 = 008° 38' W = -8,6333°
---> φ2 = 0° 40' 19,9" N = 0,6722°, λ2 = 061° 32' W = -61,5333°

->cos c = sin φ1 · sin φ2 + cos φ1 · cos φ2 · cos (λ1 - λ2)

---> 0,4618 = c = 62,5° = 3749' = 3749 sm

So ich komm mit den obigen Programm nicht drauf???

Was mach ich den falsch??

Danke Leute

[Trabukh]

D2 = Format(Cos(D1) * 180 / Pi, "0.000")
Hier wurden die Klammern vergessen!
D2 = Format(Cos(D1) * (180 / Pi), "0.000")

Gruß, Trabukh

[Sommer]

Hi,

kommt auch mit der Klammer das falsche raus *grrrr*

I komm net weiter :-(

Will Geographische Daten Grad'Minuten'Secunden Start -->Ziehl ausrechnen Winkel und Entfernung mit VB aber irgendwie wills net :-)

Evtl. noch jemand ne Lösung?

by Ulli

[Sommer]

Hi,

so ich habs :-) :-) :-)

VB kann des nicht auf den direkten weg und somit hab ich mich mal auf die Suche nach Funktionen gemacht!

Bin auch fündig geworden und man mus es zuvor auf Deg2 umrechen!

Sieht nun wie folgt aus.


Option Explicit

Dim Lat1
Dim Lon1
Dim Lat2
Dim Lon2
Dim L1
Dim L2
Dim G1
Dim G2


Const pi = 3.14159265358979


Function acos(rad)
If Abs(rad) <> 1 Then
acos = pi / 2 - Atn(rad / Sqr(1 - rad * rad))
ElseIf rad = -1 Then
acos = pi
End If
End Function



Function deg2rad(Deg)
deg2rad = CDbl(Deg * pi / 180)
End Function


Function rad2deg(rad)
rad2deg = CDbl(rad * 180 / pi)
End Function

Private Sub Command1_Click()

Lat1 = (Text1.Text + (Text2.Text / 60) + (Text3.Text / 3600))
Lon1 = -(Text4.Text + (Text5.Text / 60) + (Text6.Text / 3600))

Lat2 = (Text7.Text + (Text8.Text / 60) + (Text9.Text / 3600))
Lon2 = -(Text10.Text + (Text11.Text / 60) + (Text12.Text / 3600))

L1 = Lat1
L2 = Lon1
G1 = Lat2
G2 = Lon2

Text15.Text = L1
Text16.Text = L2
Text17.Text = G1
Text18.Text = G2

Dim theta, dist, distance, Deg

theta = Lon1 - Lon2
dist = Sin(deg2rad(Lat1)) * Sin(deg2rad(Lat2)) + Cos(deg2rad(Lat1)) * Cos(deg2rad(Lat2)) * Cos(deg2rad(theta))
dist = acos(dist)
dist = rad2deg(dist)
distance = Format(dist * 60, "0.000")
Deg = Format(dist, "0.000")

Text14.Text = Deg
Text13.Text = distance



End Sub



So gehts nun, also damit kann man leben :-)

Und ab jetzt wird es erst Interessant!

Es kommen GPS Daten hinzu und Log Daten

Und zur Fehlerkorrektur kommt noch ein Privates DGPS dazu :-)

Wird also noch a bissl Arbeit

by Ulli

Tipps immer gerne willkommen!

[Trabukh]

Hmm, komisch. Ich habe neulich eine Billiardsimulation mit VB gemacht, da ging das mit den Winkeln prima... komisch... ???
Aber schön, dass es jetzt doch endlich geklappt hat! :-)

Gruß, Trabukh

EDIT: Ich weiß jetzt, warum es bei dir nicht ging, die Grad-Variable MUSS als Double deklariert werden!!!

[Sommer]

Hi,

hatte ich zuvor auch als Double :-)

By Ulli

[Trabukh]

Naja, ansonsten fehlt bei deinem ersten Code nur noch die Konstante PI! :-) Und die Werte L1, L2, G1 und G2 müssen auch vor den trigonometrischen Funktion umgerechnet werden. Aber das ist ja jetzt auch egal, Hauptsache, es funktioniert... :-)

Gruß, Trabukh

sorry, wenn ich den alten beitrag nochmal hochhole...

ich benutze folgendes modul um die gps-daten (512X.2722=51° 2X.2722min x 121X.0787=12° 1X.0787min) in grad umzuwandeln (51,33787° x 12,234645°)

' quelle: http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=63143&lngWId=1

Option Explicit
Option Base 1

'The RMC-Datasentence (RMC=recommended minimum sentence C)
'is a recommendation for the minimum, that a GPS-Receiver should give back.
'It looks like this: "$GPRMC,191410,A,4735.5634,N,00739.3538,E,0.0,0.0,1 81102,0.4,E,A*19"
Public Sub decodeRMC(ByVal inp As String, _
Optional ByRef UtcTime As String, _
Optional ByRef ReceiverWarning As Boolean, _
Optional ByRef Latitude As Double, _
Optional ByRef LatitudeDir As String, _
Optional ByRef Longitude As Double, _
Optional ByRef LongitudeDir As String, _
Optional ByRef SpeedKMH As Double, _
Optional ByRef Course As Double, _
Optional ByRef DateStamp As String, _
Optional ByRef MagneticDeclination As Double, _
Optional ByRef Checksum As Boolean)
On Error Resume Next
inp = UCase(Trim(inp))
'Checking initstring. Must be the same for all RMC sentences.
If Left(inp, 1) <> "$" Or Mid(inp, 4, 3) <> "RMC" Then Checksum = False: Exit Sub
'Extracting that part of the sentence that is needed to calculate the checksum
Dim ChkDat As String
ChkDat = Mid(inp, 2, InStr(2, inp, "*") - 2)
'For compatibility with split function
inp = Replace(inp, ",,", ", ,")
'Splitting sentence
Dim Dat As Variant
Dat = Split(inp, ",")
'Calculating checksum and comparing it
Dim ChkSum As String
ChkSum = Dat(UBound(Dat))
ChkSum = Right(ChkSum, Len(ChkSum) - InStr(1, ChkSum, "*"))
If calcChecksum(ChkDat) = Hex2Dec(ChkSum) Then Checksum = True Else Checksum = False: Exit Sub
'UtcTime
UtcTime = Left(Dat(2), 6)
If UtcTime <> " " Then UtcTime = Left(UtcTime, 2) & ":" & Mid(UtcTime, 3, 2) & ":" & Right(UtcTime, 2) Else UtcTime = ""
'ReceiverWarning
If Dat(3) = "A" Or Dat(3) = "" Then ReceiverWarning = False Else ReceiverWarning = True
'Length
Dim sp As Integer
sp = InStr(1, Dat(4), ".")
Latitude = CDbl(Left(Dat(4), sp - 3)) + CDbl(CDbl(Replace(Mid(Dat(4), sp - 2), ".", ",")) / 60)
Latitude = Round(Latitude, 8)
'LengthDir
LatitudeDir = Dat(5)
'Width
sp = InStr(1, Dat(6), ".")
Longitude = CDbl(Left(Dat(6), sp - 3)) + CDbl(CDbl(Replace(Mid(Dat(6), sp - 2), ".", ",")) / 60)
Longitude = Round(Longitude, 8)
'WidthDir
LongitudeDir = Dat(7)
'SpeedKMH (needs to be converted from knots)
SpeedKMH = Replace(CStr((Dat(8) * 0.54)), ".", ",")
'Course without movement
Course = Replace(CStr(Dat(9)), ".", ",")
'DateStamp
DateStamp = Left(Dat(10), 6)
If DateStamp <> " " Then DateStamp = Left(DateStamp, 2) & "." & Mid(DateStamp, 3, 2) & "." & Mid(DateStamp, 5) Else DateStamp = ""
'MagneticDeclination
MagneticDeclination = Replace(CStr(Dat(11)), ".", ",")
End Sub

'The GGA-Datasentence contains the most important information about GPS-position and accuracy.
'it looks like: "$GPGGA,191410,4735.5634,N,00739.3538,E,1,04,4.4,35 1.5,M,48.0,M,,*45"
Public Sub decodeGGA(ByVal inp As String, _
Optional ByRef UtcTime As String, _
Optional ByRef Latitude As Double, _
Optional ByRef LatitudeDir As String, _
Optional ByRef Longitude As Double, _
Optional ByRef LongitudeDir As String, _
Optional ByRef Quality As String, _
Optional ByRef SatellitesIV As Integer, _
Optional ByRef HDOP As Double, _
Optional ByRef AltitudeSea As Double, _
Optional ByRef AltitudeSeaUnit As String, _
Optional ByRef AltitudeEllipsoid As Double, _
Optional ByRef AltitudeEllipsoidUnit As String, _
Optional ByRef Checksum As Boolean)
On Error Resume Next
inp = UCase(Trim(inp))
'Checking initstring. Must be the same for all GGA sentences.
If Left(inp, 1) <> "$" Or Mid(inp, 4, 3) <> "GGA" Then Checksum = False: Exit Sub
'Extracting that part of the sentence that is needed to calculate the checksum
Dim ChkDat As String
ChkDat = Mid(inp, 2, InStr(2, inp, "*") - 2)
'For compatibility with split function
inp = Replace(inp, ",,", ", ,")
'Splitting sentence
Dim Dat As Variant
Dat = Split(inp, ",")
'Calculating checksum and comparing it
Dim ChkSum As String
ChkSum = Dat(UBound(Dat))
ChkSum = Right(ChkSum, Len(ChkSum) - InStr(1, ChkSum, "*"))
If calcChecksum(ChkDat) = Hex2Dec(ChkSum) Then Checksum = True Else Checksum = False: Exit Sub
'UtcTime
UtcTime = Left(Dat(2), 6)
If UtcTime <> " " Then UtcTime = Left(UtcTime, 2) & ":" & Mid(UtcTime, 3, 2) & ":" & Right(UtcTime, 2) Else UtcTime = ""
'Length
Dim sp As Integer
sp = InStr(1, Dat(3), ".")
Latitude = CDbl(Left(Dat(3), sp - 3)) + CDbl(CDbl(Replace(Mid(Dat(3), sp - 2), ".", ",")) / 60)
Latitude = Round(Latitude, 8)
'LengthDir
LatitudeDir = Dat(4)
'Width
sp = InStr(1, Dat(5), ".")
Longitude = CDbl(Left(Dat(5), sp - 3)) + CDbl(CDbl(Replace(Mid(Dat(5), sp - 2), ".", ",")) / 60)
Longitude = Round(Longitude, 8)
'WidthDir
LongitudeDir = Dat(6)
'Quality: 0-invalid, 1-gps, 2-dgps, 6-guessed
Quality = "unknown"
If Dat(7) = 0 Then Quality = "no fix"
If Dat(7) = 1 Then Quality = "GPS fix"
If Dat(7) = 2 Then Quality = "DGPS fix"
If Dat(7) = 6 Then Quality = "guessed"
'Satellites in view
SatellitesIV = Dat(8)
'HDOP: horizontal dilution of precision (accuracy)
HDOP = Replace(CStr(Dat(9)), ".", ",")
'Altitude over sea
AltitudeSea = Replace(CStr(Dat(10)), ".", ",")
'Altitude over sea unit
AltitudeSeaUnit = Dat(11)
'Altitude over ellipsoid
AltitudeEllipsoid = Replace(CStr(Dat(12)), ".", ",")
'Altitude over ellipsoid unit
AltitudeEllipsoidUnit = Dat(13)
End Sub

'The GSA-Datasentence contains information about the PRN-Numbers of the satellites that are used
'for calculating the actual position and some more detailed info about the accuracy.
'it looks like: "$GPGSA,A,3,,,,15,17,18,23,,,,,,4.7,4.4,1.5*3F"
Public Sub decodeGSA(ByVal inp As String, _
Optional ByRef AutoSel As Boolean, _
Optional ByRef mode As String, _
Optional ByRef prn As Variant, _
Optional ByRef PDOP As Double, _
Optional ByRef HDOP As Double, _
Optional ByRef VDOP As Double, _
Optional ByRef Checksum As Boolean)
On Error Resume Next
inp = UCase(Trim(inp))
'Checking initstring. Must be the same for all GSA sentences.
If Left(inp, 1) <> "$" Or Mid(inp, 4, 3) <> "GSA" Then Checksum = False: Exit Sub
'Extracting that part of the sentence that is needed to calculate the checksum
Dim ChkDat As String
ChkDat = Mid(inp, 2, InStr(2, inp, "*") - 2)
'For compatibility with split function
inp = Replace(inp, ",,", ", ,")
'Splitting sentence
Dim Dat As Variant
Dat = Split(inp, ",")
'Calculating checksum and comparing it
Dim ChkSum As String
ChkSum = Dat(UBound(Dat))
ChkSum = Right(ChkSum, Len(ChkSum) - InStr(1, ChkSum, "*"))
If calcChecksum(ChkDat) = Hex2Dec(ChkSum) Then Checksum = True Else Checksum = False: Exit Sub
'Auto Selection Mode
If Dat(2) = "A" Then AutoSel = True Else AutoSel = False
'Mode
mode = "unknown"
If Dat(3) = "3" Then mode = "3D-Fix"
If Dat(3) = "2" Then mode = "2D-Fix"
If Dat(3) = "1" Then mode = "No-Fix"
'PRN-Numbers
ReDim prn(12)
Dim i As Integer
For i = 4 To 15
If IsNumeric(Dat(i)) Then prn(i - 3) = CInt(Dat(i)) Else prn(i - 3) = ""
Next
'PDOP in meters
PDOP = Replace(CStr(Dat(16)), ".", ",")
'HDOP horizontal dilution of precision in meters
HDOP = Replace(CStr(Dat(17)), ".", ",")
'VDOP vertical dilution of precision in meters
VDOP = Replace(Left(CStr(Dat(18)), InStr(1, Dat(18), "*") - 1), ".", ",")
End Sub

' sn ed azi dB ------------ ------------ ------------
'$GPGSV,3,1,12,22,89,000,00,14,59,000,00,15,53,000 ,00,18,51,000,00*7F
' ------------ ------------ ---------- ----------
'$GPGSV,3,2,12,09,47,000,00,19,15,000,00,21,13,000 ,,31,13,000,*7C
' ------------ ---------- ------------ ------------
'$GPGSV,3,3,12,03,06,000,00,11,04,000,,28,02,000,0 0,05,01,000,00*77

'$GPGSV,3,1,12,22,89,000,00,14,59,000,00,15,53,000 ,00,18,51,000,00*7F
'$GPGSV,3,2,12,09,47,000,00,19,15,000,00,21,13,000 ,,31,13,000,*7C
'$GPGSV,3,3,12,03,06,000,00,11,04,000,,28,02,000,0 0,05,01,000,00*77
'GSV - Satellites in view
' 1 2 3 4 5 6 7 n
' | | | | | | | |
' $--GSV,x,x,x,x,x,x,x,...*hh<CR><LF>
' 1) total number of messages
' 2) message number
' 3) satellites in view
' 4) satellite number
' 5) elevation in degrees
' 6) azimuth in degrees to true
' 7) SNR in dB
' more satellite infos like 4)-7)
' n) checksum

Public Sub decodeGSV(ByVal inp As String, _
Optional ByRef tnm As Integer, _
Optional ByRef mn As Integer, _
Optional ByRef SatsInView As Integer, _
Optional ByRef SatNr As Variant, _
Optional ByRef Elevation As Variant, _
Optional ByRef Azimuth As Variant, _
Optional ByRef SNRdB As Variant, _
Optional ByRef Checksum As Boolean)
On Error Resume Next
inp = UCase(Trim(inp))
'Checking initstring. Must be the same for all GSV sentences.
If Left(inp, 1) <> "$" Or Mid(inp, 4, 3) <> "GSV" Then Checksum = False: Exit Sub
'Extracting that part of the sentence that is needed to calculate the checksum
Dim ChkDat As String
ChkDat = Mid(inp, 2, InStr(2, inp, "*") - 2)
ChkDat = ChkDat
'For compatibility with split function
inp = Replace(inp, ",,", ", ,")
'Splitting sentence
Dim Dat As Variant
Dat = Split(inp, ",")
'Cutting what we won't need
inp = Right(inp, Len(inp) - 7)
inp = Left(inp, InStr(1, inp, "*") - 1)
'Calculating checksum and comparing it
Dim ChkSum As String
ChkSum = Dat(UBound(Dat))
ChkSum = Right(ChkSum, Len(ChkSum) - InStr(1, ChkSum, "*"))
Dim ccs As Integer, dcs As Long
ccs = calcChecksum(ChkDat)
dcs = Hex2Dec(ChkSum)
If ccs = dcs Then Checksum = True Else Checksum = False: Exit Sub
'total number of messages
tnm = CInt(Dat(1))
'message number
mn = CInt(Dat(2))
'Satellites in View
SatsInView = Dat(3)
Dim i As Integer
Dim sp As Integer
'Satellite-Numbers
ReDim SatNr(4)
For i = 1 To 4
sp = InStr(1, Dat(3 + i), "*")
If sp > 0 Then Dat(3 + i) = Left(Dat(3 + i), sp - 1)
SatNr(i) = Dat(3 + i)
Next
'Elevations
ReDim Elevation(4)
For i = 1 To 4
sp = InStr(1, Dat(7 + i), "*")
If sp > 0 Then Dat(7 + i) = Left(Dat(7 + i), sp - 1)
Elevation(i) = Dat(7 + i)
Next
'Azimuth's
ReDim Azimuth(4)
For i = 1 To 4
sp = InStr(1, Dat(11 + i), "*")
If sp > 0 Then Dat(11 + i) = Left(Dat(11 + i), sp - 1)
Azimuth(i) = Dat(11 + i)
Next
'SNRdB's
ReDim SNRdB(4)
For i = 1 To 4
sp = InStr(1, Dat(15 + i), "*")
If sp > 0 Then Dat(15 + i) = Left(Dat(15 + i), sp - 1)
SNRdB(i) = Dat(15 + i)
Next
End Sub



'Helper functions:
'=================

Function calcChecksum(inp As String) As Integer
Dim i As Integer, s As Integer
s = 0
For i = 1 To Len(inp)
s = s Xor Asc(Mid(inp, i, 1))
Next
calcChecksum = s
End Function

Function Hex2Dec(HexNum As Variant) As Long
Hex2Dec = "&h" & HexNum
End Function


'Compatibility functions:
'========================

Function Split(sIn As String, sDel As String) As Variant
Dim i As Integer, x As Integer, s As Integer, t As Integer
i = 1: s = 1: t = 1: x = 1
ReDim tArr(1 To x) As Variant
If InStr(1, sIn, sDel) <> 0 Then
Do
ReDim Preserve tArr(1 To x) As Variant
tArr(i) = Mid(sIn, t, InStr(s, sIn, sDel) - t)
t = InStr(s, sIn, sDel) + Len(sDel)
s = t
If tArr(i) <> "" Then i = i + 1
x = x + 1
Loop Until InStr(s, sIn, sDel) = 0
ReDim Preserve tArr(1 To x) As Variant
tArr(i) = Mid(sIn, t, Len(sIn) - t + 1)
Else
tArr(1) = sIn
End If
Split = tArr
End Function

Function Round(ByVal Value As Variant, Optional ByVal digits As Integer = 0) As Variant
Dim i As Long
Dim Pot10(-28 To 28) As Variant
If i = 0 Then
For i = LBound(Pot10) To UBound(Pot10)
Pot10(i) = CDec(10 ^ i)
Next i
End If
On Error Resume Next
If Value > 0 Then
Round = Int(Value * Pot10(digits) + 0.5) * Pot10(-digits)
Else
Round = -Int(-Value * Pot10(digits) + 0.5) * Pot10(-digits)
End If
If Err.Number Then Round = Value
On Error GoTo 0
End Function

Function Replace(strString As String, Find As String, strReplace As String) As String
Dim ss As Long
ss = InStr(1, strString, Find)
If ss > 0 Then
strString = Left(strString, ss - 1) & strReplace & Right(strString, Len(strString) - (ss + (Len(Find) - 1)))
Replace = Replace(strString, Find, strReplace)
Else
Replace = strString
End If
End Function

wenn ich nun L1, L2, G1, G2 durch die errechneten koordinaten ersetze, dann müßte ich doch ebenfalls die entfernung ermittelt bekommen, kann das einer bestätigen? oder gibt es vielleicht andere gps-projekte die sich näher mit der entfernungsberechnung beschäftigen? hat vielleicht schon einer ein fertiges beispielprojekt, da ich mir nicht sicher bin ob ich mit der oben genannten methode ein korrektes ergebniss erhalte oder ob da irgendwo doch ein fehler drin ist.

vielleicht kann einer weiterhelfen.
mfg.

ok, ich komme immer auf falsche ergebnisse, im deut. raum muß man wohl folgende konstante benutzen: distance = dist * 111.12 '<- den wert hab ich aus einer exel-koordinaten-umrechnungstabelle

weiß vielleicht einer warum gerade "111.12"? woraus/wie errechnet sich dieser wert bzw. woher kommen die "60" aus dem obigen code?

mfg.

[gpsklaus]

Hallo

> weiß vielleicht einer warum gerade "111.12"? woraus/wie errechnet sich dieser wert bzw. woher kommen die "60" aus dem obigen code?


Der Wert kommt mir irgendwie bekannt vor. Der Abstand zwischen zwei Breitengraden beträgt 111Km ( oder vielleicht auch: 111.12 Km ?).
Das kann doch kein Zufall sein?

Klaus

[gpsklaus]

Hallo,
ich habe den Code von SOMMER am PDA unter Verwendung von "eVB" ausprobiert. Zum Testen wurden allerdings nur fixe Eingangsdaten verwendet.
Wenn man den Entfernungsparameter "dist" mit 1.852 multipliziert, erhält man Entfernungsangaben in Km. Von einem Breitengrad zum nächsten ergibt das exakt 111.12KM. Der Abstand zwischen zwei Längengraden variiert dagegen in Abhängigkeit vom Breitengrad. Im mittleren Teil von Deutschland sind es etwa 70Km. Soweit scheint der Code also zu funktionieren. Nicht klargekommen bin ich dagegen mit der verwendeten Richtungsberechnung. Deshalb habe ich hierfür stattdessen eine vorhandene Routine eingebaut. Sie ist auch im beigefügten Code zu finden.

Klaus


Option Explicit

Dim Lat1
Dim Lon1
Dim Lat2
Dim Lon2
Dim L1
Dim L2
Dim G1
Dim G2

Const pi = 3.14159265358979
Const radian = 0.017453292 'pi/180

Private Sub Command2_Click()

'Lat1 = (Text1.Text + (Text2.Text / 60) + (Text3.Text / 3600))
'Lon1 = -(Text4.Text + (Text5.Text / 60) + (Text6.Text / 3600))

'Lat2 = (Text7.Text + (Text8.Text / 60) + (Text9.Text / 3600))
'Lon2 = -(Text10.Text + (Text11.Text / 60) + (Text12.Text / 3600))

Lat1 = 50.96
Lon1 = 8.2
Lat2 = 49.96
Lon2 = 8.2

L1 = Lat1
L2 = Lon1
G1 = Lat2
G2 = Lon2

Text1.Text = L1
Text2.Text = L2
Text3.Text = G1
Text4.Text = G2

'Distanzberechnung
Dim theta, dist, Deg

theta = Lon1 - Lon2
dist = Sin(deg2rad(Lat1)) * Sin(deg2rad(Lat2)) + Cos(deg2rad(Lat1)) * Cos(deg2rad(Lat2)) * Cos(deg2rad(theta))
dist = acos(dist)
dist = rad2deg(dist)
Text5.Text = (Int(dist * 6000 + 0.5) / 100) * 1.852

'Richtungsbrechnung
Dim ga, zw, bear

If dist > 0 Then

Lon1 = Lon1 * radian
Lat1 = Lat1 * radian
Lon2 = Lon2 * radian
Lat2 = Lat2 * radian

ga = Lon1 - Lon2
zw = Cos(Lat1) * Cos(Lon1 - Lon2) * Cos(Lat2) + Sin(Lat1) * Sin(Lat2)
zw = Atn(zw / Sqr(1 - zw * zw))
zw = pi / 2 - zw

bear = ((Sin(Lat2) - Sin(Lat1) * Cos(zw)) / (Cos(Lat1) * Sin(zw)))
bear = Atn(bear / Sqr(1 - bear * bear))
bear = (pi / 2 - bear) / radian

If Sin(ga) >= 0 Then
bear = 360 - bear
End If
End If

bear = Int(bear * 10 + 0.5) / 10
If bear = 0 Then bear = 360
Text6.Text = bear

End Sub

Function acos(rad)
If Abs(rad) <> 1 Then
acos = pi / 2 - Atn(rad / Sqr(1 - rad * rad))
ElseIf rad = -1 Then
acos = pi
End If
End Function

Function deg2rad(Deg)
deg2rad = CDbl(Deg * pi / 180)
End Function

Function rad2deg(rad)
rad2deg = CDbl(rad * 180 / pi)
End Function

Private Sub Form_OKClick()
App.End
End Sub

[Vogon]

...Wenn man den Entfernungsparameter "dist" mit 1.852 multipliziert, erhält man Entfernungsangaben in Km...
:-k Wer wissen möchte warum das so ist: http://de.wikipedia.org/wiki/Nautische_Meile