File "Julian.inc"
Path: /iCalendar Generator/inc/Julian.inc
File size: 9.61 KB
MIME-type:
Charset: 8 bit
'--------------------------------------------------------------------------------
' Globals
'--------------------------------------------------------------------------------
GLOBAL shortWeekDay() AS STRING ' (1 TO 7) : e.g. Mon, Tue, Wed...
GLOBAL longWeekDay() AS STRING ' (1 TO 7) : e.g. Monday, Tuesday...
GLOBAL shortMonthName() AS STRING ' (1 TO 12) : e.g. JAN, FEB, MAR...
GLOBAL longMonthName() AS STRING ' (1 TO 12) : e.g. January, February...
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Function DateStr returns a date according to a format string
'--------------------------------------------------------------------------------
' w short weekday name (3 characters) e.g. Mon, Tue, Wed...
' wd full weekday name e.g. Monday, Tuesday...
' wn week number
' d short day number (1 or 2 digits)
' dd long day number (2 digits, prefixed with '0')
' m short month number (1 or 2 digits)
' mm long month number (2 digits, prefixed with '0')
' M short month name (3 characters) e.g. JAN, FEB, MAR...
' MM long month name e.g. January, February...
' yy short year number (2 digits)
' yyyy long year number (4 digits)
'--------------------------------------------------------------------------------
FUNCTION DateStr(BYVAL year AS LONG, _
BYVAL month AS LONG, _
BYVAL day AS LONG, _
BYVAL format AS STRING) AS STRING
LOCAL i, j, k AS LONG
LOCAL wn, dow AS LONG
LOCAL r AS STRING
REDIM PRESERVE shortWeekDay(1 TO 7)
REDIM PRESERVE longWeekDay(1 TO 7)
REDIM PRESERVE shortMonthName(1 TO 12)
REDIM PRESERVE longMonthName(1 TO 12)
IF shortWeekDay(1) = "" THEN ARRAY ASSIGN shortWeekDay() _
= "lun", "mar", "mer", "jeu", "ven", "sam", "dim"
IF longWeekDay(1) = "" THEN ARRAY ASSIGN longWeekDay() _
= "lundi", "mardi", "mercredi", "jeudi", "vendredi", "samedi", "dimanche"
IF shortMonthName(1) = "" THEN ARRAY ASSIGN shortMonthName() _
= "JAN", "FEV", "MAR", "AVR", "MAI", "JUN", "JUL", "AOU", "SEP", "OCT", "NOV", "DEC"
IF longMonthName(1) = "" THEN ARRAY ASSIGN longMonthName() _
= "janvier", "fvrier", "mars", "avril", "mai", "juin", "juillet", _
"aot", "septembre", "octobre", "novembre", "dcembre"
wn = WeekNb(year, month, day)
dow = DayOfWeek(year, month, day)
' Protect keywords with curled braces
r = format
REPLACE "wn" WITH "{WN}" IN r ' week number
REPLACE "wd" WITH "{LW}" IN r ' long weekday
REPLACE "w" WITH "{SW}" IN r ' short weekday
REPLACE "dd" WITH "{LD}" IN r ' long day number
REPLACE "d" WITH "{SD}" IN r ' short day number
REPLACE "mm" WITH "{L#}" IN r ' long month number
REPLACE "m" WITH "{S#}" IN r ' short month number
REPLACE "MM" WITH "{LO}" IN r ' long month name
REPLACE "M" WITH "{SH}" IN r ' short month name
REPLACE "yyyy" WITH "{Y4}" IN r ' year on 4 digits
REPLACE "YYYY" WITH "{Y4}" IN r ' be a little permissive: YYYY=yyyy
REPLACE "yy" WITH "{Y2}" IN r ' year on 2 digits
REPLACE "YY" WITH "{Y2}" IN r ' be a little permissive: YY=yy
' Now, replace protected keywords with their values
REPLACE "{WN}" WITH TRIM$(STR$(wn)) IN r
REPLACE "{LW}" WITH longWeekDay(dow) IN r
REPLACE "{SW}" WITH shortWeekDay(dow) IN r
REPLACE "{LD}" WITH FORMAT$(day, "00") IN r
REPLACE "{SD}" WITH TRIM$(STR$(day)) IN r
REPLACE "{L#}" WITH FORMAT$(month, "00") IN r
REPLACE "{S#}" WITH TRIM$(STR$(month)) IN r
REPLACE "{LO}" WITH longMonthName(month) IN r
REPLACE "{SH}" WITH shortMonthName(month) IN r
REPLACE "{Y4}" WITH TRIM$(STR$(year)) IN r
REPLACE "{Y2}" WITH RIGHT$(TRIM$(STR$(year)), 2) IN r
FUNCTION = r
END FUNCTION
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Function Julian - returns Julian Day Number (JDN)
' Actually it counts days elapsed since "11/25/-4713" (= Nov. 25, 4714 BCE)
'--------------------------------------------------------------------------------
FUNCTION Julian(BYVAL year AS LONG, _
BYVAL month AS LONG, _
BYVAL day AS LONG) AS LONG
LOCAL Days AS LONG, yearsBC AS LONG, yearsAD AS LONG
IF month < 3 THEN ' January or February?
month = month + 12 ' 13th or 14th month ....
DECR year ' .... of prev. year
END IF
yearsBC = 4714 - 1 ' 4713 BC thru 1 BC
yearsAD = year - 1 ' 1 AD thru (year of date minus 1)
Days = INT((yearsBC + yearsAD) * 365.25) ' calculate days in years
Days = Days - (year \ 100) ' substract century leapdays
Days = Days + (year \ 400) ' re-add valid ones
Days = Days + INT(30.6 * (month - 1) + .2) ' days in months elapsed (+ adjustment)
FUNCTION = Days + day ' days in month of date
END FUNCTION
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Function Julian2Date - returns a date "yyyymmdd" from a Julian Day Number (JDN)
'--------------------------------------------------------------------------------
FUNCTION Julian2Date(BYVAL jd AS LONG) AS STRING
LOCAL q, r, s, t, u, v, d, cond, m, y AS LONG
LOCAL yr, mo, da AS STRING
q = INT((jd / 36524.25) - 51.12264)
r = jd + q - INT(q / 4) + 1
s = r + 1524
t = INT((s / 365.25) - 0.3343)
u = INT(t * 365.25)
v = INT((s - u) / 30.61)
d = s - u - INT(v * 30.61)
IF v > 13.5 THEN cond = -1 ELSE cond = 0
m = (v - 1) + 12 * cond
IF m < 2.5 THEN cond = -1 ELSE cond = 0
y = t - cond - 4716
yr = TRIM$(STR$(y)) : WHILE LEN(yr) < 4 : yr = "0" + yr : WEND
mo = TRIM$(STR$(m)) : IF LEN(mo) < 2 THEN mo = "0" + mo
da = TRIM$(STR$(d)) : IF LEN(da) < 2 THEN da = "0" + da
FUNCTION = yr + mo + da
END FUNCTION
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Function JulianDayOfWeek returns day of the week (Mon=1..Sun=7)
'--------------------------------------------------------------------------------
FUNCTION JulianDayOfWeek(JDN AS LONG) AS BYTE
FUNCTION = JDN MOD 7 + 1
END FUNCTION
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Function DayOfWeek same than above with different input format
'--------------------------------------------------------------------------------
FUNCTION DayOfWeek(BYVAL year AS LONG, _
BYVAL month AS LONG, _
BYVAL day AS LONG) AS BYTE
LOCAL JD AS LONG
JD = Julian(year, month, day)
FUNCTION = JulianDayOfWeek(JD)
END FUNCTION
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Function WeekOne returns first day of first week for the given year
' Note: This is only a helper function for WeekNbStr
'--------------------------------------------------------------------------------
FUNCTION WeekOne(BYVAL year AS LONG) AS LONG
LOCAL temp AS LONG, Thursday AS BYTE
Thursday = 4
temp = Julian(year,1,1) - 1 ' Dec. 31 of prev. year
DO
INCR temp
LOOP UNTIL JulianDayOfWeek(temp) = Thursday ' until first Thursday of year is found
FUNCTION = temp - 3 ' first day of first week is a Monday
END FUNCTION
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Function WeekNb returns ISO-proof weeknumber for a date
'--------------------------------------------------------------------------------
FUNCTION WeekNb(BYVAL year AS LONG, _
BYVAL month AS LONG, _
BYVAL day AS LONG) AS BYTE
LOCAL FirstDay AS LONG, FinalDay AS LONG, ToDay AS LONG
FirstDay = WeekOne(year)
FinalDay = WeekOne(year + 1) - 1
ToDay = Julian(year, month, day)
SELECT CASE ToDay
CASE < FirstDay
' it is week 52 or 53, but which one?
' therefore we need week one of previous year as a starting point
FirstDay = WeekOne(year - 1)
CASE > FinalDay
' there is only one possibility: week nbr 1
FUNCTION = 1
EXIT FUNCTION
END SELECT
FUNCTION = ((ToDay - FirstDay) \ 7) + 1
END FUNCTION
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Function EasterDate returns Easter day in March (or in April if > 31) for a year
'--------------------------------------------------------------------------------
FUNCTION EasterDate(BYVAL DDPyear AS LONG) AS LONG
LOCAL year, g, c, c4, e, h, k, p, q, i, b, j1, j2 AS LONG
year = DDPyear
g = year MOD 19
c = INT(year / 100)
c4 = INT(c / 4)
e = INT((8 * c + 13) / 25)
h = (19 * g + c - c4 - e + 15) MOD 30
k = INT(h / 28)
p = INT(29 / (h + 1))
q = INT(21 - g) / 11
i = (k * p * q - 1) * k + h
b = INT(year / 4) + year
j1 = b + i + 2 + c4 - c
j2 = j1 MOD 7
FUNCTION = 28 + i - j2
END FUNCTION
'--------------------------------------------------------------------------------