[AccessD] Zipcodes within a radius

On 23 Mar 2007 at 10:01, pcs at AZIZAZ.com wrote:

> John,
> Alternatively you can use the following function in your 
> query:

Here's my toolkit which gives distances in nautical miles and great 
circle bearings between places which are held in tblLocations:
LocKey - PK - Autonumber
....
Lat - Double - Latitude in decimal degrees (S = Negative)
Long - Double - Longitude in decimal degrees (W = Negative) 

Of course, JC would use a Location class which he could pass to the 
functions Bearing() and DistanceNm() to avoid the DLookup()s <g>

........................................................

Option Compare Database
Option Explicit

Function DegToRad(angle_degrees As Double) As Double
DegToRad = (3.14159265358979 / 180) * angle_degrees
End Function

Function RadToDeg(angle_radians As Double) As Double
RadToDeg = (180 / 3.14159265358979) * angle_radians
End Function

Function arcsin(X As Double) As Double
arcsin = Atn(X / Sqr(-X * X + 1))
End Function

Function acos(angle As Double) As Double
 acos = Atn(-angle / Sqr(-angle * angle + 1)) + 2 * Atn(1)
End Function

Function NmToRad(distance_nm As Long) As Double
NmToRad = (3.14159265358979 / (180 * 60)) * distance_nm
End Function

Function RadToNm(distance_radians As Double) As Long
RadToNm = ((180 * 60) / 3.14159265358979) * distance_radians
End Function

Function DistanceNm(pos1 As Long, pos2 As Long) As Double
Dim lat1 As Double, lat2 As Double, lon1 As Double, lon2 As Double
lat1 = DegToRad(DLookup("lat", "tblLocations", "LocKey = " & pos1))
lon1 = DegToRad(DLookup("long", "tblLocations", "LocKey = " & pos1))
lat2 = DegToRad(DLookup("lat", "tblLocations", "LocKey = " & pos2))
lon2 = DegToRad(DLookup("long", "tblLocations", "LocKey = " & pos2))
DistanceNm = RadToNm(2 * arcsin(Sqr((Sin((lat1 - lat2) / 2)) ^ 2 + 
Cos(lat1) * Cos(lat2) * (Sin((lon1 - lon2) / 2)) ^ 2)))
End Function

Function Bearing(pos1 As Long, pos2 As Long) As Long
If pos1 = pos2 Then Exit Function
Dim lat1 As Double, lat2 As Double, lon1 As Double, lon2 As Double
Dim Dist As Double
lat1 = DegToRad(DLookup("lat", "tblLocations", "LocKey = " & pos1))
lon1 = DegToRad(DLookup("long", "tblLocations", "LocKey = " & pos1))
lat2 = DegToRad(DLookup("lat", "tblLocations", "LocKey = " & pos2))
lon2 = DegToRad(DLookup("long", "tblLocations", "LocKey = " & pos2))
If (Abs(Cos(lat1)) < 0.0000001) Then ' a small number ~ machine 
precision
  If (lat1 > 0) Then
     Bearing = 180       '  starting from N pole
  Else
     Bearing = 0        '  starting from S pole
  End If
 Exit Function
End If
Dist = NmToRad(DistanceNm(pos1, pos2))
If Sin(lon1 - lon2) < 0 Then
   Bearing = RadToDeg(acos((Sin(lat2) - Sin(lat1) * Cos(Dist)) / 
(Sin(Dist) * Cos(lat1))))
Else
   Bearing = RadToDeg(2 * 3.14159265358979 - acos((Sin(lat2) - 
Sin(lat1) * Cos(Dist)) / (Sin(Dist) * Cos(lat1))))
End If
End Function