GAO Associates 
87 Andrews Way
Plymouth, MA 02360-1641
This page contains source code lists of routines in ASCII text format that may be
of interest to programmers who code in the basic language. The routines
are in Visual Basic format and have all been tested for validity, however GAOA
assumes no responsibility for their use by anyone, since they are provided free of
charge. The routines are copyright free and may be used for
personal or business purposes. The only limitations are that they cannot be sold
as individual items, but can be included as components is applications that are sold.
Also, if any of the routines are redistributed, it is requested that the user indicate their
source as GAO Associates.
More functions and subroutines will be added here on a regular basis.
The source code listing below can simply be copied using any word processor that can
export text such as WordPerfect, or a simple text processor like Wordpad.
An equation for generating a value for PI
In programs the require the value for pi, one can either write out the number and
equate it to a global constant, or generate with the following expression
PI = 4 * ATN(1)
where ATN is the ordinary arctangent function which is included
in all programming languages.
General Date Computation Routines
The two functions and one subroutine that follow can all be used together for handling
time and date problems. The function "date_to_jd(year, month, day+fraction)" converts
input consisting of 3 variables to the full julian day number. This number is used for setting time
differentials of various types. For example, to get the exact time span between any two dates,
including time of day, input year (must be error free), month, and day where day can include
a fraction (e.g. for the 13th at 08:30, the input day is approximately 13.3541667), find the julian
day number for each date/time of interest and the difference between them is the desired time
span in days and fraction of a day.
If the date format in a program is not perfectly predictable the function Gendate(x) can
be used to produce the julian day number.
This is a very forgiving function that can handle several errors in the input data, such as
extraneous spaces, 1, 2 and 4 digit years, use of / or - as separators, etc. It cannot handle
fractional days, however a simple change in the input requirement to allow for another input
variable which contains only the fraction could be added "Gendate(x, df as double)"
would suffice and then change the line d2 = d, to d2 = d + df.
Function date_to_jd(yr%, mo%, d#)
'Converts calendar date to full Julian day number
'can be used over any calendar date if 4 digit year is input
'as presented here, the dates are Gregorian calendar only
'y is 1, 2 or 4 digit year, but if 1 or 2 digits, zeroyear is required
'zeroyear is a 1 or 2 digit integer for the function and should
'be a global constant set in the declarations of some module
'Note 1: With 1 or 2 digits for yr, the function can only be used
'during a 100 year span between 1900 and 2099
'Note 2: since yr is an integer, 2 digit representation for 2000-2009 is simply 0-9
'Example 1: if zeroyear is 0 then all 2 digit years are from 1900 to 1999
'Example 2: if zeroyear is 1 then all 2 digit years are from 1901 to 2000
'Example 2: if zeroyear is 5 then all 2 digit years are from 1905 to 2004
'Example 3: if zeroyear is 93 then all 2 digit years are from 1993 to 2092
'*****************************************************************************
Dim temp As String
temp = Trim(Str(yr))
If Len(temp) < 4 Then 'year is not in 4 digit form
If yr < zeroyear Then
yr = yr + 2000
Else
yr = yr + 1900
End If
End If
Dim jd#, y%, m%, a%, b%
If mo <= 2 Then
y = yr - 1
m = mo + 12
Else
y = yr
m = mo
End If
a = Fix(y / 100)
b = 2 - a + Fix(a / 4)
jd = Fix(365.25 * (y + 4716)) + Fix(30.6001 * (m + 1))
jd = jd + d + b - 1524.5
date_to_jd = jd
End Function
Sub Jd_to_date(jd#, yr%, mo%, da%, hr%, min%, sec!)
'Converts jd to date/time
'jd need not be an integer and can include fraction of day
'works for any positive julian day number
'produces positive as well as negative (BC) years
'*************************************************
Dim jdc#, z&, f#, alph&, a&, b&, c&
Dim d&, e%, dom#, hrs#, mins#
jdc = jd + 0.5
z = Fix(jdc)
f = jdc - z
alph = Fix((z - 1867216.25) / 36524.25)
a = z + 1 + alph - Fix(alph / 4)
b = a + 1524
c = Fix((b - 122.1) / 365.25)
d = Fix(365.25 * c)
e = Fix((b - d) / 30.6001)
dom = b - d - Fix(30.6001 * e) + f
da = Fix(dom) 'day out
hrs = (dom - da) * 24
hr = Fix(hrs) 'hour out
mins = (hrs - hr) * 60
min = Fix(mins) 'minute out
sec = (mins - min) * 60
If e < 14 Then
mo = e - 1 'month out
Else
mo = e - 13
End If
If mo > 2 Then 'year out
yr = c - 4716
Else
yr = c - 4715
End If
End Sub
Function GenDate(x As String)
Rem Handles a variety of date inputs to generate Julian Day number
Rem if x includes 4 digits for the year, the function can
Rem handle years from 0001 to any date
Rem for routine to handle dates from 4716 BC contact GAO Associates
Rem if x includes only 2 digits for the year
Rem the function can handle any 100 year span between 1900 and 2099
Rem 2 digit year requires global constant "zeroyear"
Rem Assumes either / or - as separators
Rem Can have extraneous spaces anywhere in the string
Dim z As String, m As Integer, d As Integer, y As Integer
Dim pos1 As Integer, pos2 As Integer, sym1 As String, sym2 As String
Dim d2 As Double
'remove any spaces at either end of the date
z = Trim$(x)
'check for and remove internal extraneous spaces
sym1 = " " 'a space, or use chr(32)
pos1 = InStr(1, z, sym1)
'if any internal paces, then pos1>0
Do While pos1
z = Left(z, pos1 - 1) & Mid(z, pos1 + 1, 14)
pos1 = InStr(1, z, sym1)
Loop
'search for / separator locations
sym1 = "/"
sym2 = "/"
pos1 = InStr(1, z, sym1)
pos2 = InStr(pos1 + 1, z, sym2)
If pos1 = 0 Then 'search for - separator locations
sym1 = "-" 'a negative sign, or use chr(45)
sym2 = "-"
pos1 = InStr(1, z, sym1)
pos2 = InStr(pos1 + 1, z, sym2)
If pos1 = 0 Then
'generate an error message and exit the function
Exit Function
End If
End If
Select Case Len(z)
Case 5 'z/z/z
m = Int(Val(Left(z, 1)))
d = Int(Val(Mid(z, 3, 1)))
y = Int(Val(Right(z, 1)))
If y < zeroyear Then
y = y + 2000
Else
y = y + 1900
End If
Case 6 'z/z/zz
m = Int(Val(Left(z, 1)))
d = Int(Val(Mid(z, 3, 1)))
y = Int(Val(Right(z, 2)))
If y < zeroyear Then
y = y + 2000
Else
y = y + 1900
End If
Case 7 'z/zz/zz or zz/z/zz
If pos1 = 2 Then 'format is z/zz/zz
m = Int(Val(Left(z, 1)))
d = Int(Val(Mid(z, 3, 2)))
y = Int(Val(Right(z, 2)))
If y < zeroyear Then
y = y + 2000
Else
y = y + 1900
End If
Else 'format is zz/z/zz
m = Int(Val(Left(z, 2)))
d = Int(Val(Mid(z, 4, 1)))
y = Int(Val(Right(z, 2)))
If y < zeroyear Then
y = y + 2000
Else
y = y + 1900
End If
End If
Case 8 'zz/zz/zz or z/z/zzzz or zzzz/z/z
If pos1 = 2 Then 'Format is z/z/zzzz
m = Int(Val(Left(z, 1)))
d = Int(Val(Mid(z, 3, 1)))
y = Int(Val(Right(z, 4)))
ElseIf pos1 = 3 Then 'format is zz/zz/zz
m = Int(Val(Left(z, 2)))
d = Int(Val(Mid(z, 4, 2)))
y = Int(Val(Right(z, 2)))
If y < zeroyear Then
y = y + 2000
Else
y = y + 1900
End If
Else 'format is zzzz/z/z
m = Int(Val(Right(z, 1)))
d = Int(Val(Mid(z, 6, 1)))
y = Int(Val(Left(z, 4)))
End If
Case 9 'z/zz/zzzz or zzzz/z/zz or zz/z/zzzz or zzzz/zz/z
If pos1 = 2 Then 'format is z/zz/zzzz
m = Int(Val(Left(z, 1)))
d = Int(Val(Mid(z, 3, 2)))
y = Int(Val(Right(z, 4)))
ElseIf pos1 = 3 Then 'format is zz/z/zzzz
m = Int(Val(Left(z, 2)))
d = Int(Val(Mid(z, 4, 1)))
y = Int(Val(Right(z, 4)))
ElseIf pos2 = 7 Then 'format is zzzz/z/zz
m = Int(Val(Mid(z, 6, 1)))
d = Int(Val(Right(z, 2)))
y = Int(Val(Left(z, 4)))
Else 'format is zzzz/zz/z
m = Int(Val(Mid(z, 6, 2)))
d = Int(Val(Right(z, 1)))
y = Int(Val(Left(z, 4)))
End If
Case 10 'zz/zz/zzzz or zzzz/zz/zz
If pos1 = 3 Then
m = Int(Val(Left(z, 2)))
d = Int(Val(Mid(z, 4, 2)))
y = Int(Val(Right(z, 4)))
Else
m = Int(Val(Mid(z, 6, 2)))
d = Int(Val(Right(z, 2)))
y = Int(Val(Left(z, 4)))
End If
Case Else
'A non-useable input, provide messagebox
Exit Function
End Select
'change d from integer to double to satisfy input requirement of function
d2 = d
GenDate = date_to_jd(y, m, d2)
End Function
