Option Explicit

Const Pi As Double = 3.141592657
Const cEarth As Double = 3959

Private Sub Command1_Click()
Dim lat1 As Double, long1 As Double, lat2 As Double, long2 As Double
Dim Cosd As Double, dMiles As Double, d As Double
On Local Error Resume Next
lat1 = Radians(txtDa(0).Text)
long1 = Radians(txtDa(1).Text)
lat2 = Radians(txtDa(2).Text)
long2 = Radians(txtDa(3).Text)

Cosd = Sin(lat1) * Sin(lat2) + Cos(lat1) * Cos(lat2) * Cos(long1 - long2)

d = ACos(Cosd)
dMiles = cEarth * d
Dim dStatuteMiles As Double, dKilometers As Double
dStatuteMiles = Int(dMiles * 100 + 0.5) / 100
dKilometers = dStatuteMiles * 1.6093470879
dKilometers = Int(dKilometers * 100 + 0.5) / 100
lblDistance.Caption = dStatuteMiles
lblKilometers.Caption = dKilometers
End Sub

Function ACos(R As Double) As Double
If R = -1 Then
ACos = 4 * Atn(1)
Else
ACos = Atn(-R / Sqr(-R * R + 1)) + 2 * Atn(1)
End If
End Function

Function Radians(aDat As String) As Double
Dim j As Long, k As Long, a As String
aDat = UCase$(aDat)
j = InStr(aDat, "N")
If j = 0 Then j = InStr(aDat, "S")
If j = 0 Then j = InStr(aDat, "E")
If j = 0 Then j = InStr(aDat, "W")
If j = 0 Then MsgBox aDat & " error - enter Deg.Min.Sec[EWNS]" & vbCrLf & "Example: 40.40.35N": Exit Function
a = Left$(aDat, j - 1)

k = InStr(a, ".")
If k Then
Radians = Val(Mid$(a, k + 1)) / 60 + Val(Left$(a, k - 1))
Else
Radians = Val(a)
End If
Radians = Radians * (Pi / 180)
Select Case Mid$(aDat, j)
Case "S", "W": Radians = -Radians
End Select
End Function