All the discussion about Easter prompted me to do something I've been
wanting to do for a long time - convert my VB6 CalWin program (see
my website) to work with PowerBASIC. The PB/CC program is below
(I have a PBWin version, if anyone wants it, but it can't write a calendar
to the screen or disk). I don't particularly like the user interface, but
it
came from a QuickBASIC version I wrote back in the '80s, and I didn't
bother to rewrite it. Note that there is a handy place to put your own
special dates like birthdays, anniversaries and such, around line 190. It
is also easy to change the holidays (the current ones are typical U.S.
holidays) to your liking. No effort was made to adjust the holidays for
years before they were made what they are now, but that would be
easy to do, if you know when and how the holidays changed. I've also
thought about putting the holiday definitions in an easily modified text
file and processing it at runtime.
--
Judson McClendon judmc@[EMAIL PROTECTED]
(remove zero)
Sun Valley Systems http://sunvaley.com
"For God so loved the world that He gave His only begotten Son, that
whoever believes in Him should not perish but have everlasting life."
'
' **************************************************
' * *
' * Calendar.bas *
' * *
' * Prints One Page Calendars *
' * *
' * Version 4.0 10-20-2007 *
' * *
' * Judson D. McClendon *
' * Sun Valley Systems *
' * 4522 Shadow Ridge Pkwy *
' * Pinson, AL 35126-2192 *
' * 205-680-0460 *
' * *
' **************************************************
'
#COMPILE EXE
#DIM ALL
'
' Declare Functions/Subroutines
'
DECLARE FUNCTION GetNumber (MaxSize AS LONG) AS LONG
DECLARE FUNCTION GetWeekday (Month AS LONG, Day AS LONG, Year AS LONG) AS
LONG
DECLARE FUNCTION IsHoliday (Month AS LONG, Day AS LONG) AS LONG
DECLARE SUB AddDays (Days AS LONG, Desc AS STRING)
DECLARE SUB CalculateHolidays ()
DECLARE SUB Initialize ()
DECLARE SUB MakeHoliday (Day AS LONG, DayOfWeek AS LONG, Month AS LONG,
Desc AS STRING)
DECLARE SUB CalendarToPrint ()
DECLARE SUB CalendarToDisk ()
DECLARE SUB CalendarToScreen ()
DECLARE SUB StoreHoliday (HMonth AS LONG, HDay AS LONG, HDesc AS STRING)
DECLARE SUB SubtractDays (Days AS LONG, Desc AS STRING)
MACRO CONST = MACRO
CONST FALSE = 0
CONST TRUE = NOT FALSE
CONST MaxHolidays = 42
CONST Sunday = 0
CONST Monday = 1
CONST Tuesday = 2
CONST Wednesday = 3
CONST Thursday = 4
CONST Friday = 5
CONST Saturday = 6
CONST Jan = 1
CONST Feb = 2
CONST Mar = 3
CONST Apr = 4
CONST May = 5
CONST Jun = 6
CONST Jul = 7
CONST Aug = 8
CONST Sep = 9
CONST Oct = 10
CONST Nov = 11
CONST Dec = 12
CONST FirstWeek = 1
CONST SecondWeek = 8
CONST ThirdWeek = 15
CONST FourthWeek = 22
CONST LastWeek30 = 24
CONST LastWeek31 = 25
CONST BeginText = 21
'
' Month Table
'
TYPE MonthDef
LName AS STRING * 19
SName AS STRING * 3
MaxDays AS LONG
DayOf AS LONG
Weekday AS LONG
END TYPE
GLOBAL MonthTab() AS MonthDef
'
' Holiday Table
'
TYPE HolidayDef
CDate AS LONG
Month AS LONG
Day AS LONG
Desc AS STRING * 18
END TYPE
GLOBAL HolidayTab() AS HolidayDef
'
' Miscellaneous Defines
'
GLOBAL Month AS LONG
GLOBAL Day AS LONG
GLOBAL Year AS LONG
GLOBAL COPY AS LONG
GLOBAL Holidays AS LONG
GLOBAL WhereTo AS STRING * 1
GLOBAL Printer AS STRING * 1
GLOBAL Legend AS STRING
GLOBAL StrYear AS STRING
FUNCTION PBMAIN ()
CALL Initialize
CALL CalculateHolidays
SELECT CASE WhereTo
CASE "P"
CALL CalendarToPrint
CASE "D"
CALL CalendarToDisk
CASE ELSE
CALL CalendarToScreen
END SELECT
WAITSTAT
END FUNCTION
'
' **************************************************
' * *
' * Add Days to Month, Day *
' * *
' **************************************************
'
SUB AddDays (Days AS LONG, Desc AS STRING)
DIM MonthTab(1 TO 12) AS GLOBAL MonthDef
Day = Day + Days
WHILE (Day > MonthTab(Month).MaxDays)
Day = Day - MonthTab(Month).MaxDays
Month = Month + 1
WEND
CALL StoreHoliday(Month, Day, Desc)
END SUB
'
' **************************************************
' * *
' * Set up Holiday Table *
' * *
' **************************************************
'
SUB CalculateHolidays
DIM HolidayTab(0 TO MaxHolidays) AS GLOBAL HolidayDef
'
' Easter Calculation Work Variables
'
LOCAL GoldenNo AS LONG
LOCAL SundayCorr AS LONG
LOCAL Century AS LONG
LOCAL LeapCent AS LONG
LOCAL LunarCorr AS LONG
LOCAL Epact AS LONG
LOCAL FullMoon AS LONG
Holidays = 0 ' No Holidays loaded
HolidayTab(0).CDate = 0 ' Load entry 0 with dummy for insert
'
' Holidays With Fixed Dates
'
CALL StoreHoliday(Jan, 1, "New Years Day")
CALL StoreHoliday(Feb, 2, "Ground Hog Day")
CALL StoreHoliday(Feb, 12, "Lincoln")
CALL StoreHoliday(Feb, 14, "St. Valentine")
CALL StoreHoliday(Mar, 17, "St. Patrick")
CALL StoreHoliday(Apr, 1, "All Fools Day")
CALL StoreHoliday(Jun, 14, "Flag Day")
CALL StoreHoliday(Jul, 4, "Independence Day")
CALL StoreHoliday(Oct, 31, "Halloween")
CALL StoreHoliday(Nov, 11, "Veterans Day")
CALL StoreHoliday(Dec, 25, "Christmas")
'
' Insert your own special dates here as in the above statements.
' For example:
'
' CALL StoreHoliday(Jun, 22, "Bob Jones")
' CALL StoreHoliday(Aug, 14, "Joe & Sue Wilson")
'
' *******************************************************
' *** Replace these lines with your own special dates ***
' *******************************************************
'
' Holidays Occuring in Specific Weeks
'
CALL MakeHoliday(ThirdWeek, Monday, Jan, "M.L. King")
CALL MakeHoliday(ThirdWeek, Monday, Feb, "Washington")
CALL MakeHoliday(SecondWeek, Sunday, May, "Mother's Day")
CALL MakeHoliday(LastWeek31, Monday, May, "Memorial Day")
CALL MakeHoliday(ThirdWeek, Sunday, Jun, "Father's Day")
CALL MakeHoliday(FirstWeek, Monday, Sep, "Labor Day")
CALL MakeHoliday(SecondWeek, Monday, Oct, "Columbus Day")
CALL MakeHoliday(SecondWeek, Tuesday, Nov, "Election Day")
CALL MakeHoliday(FourthWeek, Thursday, Nov, "Thanksgiving")
'
' *** Easter Related Holidays ***
'
'
' Easter
'
GoldenNo = (Year MOD 19) + 1
Century = (Year \ 100) + 1
LeapCent = ((3 * Century) \ 4) - 12
LunarCorr = ((8 * Century + 5) \ 25) - 5
SundayCorr = ((5 * Year) \ 4) - LeapCent - 10
Epact = ABS(11 * GoldenNo + 20 + LunarCorr - LeapCent) MOD 30
IF ((Epact = 25) AND (GoldenNo > 11)) OR (Epact = 24) THEN
Epact = Epact + 1
END IF
FullMoon = 44 - Epact
IF (FullMoon < 21) THEN
FullMoon = FullMoon + 30
END IF
Day = FullMoon + 7 - ((SundayCorr + FullMoon) MOD 7)
IF (Day > 31) THEN
Day = Day - 31
Month = 4
ELSE
Month = 3
END IF
CALL StoreHoliday(Month, Day, "Easter")
CALL SubtractDays( 2, "Good Friday")
CALL SubtractDays( 5, "Palm Sunday")
CALL SubtractDays(39, "Ash Wednesday")
CALL AddDays(95, "Pentecost")
END SUB
'
' **************************************************
' * *
' * Accept a Number of MaxSize Digits from KBD *
' * *
' **************************************************
'
FUNCTION GetNumber (MaxSize AS LONG) AS LONG
LOCAL Number AS LONG
LOCAL Row AS LONG
LOCAL Col AS LONG
LOCAL SIZE AS LONG
LOCAL Char AS STRING
Row = CURSORY
Col = CURSORX
SIZE = 0
Number = 0
DO
DO
Char = INKEY$
LOOP WHILE (Char = "")
IF (Char >= "0" AND Char <= "9" AND SIZE < MaxSize) THEN
IF (SIZE > 0 OR Char <> "0") THEN
Number = Number * 10 + VAL(Char)
SIZE = SIZE + 1
PRINT Char;
Col = Col + 1
END IF
ELSEIF (Char = CHR$(8) AND SIZE > 0) THEN
Number = INT(Number / 10)
SIZE = SIZE - 1
Col = Col - 1
LOCATE Row, Col
PRINT " ";
LOCATE Row, Col
END IF
LOOP WHILE (Char <> CHR$(13))
IF (Number = 0) THEN
PRINT "0";
END IF
GetNumber = Number
END FUNCTION
'
' **************************************************
' * *
' * Calc Day of Week using Zeller's Congruence *
' * *
' **************************************************
'
FUNCTION GetWeekday (Month AS LONG, Day AS LONG, Year AS LONG) AS LONG
LOCAL M AS LONG
LOCAL D AS LONG
LOCAL Y AS LONG ' Need extra precision
IF (Month < Mar) THEN ' Treat Jan & Feb as 13th & 14th month of prev
year
M = Month + 12
D = Day
Y = Year - 1
ELSE
M = Month
D = Day
Y = Year
END IF
GetWeekday = (D + M * 2 + (M + 1) * 3 \ 5 + Y + Y \ 4 - Y \ 100 + Y \
400 + 1) MOD 7
END FUNCTION
'
' **************************************************
' * *
' * Initialize tables & get specs from user *
' * *
' **************************************************
'
SUB Initialize
DIM MonthTab(1 TO 12) AS GLOBAL MonthDef
LOCAL I AS LONG
LOCAL DataPtr AS LONG
CLS
PRINT TAB(BeginText); "+-------------------------------+"
PRINT TAB(BeginText); "| |"
PRINT TAB(BeginText); "| CALENDAR |"
PRINT TAB(BeginText); "| |"
PRINT TAB(BeginText); "| Version 4.0 |"
PRINT TAB(BeginText); "| |"
PRINT TAB(BeginText); "| Judson D. McClendon |"
PRINT TAB(BeginText); "| 4522 Shadow Ridge Pkwy |"
PRINT TAB(BeginText); "| Pinson, AL 35126-2192 |"
PRINT TAB(BeginText); "| 205-680-0460 |"
PRINT TAB(BeginText); "| |"
PRINT TAB(BeginText); "+-------------------------------+"
PRINT
DATA " J A N U A R Y ", "Jan", "31"
DATA " F E B R U A R Y ", "Feb", "28"
DATA " M A R C H ", "Mar", "31"
DATA " A P R I L ", "Apr", "30"
DATA " M A Y ", "May", "31"
DATA " J U N E ", "Jun", "30"
DATA " J U L Y ", "Jul", "31"
DATA " A U G U S T ", "Aug", "31"
DATA " S E P T E M B E R ", "Sep", "30"
DATA " O C T O B E R ", "Oct", "31"
DATA " N O V E M B E R ", "Nov", "30"
DATA " D E C E M B E R ", "Dec", "31"
DataPtr = 0
FOR Month = 1 TO 12
INCR DataPtr
MonthTab(Month).LName = READ$(DataPtr)
INCR DataPtr
MonthTab(Month).SName = READ$(DataPtr)
INCR DataPtr
MonthTab(Month).MaxDays = VAL(READ$(DataPtr))
NEXT Month
DO
LOCATE 15, BeginText + 23: PRINT SPC(10); ' Clear previous answer
LOCATE 15, BeginText: PRINT "Enter year since 1582: ";
Year = GetNumber(4)
IF (Year = 0) THEN
Year = VAL(RIGHT$(DATE$, 4))
END IF
LOCATE 15, BeginText + 22
PRINT Year; SPC(10);
LOOP UNTIL (Year > 1582)
IF (Year MOD 400 = 0) OR ((Year MOD 4 = 0) AND (Year MOD 100 <> 0))
THEN
MonthTab(2).MaxDays = 29
END IF
LOCATE 17, BeginText: PRINT "Write to Printer, Disk or Screen (P/D/S):
";
DO
WhereTo = UCASE$(INKEY$)
LOOP UNTIL (INSTR("PDS", WhereTo))
PRINT WhereTo;
StrYear = "=" + LTRIM$(RTRIM$(STR$(Year))) + "="
END SUB
'
' **************************************************
' * *
' * If Date in Holiday table return TRUE *
' * *
' **************************************************
'
FUNCTION IsHoliday (Month AS LONG, Day AS LONG) AS LONG
DIM HolidayTab(0 TO MaxHolidays) AS GLOBAL HolidayDef
LOCAL CDate AS LONG ' Composite Date for comparison
LOCAL L AS LONG ' Low Pointer
LOCAL H AS LONG ' High Pointer
LOCAL M AS LONG ' Mid Pointer
CDate = Month * 100 + Day
L = 1
H = Holidays
' Binary search Holiday table for CDate
DO
M = (L + H) \ 2
SELECT CASE (HolidayTab(M).CDate)
CASE < CDate
L = M + 1
CASE > CDate
H = M - 1
CASE ELSE
IsHoliday = TRUE
EXIT FUNCTION
END SELECT
LOOP UNTIL (L > H)
IsHoliday = FALSE
END FUNCTION
'
' **************************************************
' * *
' * Create Holiday for Nth Weekday of month *
' * and store it in Holiday table *
' * *
' **************************************************
'
SUB MakeHoliday (Day AS LONG, DayOfWeek AS LONG, Month AS LONG, Desc AS
STRING)
LOCAL Weekday AS LONG
Weekday = GetWeekday (Month, Day, Year)
Day = Day + ((DayOfWeek + 7 - Weekday) MOD 7)
CALL StoreHoliday(Month, Day, Desc)
END SUB
'
' **************************************************
' * *
' * Write Calendar & Holiday Table to Printer *
' * *
' **************************************************
'
SUB CalendarToPrint
DIM HolidayTab(0 TO MaxHolidays) AS GLOBAL HolidayDef
LOCAL WorkMonth AS LONG
LOCAL Week AS LONG
LOCAL TabCol AS LONG
LOCAL TabSize AS LONG
LOCAL Stp AS LONG
LOCAL I AS LONG
LOCAL J AS LONG
LOCAL Desc AS STRING
Legend = SPACE$(20 - LEN(StrYear))
FOR I = 1 TO LEN(StrYear)
Legend = Legend + MID$(StrYear, I, 1) + " "
NEXT I
XPRINT ATTACH DEFAULT
XPRINT FONT "Courier New", 24, 1
XPRINT Legend
XPRINT FONT "Courier New", 12, 1
XPRINT
FOR WorkMonth = 1 TO 10 STEP 3
XPRINT FONT "Courier New", 12, 1
TabCol = 1
FOR Month = WorkMonth TO WorkMonth + 2
' TAB((Month - WorkMonth) * 24 + 6)
TabSize = (Month - WorkMonth) * 24 + 6 - TabCol
XPRINT SPACE$(TabSize);
TabCol = TabCol + TabSize
XPRINT MonthTab(Month).LName;
TabCol = TabCol + SIZEOF(MonthTab(Month).LName)
NEXT Month
XPRINT
XPRINT FONT "Courier New", 12, 1
XPRINT
TabCol = 1
FOR Month = WorkMonth TO WorkMonth + 2
' TAB((Month - WorkMonth) * 24 + 6);
TabSize = (Month - WorkMonth) * 24 + 6 - TabCol
XPRINT SPACE$(TabSize);
TabCol = TabCol + TabSize
XPRINT "SU MO TU WE TH FR SA";
TabCol = TabCol + 20
Day = 1
MonthTab(Month).Weekday = GetWeekday(Month, Day, Year)
MonthTab(Month).DayOf = 1
NEXT Month
XPRINT FONT "Courier New", 12, 0
XPRINT
FOR Week = 1 TO 6
TabCol = 1
FOR Month = WorkMonth TO WorkMonth + 2
WHILE MonthTab(Month).DayOf <= MonthTab(Month).MaxDays AND
MonthTab(Month).Weekday < 7
TabSize = (Month - WorkMonth) * 24 +
MonthTab(Month).Weekday * 3 + 6 - TabCol
XPRINT SPACE$(TabSize);
TabCol = TabCol + TabSize
IF (IsHoliday (Month, MonthTab(Month).DayOf)) THEN
XPRINT COLOR %WHITE, %GRAY
XPRINT FONT "Courier New", 12, 1
XPRINT USING$("##", MonthTab(Month).DayOf);
XPRINT COLOR -1, -1
XPRINT FONT "Courier New", 12, 0
ELSE
XPRINT USING$("##", MonthTab(Month).DayOf);
END IF
TabCol = TabCol + 2
MonthTab(Month).DayOf = MonthTab(Month).DayOf + 1
MonthTab(Month).Weekday = MonthTab(Month).Weekday + 1
WEND
IF MonthTab(Month).Weekday > 6 THEN MonthTab(Month).Weekday =
0
NEXT Month
XPRINT
NEXT Week
XPRINT
NEXT WorkMonth
Stp = (Holidays + 2) \ 3
FOR I = 1 TO Stp
XPRINT " ";
FOR J = I TO Holidays STEP Stp
Month = HolidayTab(J).Month
Day = HolidayTab(J).Day
XPRINT USING$(" & ## &", MonthTab(Month).SName, Day,
HolidayTab(J).Desc);
NEXT J
XPRINT
NEXT I
XPRINT CLOSE
END SUB
'
' **************************************************
' * *
' * Write Calendar & Holiday Table to "year.CAL" *
' * *
' **************************************************
'
SUB CalendarToDisk
DIM HolidayTab(0 TO MaxHolidays) AS GLOBAL HolidayDef
LOCAL WorkMonth AS LONG
LOCAL Week AS LONG
LOCAL TabCol AS LONG
LOCAL TabSize AS LONG
LOCAL Stp AS LONG
LOCAL I AS LONG
LOCAL J AS LONG
LOCAL FileName AS STRING
LOCAL Desc AS STRING
Legend = SPACE$(39 - LEN(StrYear))
FOR I = 1 TO LEN(StrYear)
Legend = Legend + MID$(StrYear, I, 1) + " "
NEXT I
FileName = LTRIM$(RTRIM$(STR$(Year))) + ".CAL"
OPEN FileName FOR OUTPUT AS #1
PRINT #1, Legend
PRINT #1, ""
FOR WorkMonth = 1 TO 10 STEP 3
FOR Month = WorkMonth TO WorkMonth + 2
PRINT #1, TAB((Month - WorkMonth) * 24 + 6);
MonthTab(Month).LName;
NEXT Month
PRINT #1, ""
FOR Month = WorkMonth TO WorkMonth + 2
PRINT #1, TAB((Month - WorkMonth) * 24 + 6); "SU MO TU WE TH FR
SA";
Day = 1
MonthTab(Month).Weekday = GetWeekday(Month, Day, Year)
MonthTab(Month).DayOf = 1
NEXT Month
PRINT #1, ""
FOR Week = 1 TO 6
TabCol = 1
FOR Month = WorkMonth TO WorkMonth + 2
WHILE MonthTab(Month).DayOf <= MonthTab(Month).MaxDays AND
MonthTab(Month).Weekday < 7
TabSize = (Month - WorkMonth) * 24 +
MonthTab(Month).Weekday * 3 + 6 - TabCol
PRINT #1, SPC(TabSize);
TabCol = TabCol + TabSize
PRINT #1, USING$("##", MonthTab(Month).DayOf);
TabCol = TabCol + 2
MonthTab(Month).DayOf = MonthTab(Month).DayOf + 1
MonthTab(Month).Weekday = MonthTab(Month).Weekday + 1
WEND
IF MonthTab(Month).Weekday > 6 THEN MonthTab(Month).Weekday =
0
NEXT Month
PRINT #1, ""
NEXT Week
PRINT #1, ""
NEXT WorkMonth
Stp = (Holidays + 2) \ 3
FOR I = 1 TO Stp
PRINT #1, " ";
FOR J = I TO Holidays STEP Stp
Month = HolidayTab(J).Month
Day = HolidayTab(J).Day
PRINT #1, USING$(" & ## &", MonthTab(Month).SName, Day,
HolidayTab(J).Desc);
NEXT J
PRINT #1, ""
NEXT I
CLOSE #1
END SUB
'
' **************************************************
' * *
' * Write Calendar to Screen *
' * *
' **************************************************
'
SUB CalendarToScreen
DIM HolidayTab(0 TO MaxHolidays) AS GLOBAL HolidayDef
LOCAL WorkMonth AS LONG
LOCAL Week AS LONG
LOCAL TabCol AS LONG
CLS
PRINT StrYear;
FOR WorkMonth = 1 TO 10 STEP 3
FOR Month = WorkMonth TO WorkMonth + 2
Day = 1
MonthTab(Month).Weekday = GetWeekday(Month, Day, Year)
MonthTab(Month).DayOf = 1
NEXT Month
' PRINT
FOR Week = 1 TO 6
FOR Month = WorkMonth TO WorkMonth + 2
IF (Week = 2) THEN
TabCol = (Month - WorkMonth) * 25 + 4
PRINT TAB(TabCol); UCASE$(MonthTab(Month).SName);
END IF
WHILE MonthTab(Month).DayOf <= MonthTab(Month).MaxDays AND
MonthTab(Month).Weekday < 7
TabCol = (Month - WorkMonth) * 25 + MonthTab(Month).Weekday
* 3 + 7
PRINT TAB (TabCol); USING$("##", MonthTab(Month).DayOf);
MonthTab(Month).DayOf = MonthTab(Month).DayOf + 1
MonthTab(Month).Weekday = MonthTab(Month).Weekday + 1
WEND
IF MonthTab(Month).Weekday > 6 THEN MonthTab(Month).Weekday =
0
NEXT Month
IF (Month < 10) THEN
PRINT
END IF
NEXT Week
NEXT WorkMonth
END SUB
'
' **************************************************
' * *
' * Store Holiday in Holiday table in sequence *
' * by Month & Day. CDate field is a composit *
' * of Month and Day for easier comparison. *
' * *
' **************************************************
'
SUB StoreHoliday (HMonth AS LONG, HDay AS LONG, HDesc AS STRING)
DIM HolidayTab(0 TO MaxHolidays) AS GLOBAL HolidayDef
LOCAL CDate AS LONG
LOCAL I AS LONG
CDate = HMonth * 100 + HDay ' Composit Date for Comparison
I = Holidays ' Move Later Holidays up in
Table
WHILE (HolidayTab(I).CDate > CDate)
HolidayTab(I + 1) = HolidayTab(I)
I = I - 1
WEND
I = I + 1 ' Insert Holiday in Date
Sequence
HolidayTab(I).CDate = CDate
HolidayTab(I).Month = HMonth
HolidayTab(I).Day = HDay
HolidayTab(I).Desc = HDesc
Holidays = Holidays + 1 ' How Many Holidays in Table
END SUB
'
' **************************************************
' * *
' * Subtract Days from Month, Day *
' * *
' **************************************************
'
SUB SubtractDays (Days AS LONG, Desc AS STRING)
Day = Day - Days
WHILE (Day < 1)
Month = Month - 1
Day = Day + MonthTab(Month).MaxDays
WEND
CALL StoreHoliday(Month, Day, Desc)
END SUB
|
