05-22-2022, 05:14 PM
Just a small program for finding out what day of the week an event occurred/will occur on. Choose from Birthday, Western Christmas Day or any random day you choose. Unlike the other stuff I've posted on here to date, this is a fresh build. It Uses a tiny (edited) portion of the Time utility I posted recently. FWIW error trapping the INPUTs was a pain.
WhatDay.BAS
Have fun.
TR
WhatDay.BAS
Code: (Select All)
Const TRUE% = -1
Const FALSE% = 0
Dim Choice$, AYear%, AMonth%, ADay%, DayNumber%, OutString$, YearPrompt$
Print
Print "What date do you want to know the day of the week for?"
Print "Your Birthday, Western Christmas Day or some other date?"
Print "The year chosen must be be between 1900 and 2099 inclusive."
Print
Print "Choose 'B', 'C' or 'O'"
Print
Do
Choice$ = UCase$(InKey$)
Loop Until ((Choice$ = "B") Or (Choice$ = "C") Or (Choice$ = "O"))
Print
Print
If Choice$ = "C" Then
YearPrompt$ = "Which Year's Christmas are you interested in? (In #### format) -> "
Do
Print YearPrompt$;
Input AYear%
If ((AYear% < 1900) Or (AYear% > 2099)) Then
Print
Print "Sorry, but that year is outside the scope of this program."
Print
End If
Loop Until ((AYear% >= 1900) And (AYear% <= 2099))
DayNumber% = DayOfWeek%(AYear%, 12, 25)
OutString$ = "In " + LTrim$(Str$(AYear%)) + " Christmas Day fell/will fall on a "
Print
Print
Else
If Choice$ = "B" Then
YearPrompt$ = "Which Year's Birthday are you interested in? (In #### format) -> "
Else
YearPrompt$ = "Which particular Year's Date are you interested in? (In #### format) -> "
End If
Do
Print YearPrompt$;
Input AYear%
If ((AYear% < 1900) Or (AYear% > 2099)) Then
Print
Print "Sorry, but that year is outside the scope of this program."
Print
End If
Loop Until ((AYear% >= 1900) And (AYear% <= 2099))
Do
Input "And the Month Number? (1 to 12) ", AMonth%
If ((AMonth% < 1) Or (AMonth% > 12)) Then
Print
Print "Sorry, but that Month does not exist."
Print
End If
Loop Until ((AMonth% > 0) And (AMonth% < 13))
Do
Do
Input "And finally the Day Number? (1 to 31) ", ADay%
If ((ADay% < 1) Or (ADay% > 31)) Then
Print
Print "Sorry, but that Day does not exist."
Print
End If
Loop Until ((ADay% >= 1) And (ADay% <= 31))
Loop Until (DayMonthMatch%(AYear%, AMonth%, ADay%) = TRUE%)
DayNumber% = DayOfWeek%(AYear%, AMonth%, ADay%)
Print
Print
If Choice$ = "B" Then
OutString$ = "In " + LTrim$(Str$(AYear%)) + " Your Birthday fell/will fall on a "
Else
OutString$ = "The " + LTrim$(Str$(ADay%)) + Suffix$(ADay%) + " of " + StringMonth$(AMonth%) + " in " + LTrim$(Str$(AYear%)) + ", is/was on a "
End If
End If
Print OutString$ + StringWeekDay$(DayNumber%) + "."
End
Function DayMonthMatch% (Year%, Month%, Day%)
Dim IsValid%
Select Case Month%
Case 1, 3, 5, 7, 8, 10, 12
IsValid% = TRUE%
Case 2
If ((((Year% Mod 400) = 0) And (Day% > 29)) Or (((Year% Mod 4) = 0) And ((Year% Mod 100) <> 0) And (Day% > 29))) Then
IsValid% = FALSE%
ElseIf Day% > 28 Then
IsValid% = FALSE%
Else
IsValid% = TRUE%
End If
Case 4, 6, 9, 11
If Day% > 30 Then
IsValid% = FALSE%
Else
IsValid% = TRUE%
End If
End Select
DayMonthMatch% = IsValid%
End Function
Function DayOfWeek% (Year%, Month%, Day%)
Dim Year$, Code%
Year$ = Str$(Year%)
Code% = Val(Right$(Year$, 2))
Code% = (Code% + (Code% \ 4)) Mod 7
Code% = Code% + Val(Mid$("033614625035", Month%, 1))
If (Year% >= 2000) Then
Code% = Code% + 6
End If
If (((Year% Mod 400) = 0) And (Month% > 2)) Then
Code% = Code% + 1
ElseIf (((Year% Mod 4) = 0) And ((Year% Mod 100) <> 0) And (Month% > 2)) Then
Code% = Code% + 1
End If
Code% = Code% + Day%
DayOfWeek% = 1 + (Code% Mod 7)
End Function
Function StringWeekDay$ (DayCode%)
Dim DayString$
Select Case DayCode%
Case 1
DayString$ = "Sunday"
Case 2
DayString$ = "Monday"
Case 3
DayString$ = "Tuesday"
Case 4
DayString$ = "Wednesday"
Case 5
DayString$ = "Thursday"
Case 6
DayString$ = "Friday"
Case 7
DayString$ = "Saturday"
End Select
StringWeekDay$ = DayString$
End Function
Function StringMonth$ (MonthCode%)
Dim MonthString$
Select Case MonthCode%
Case 1
MonthString$ = "January"
Case 2
MonthString$ = "February"
Case 3
MonthString$ = "March"
Case 4
MonthString$ = "April"
Case 5
MonthString$ = "May"
Case 6
MonthString$ = "June"
Case 7
MonthString$ = "July"
Case 8
MonthString$ = "August"
Case 9
MonthString$ = "September"
Case 10
MonthString$ = "October"
Case 11
MonthString$ = "November"
Case 12
MonthString$ = "December"
End Select
StringMonth$ = MonthString$
End Function
Function Suffix$ (MonthDay%)
Dim TempString$
If ((MonthDay% > 3) And (MonthDay% < 21)) Then
TempString$ = "th"
Else
TempMonthDay% = MonthDay% Mod 10
Select Case TempMonthDay%
Case 0
TempString$ = "th"
Case 1
TempString$ = "st"
Case 2
TempString$ = "nd"
Case 3
TempString$ = "rd"
Case Else
TempString$ = "th"
End Select
End If
Suffix$ = TempString$
End FunctionHave fun.
TR
