Code archives/Miscellaneous/Julian Days conversion

This code has been declared by its author to be Public Domain code.

Download source code

Julian Days conversion by Imphenzia
(Posted 24 years ago)
This is a simple method of converting Blitz dates into "Julian Days". Using this format you can convert any two dates into Julian Days and then simply substract the two resulting numbers to get the number of days between those dates without having to worry about days per month, leap years and all the rest! Can for example be used for calculating trial periods.
Open in online IDE
Dim Months$(12)
Months(1)="JAN":Months(2)="FEB":Months(3)="MAR":Months(4)="APR":Months(5)="MAY":Months(6)="JUN": Months(7)="JUL": Months(8)="AUG": Months(9)="SEP": Months(10)="OCT": Months(11)="NOV": Months(12)="DEC"

Print "Days between today and 23 Aug 2008: " + (JulianDays("23 AUG 2008") - JulianDays(CurrentDate()))

Function FindMonth(fm$)
  For i=1 To 12
  If Upper(fm$)=months$(i) Then Return i
  Next
End Function

Function JulianDays(txt$)
  d=Int(Left(txt$,2))
  m=Int(FindMonth(Mid(txt$,4,3)))
  y=Int(Right(txt$,4))
  jd=( 1461 * ( y + 4800 + ( m - 14 ) / 12 ) ) / 4 + ( 367 * ( m - 2 - 12 * ( ( m - 14 ) / 12 ) ) ) / 12 - ( 3 * ( ( y + 4900 + ( m - 14 ) / 12 ) / 100 ) ) / 4 + d - 32075
  Return jd
End Function

Comments

TAS
(Posted 22 years ago)
The code below is public domain and is used to convert a Blitz date string to MS Excel type date number (1/1/1900 =day 1) and back.


Function E2Day$(ed)

y%=Floor(ed/365.25)
r%=ed-Floor(y*365+Floor((y+3)/4))
Y=Y+1900

m=Int(r/30)
If (r-m*30)<1 Then m=m-1

If (y Mod 4) =0 Then
;leap year
If r<32 Then
Return Str$(r)+" JAN "+Y
ElseIf r<61
Return Str$(r-31)+" FEB "+Y
ElseIf r<92
Return Str$(r-60)+" MAR "+Y
ElseIf r<122
Return Str$(r-91)+" APR "+Y
ElseIf r<153
Return Str$(r-121)+" MAY "+Y
ElseIf r<183
Return Str$(r-152)+" JUN "+Y
ElseIf r<214
Return Str$(r-182)+" JUL "+Y
ElseIf r<245
Return Str$(r-213)+" AUG "+Y
ElseIf r<275
Return Str$(r-244)+" SEP "+Y
ElseIf r<306
Return Str$(r-274)+" OCT "+Y
ElseIf r<336
Return Str$(r-305)+" NOV "+Y
ElseIf r<367
Return Str$(r-335)+" DEC "+Y
Else
Return "LERROR"
EndIf
Else
If r<32
Return Str$(r)+" JAN "+Y
ElseIf r<60
Return Str$(r-31)+" FEB "+Y
ElseIf r<91
Return Str$(r-59)+" MAR "+Y
ElseIf r<121
Return Str$(r-90)+" APR "+Y
ElseIf r<152
Return Str$(r-120)+" MAY "+Y
ElseIf r<182
Return Str$(r-151)+" JUN "+Y
ElseIf r<213
Return Str$(r-181)+" JUL "+Y
ElseIf r<244
Return Str$(r-212)+" AUG "+Y
ElseIf r<274
Return Str$(r-243)+" SEP "+Y
ElseIf r<305
Return Str$(r-273)+" OCT "+Y
ElseIf r<335
Return Str$(r-304)+" NOV "+Y
ElseIf r<366
Return Str$(r-334)+" DEC "+Y
Else
Stop
Return "NLERROR"
EndIf
EndIf

End Function


Function EDATE(txt$)
;Calculates a EXCEL type "Julian Date"
;day 1 = 1/1/1900
;assumes DD_MMM_YYYY
d=Int(Left(txt$,2))
m=Int(FindMonth(Mid(txt$,4,3)))
y=Int(Right(txt$,4))

If y>1899 Then
y=y-1900
ElseIf y>99 Then
Return 0
Else
Return 0
EndIf

;(y+3)/4 adds leap day
r%=d+y*365+Floor((y+3)/4)

If (y Mod 4)=0 Then
;extra day if leap year and month is not Feb or Jan
If m>2 Then r=r+1
EndIf

Select m
Case 1 :Return r
Case 2 :Return r+31
Case 3 :Return r+59
Case 4 :Return r+90
Case 5 :Return r+120
Case 6 :Return r+151
Case 7 :Return r+181
Case 8 :Return r+212
Case 9 :Return r+243
Case 10 :Return r+273
Case 11 :Return r+304
Case 12 :Return r+334
Default :Return 0
End Select

End Function


Function FindMonth(fm$)
Select Upper$(fm$)
Case "JAN": Return 1
Case "FEB": Return 2
Case "MAR": Return 3
Case "APR": Return 4
Case "MAY": Return 5
Case "JUN": Return 6
Case "JUL": Return 7
Case "AUG": Return 8
Case "SEP": Return 9
Case "OCT": Return 10
Case "NOV": Return 11
Case "DEC": Return 12
Default
Return 0
End Select
End Function

Code Archives Forum