08-14-2024, 12:21 AM
You can use this simple calendar maker for any month of any Gregorian year up to 9999 A.D.
You can also add some holidays or your own information to any day. Plus you can print them out and save them as .BMP pictures.
This one also asks if you want to print an entire year when you start.
You can also add some holidays or your own information to any day. Plus you can print them out and save them as .BMP pictures.
This one also asks if you want to print an entire year when you start.
Code: (Select All)
'This is my very first calendar making program!
'Thanks to the guys from the QB64 forum for the help: bplus, SMcNeill, euklides, and TempodiBasic!
'This is a freeware program like all my other programs and games, only free.
'Feel free to use this code in your own programs.
'This version has the ability to save your own month info and come back to it anytime.
'Calendar Maker 1 version made on Sept. 19, 2019.
'Calendar Maker 2 version made on Dec. 29, 2021.
'Calendar Maker 3 version made on June 13, 2022.
start:
_Title "Calendar Maker 3 - by SierraKen"
_Limit 1000
Dim newinfo$(50)
Dim dayinfo(50)
holidays = 0
dd = 0
leap = 0
m = 0
mm = 0
y = 0
yy = 0
w = 0
weekday = 0
days = 0
load = 0
Screen _NewImage(800, 600, 32)
Cls
Print: Print
Print " Monthly Calendar Maker 3"
Print: Print: Print
Print " By SierraKen"
Print
Print
Print " This program will make a calendar for the year and month you want."
Print " It will also name some U.S. holidays on their dates if you choose that."
Print " You also can add holidays or info to any day you wish with up to 12"
Print " letters, numbers, symbols, or spaces."
Print " This uses the Gregorian Calendar which became common practice in"
Print " England in 1753 and we still use it today."
Print
Print " First make a calendar, then if you want to save it as a .bmp file,"
Print " press the 'S' key and it will save it as the month and year for its name."
Print " For example, if you made a calendar for January 2022 and wish to save it,"
Print " press the 'S' key and it will save it as the picture file 1-2022.bmp"
Print " If you save the .bmp calendar, it will be put in the same directory as this program."
Print " If you wish to print your calendar on your printer, press 'P' once."
Print " Feel free to print each month as many times as you wish. They take up 1 page each."
Print " To switch to the last month use the left arrow key, to the next month the right arrow key."
Print " To make a different calendar without saving, press the Space Bar."
Print " Keyboard commands will be listed on the title bar of the window."
Print
Print " You also can print a whole year at once, without saving, with some U.S. holidays."
Print " You can draw or print something on the back of each month using a different program,"
Print " staple them together, punch a hole, and hang it on the wall. This does not include"
Print " saved month info."
Print
Print " New Feature: After you add your own month info in the beginning, it saves it"
Print " to a .txt file in the same directory and you can load that month's data anytime"
Print " by pressing L at any calendar month screen. You can only load one month at a time."
loops = 0
Print
Input " Press Enter To begin.", begin$
Cls
Print: Print: Print
Input " Would you like to print a whole year on your printer? (Y/N):", wholeyear$
If Left$(wholeyear$, 1) = "y" Or Left$(wholeyear$, 1) = "Y" Then m = 0: loops = 1
again1:
Print
Input " Type the year here (1753-9999): ", y
If y <> Int(y) Then Print "Cannot use decimals, try again.": GoTo again1:
If y < 1753 Or y > 9999 Then Print "The year can only be between 1753 and 9999, try again.": GoTo again1:
If loops = 1 Then
year = y
holidays = 1
Print " This will print 12 pages on your printer, one month each."
Print " This will not show any of your saved month information."
Print " But it will print out some U.S. holidays."
Print
Print " Press P to print the whole year on your printer."
Print " Press Esc key to go back to the beginning."
Do
ent$ = InKey$
If ent$ = "p" Or ent$ = "P" Then GoTo calculate:
If ent$ = Chr$(27) Then GoTo start:
Loop
End If
again2:
Print
Input " Type the month here (1-12): ", m
Print
If m <> Int(m) Then Print " Cannot use decimals, try again.": GoTo again2:
If m < 1 Or m > 12 Then Print " 1-12 only, try again.": GoTo again2:
Input " Do you want some U.S. holidays added (Y/N)?", hol$
If Left$(hol$, 1) = "y" Or Left$(hol$, 1) = "Y" Then holidays = 1
Print
Input " Do you want to add your own month info (Y/N)?", adding$
'It loops here 12 times when printing an entire year.--------------------------------------------------------
calculate:
info = 0
load = 0
calculate2:
monthname = 0
mn = 0
infos = 0
If loops = 1 Then m = m + 1
If m > 12 Then loops = 0: GoTo start:
dd = 0
leap = 0
w = 0
weekday = 0
days = 0
'Get the month name.
If m = 1 Then month$ = " January"
If m = 2 Then month$ = "February"
If m = 3 Then month$ = " March"
If m = 4 Then month$ = " April"
If m = 5 Then month$ = " May"
If m = 6 Then month$ = " June"
If m = 7 Then month$ = " July"
If m = 8 Then month$ = " August"
If m = 9 Then month$ = "September"
If m = 10 Then month$ = " October"
If m = 11 Then month$ = "November"
If m = 12 Then month$ = "December"
'Calculate to see if it's a Leap Year.
If m <> 2 Then GoTo nex:
If y / 400 = Int(y / 400) Then leap = 1: GoTo more:
If y / 4 = Int(y / 4) Then leap = 1
If y / 100 = Int(y / 100) Then leap = 0
'Get the number of days for each month.
more:
If leap = 1 Then days = 29
If leap = 0 Then days = 28
GoTo weekday:
nex:
If m = 1 Then days = 31
If m = 3 Then days = 31
If m = 4 Then days = 30
If m = 5 Then days = 31
If m = 6 Then days = 30
If m = 7 Then days = 31
If m = 8 Then days = 31
If m = 9 Then days = 30
If m = 10 Then days = 31
If m = 11 Then days = 30
If m = 12 Then days = 31
weekday:
'Set the month, year, and weekday variables to start with.
mm = m
yy = y
GetDay mm, dd, yy, weekday
If loops = 1 Then y = year
If Left$(adding$, 1) = "y" Or Left$(adding$, 1) = "Y" Then GoSub adding:
adding$ = ""
'This section makes the calendar graph.
make:
Screen _NewImage(800, 600, 32)
Cls
Line (0, 0)-(800, 600), _RGB32(255, 255, 255), BF
_Title "(S)ave BMP Picture, (L)oad Saved Month Info, (P)rint, Left and Right Switches Months, Space Bar Start's Over, Esc ends."
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
Locate 3, 42: Print month$; " "; y
For x = 20 To 780 Step 108
Line (x, 100)-(x, 580), _RGB32(0, 0, 0)
Next x
For z = 100 To 580 Step 80
Line (16, z)-(780, z), _RGB32(0, 0, 0)
Next z
Locate 5, 8: Print "SUNDAY"
Locate 5, 21: Print "MONDAY"
Locate 5, 34: Print "TUESDAY"
Locate 5, 47: Print "WEDNESDAY"
Locate 5, 60: Print "THURSDAY"
Locate 5, 75: Print "FRIDAY"
Locate 5, 87: Print "SATURDAY"
'Finding Date of Easter
PQA = yy
GoSub PAQUES
'month = PQM, day = PQJ, year = PQA
'This section puts the right dates and holidays in the right squares for the calendar.
_Font 16
w = (weekday * 108) + 25
For weeky = 110 To 570 Step 80
For dayx = w To 692 Step 108
_Limit 1000
dd = dd + 1
GetDay mm, dd, yy, weekday
If loops = 1 Then y = year
If weekday = 1 Then GoSub coloring:
If weekday <> 1 Then Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
dd$ = Str$(dd)
_Font 8
If dd = (dayinfo(infos) And loadm = m And loady = y And load = 1) Or (dd = dayinfo(infos) And newy = y And newm = m) Then
GoSub coloring:
i = Len(newinfo$(infos))
If i < 8 Then ii = 25
If i > 7 And i < 12 Then ii = 11
If i > 11 And i < 14 Then ii = 5
If i > 13 Then ii = 2
_PrintString (dayx + ii, weeky + 20), newinfo$(infos)
infos = infos + 1
ye = 1
End If
If holidays = 0 Then GoTo skip:
If m = 1 And dd = 1 Then
GoSub coloring:
_PrintString (dayx + 15, weeky + 60), "New Years"
End If
If m = 1 And weekday = 2 And dd > 14 And dd < 22 Then
GoSub coloring:
_PrintString (dayx + 25, weeky + 60), "MLK Jr."
End If
If m = 2 And dd = 2 Then
GoSub coloring:
_PrintString (dayx + 13, weeky + 60), "Groundhog"
End If
If m = 2 And weekday = 2 And dd > 14 And dd < 22 Then
GoSub coloring:
_PrintString (dayx + 10, weeky + 60), "Presidents"
End If
If m = 2 And dd = 14 Then
GoSub coloring:
_PrintString (dayx + 10, weeky + 60), "Valentines"
End If
If m = 3 And dd = 17 Then
GoSub coloring:
_PrintString (dayx + 5, weeky + 60), "St. Patrick"
End If
If m = PQM And dd = PQJ Then
GoSub coloring:
_PrintString (dayx + 25, weeky + 60), "Easter"
End If
If m = 4 And dd > 23 And weekday = 7 Then
GoSub coloring:
_PrintString (dayx + 25, weeky + 60), "Arbor"
End If
If m = 5 And weekday = 0 And dd > 14 And dd < 22 Then
GoSub coloring:
_PrintString (dayx + 2, weeky + 60), "Armed Forces"
End If
If m = 5 And weekday = 2 And dd > 24 Then
GoSub coloring:
_PrintString (dayx + 15, weeky + 60), "Memorial"
End If
If m = 5 And weekday = 1 And dd > 7 And dd < 15 Then
GoSub coloring:
_PrintString (dayx + 2, weeky + 60), "Mother's Day"
End If
If m = 6 And weekday = 1 And dd > 14 And dd < 22 Then
GoSub coloring:
_PrintString (dayx + 2, weeky + 60), "Father's Day"
End If
If m = 6 And dd = 14 Then
GoSub coloring:
_PrintString (dayx + 35, weeky + 60), "Flag"
End If
If m = 7 And dd = 4 Then
GoSub coloring:
_PrintString (dayx + 2, weeky + 60), "Independence"
End If
If m = 9 And weekday = 2 And dd < 8 Then
GoSub coloring:
_PrintString (dayx + 27, weeky + 60), "Labor"
End If
If m = 10 And dd > 9 And dd < 16 And weekday = 2 Then
GoSub coloring:
_PrintString (dayx + 17, weeky + 60), "Columbus"
End If
If m = 10 And dd = 31 Then
GoSub coloring:
_PrintString (dayx + 15, weeky + 60), "Halloween"
End If
If m = 11 And dd = 11 Then
GoSub coloring:
_PrintString (dayx + 19, weeky + 60), "Veterans"
End If
If m = 11 And dd > 21 And dd < 29 And weekday = 5 Then
GoSub coloring:
_PrintString (dayx + 2, weeky + 60), "Thanksgiving"
End If
If m = 12 And dd = 25 Then
GoSub coloring:
_PrintString (dayx + 15, weeky + 60), "Christmas"
End If
skip:
ye = 0
_Font 16
_PrintString (dayx, weeky), dd$
_Font 8
If dd = days Then _Font 16: GoTo more2:
Next dayx
w = 25
Next weeky
more2:
_Limit 100
a$ = InKey$
If a$ = "l" Or a$ = "L" Then GoTo loading:
If a$ = Chr$(27) Then Cls: Print: Print: Print "Goodbye.": End
If a$ = "s" Or a$ = "S" Then GoTo saving:
If a$ = " " Then GoTo start:
If a$ = "p" Or a$ = "P" Or loops = 1 Then
_Delay 2
'printer prep (code copied and pasted from bplus Free Calendar Program)
YMAX = _Height: XMAX = _Width
landscape& = _NewImage(YMAX, XMAX, 32)
_MapTriangle (XMAX, 0)-(0, 0)-(0, YMAX), 0 To(0, 0)-(0, XMAX)-(YMAX, XMAX), landscape&
_MapTriangle (XMAX, 0)-(XMAX, YMAX)-(0, YMAX), 0 To(0, 0)-(YMAX, 0)-(YMAX, XMAX), landscape&
_PrintImage landscape&
End If
If a$ = Chr$(0) + Chr$(77) And loops = 0 Then
m = m + 1
If m > 12 Then
m = 1
yy = yy + 1
y = y + 1
End If
If y > 9999 Then y = 1753
dd = 0
leap = 0
_Delay .1
Cls
GoTo calculate2:
End If
If a$ = Chr$(0) + Chr$(75) And loops = 0 Then
m = m - 1
If m < 1 Then
m = 12
yy = yy - 1
y = y - 1
End If
If y < 1753 Then y = 9999
dd = 0
leap = 0
_Delay .1
Cls
GoTo calculate2:
End If
If loops = 1 Then _Delay 1: Cls: GoTo calculate:
GoTo more2:
adding:
load = 0
monthsave$ = Str$(m)
yearsave$ = Str$(y)
name$ = LTrim$(monthsave$) + "-" + LTrim$(yearsave$) + ".txt"
theFileExists = _FileExists(name$)
If theFileExists = -1 Then
Print
Print " File Already Exists"
Print " Saving will delete your old"
Print " month data."
Print " Would you like to still do it?"
Print " (Y/N)."
Print " Esc or N goes back to calendar."
llloop:
_Limit 100
ag2$ = InKey$
If ag2$ = Chr$(27) Then GoTo make:
If Left$(ag2$, 1) = "n" Or Left$(ag2$, 1) = "N" Then GoTo make:
If ag2$ = "" Then GoTo llloop:
If ag2$ = "y" Or ag$ = "Y" Then
Shell _Hide "DEL " + name$
GoTo saving2:
End If
GoTo llloop:
End If
saving2:
Open name$ For Output As #1
addingbegin:
Cls
Print: Print
add:
Print
olddayinfo = dayinfo(info)
adding2:
If info > days Then Print "You have reached the maximum amount of holidays or info for this month.": Input "Press enter to create calendar.", pe$: Return
Print
Print "Your dates must go in order here."
Print "for example, you cannot put info for day 15 and then put info for day 1."
Print "They must all follow from smallest number to highest number or it will tell you to start over again."
Print "Also, you cannot change a day by doing it over again, so if you mess up, create a new month."
Print
Print info; ". ";
Input "Which day of the month for new holiday or information: ", dayinfo(info)
If dayinfo(info) > days Then Print "That day is not on this calendar, try again.": GoTo adding2:
If dayinfo(info) < 1 Then Print "You cannot type a date less than 1, try again.": GoTo adding2:
If dayinfo(info) <> Int(dayinfo(info)) Then Print "You cannot type a decimal for a date, try again.": GoTo adding2:
If dayinfo(info) < olddayinfo Then
Print
Print "You have put a date before your previous one which cannot work, start over from your first date."
For dl = 0 To 31
newinfo$(dl) = ""
dayinfo(dl) = 0
Next dl
olddayinfo = 0
info = 0
GoTo add:
End If
adding3:
day$ = Str$(dayinfo(info))
day2$ = LTrim$(day$)
Print #1, day2$
Print
Print "Type up to 12 letters, numbers, or spaces that will be put for that day."
Print
Input "->", newinfo$(info)
infoamount = Len(newinfo$(info))
If infoamount > 12 Then Print "Too long, try again.": GoTo adding3:
If infoamount < 1 Then Print "Nothing typed, try again.": GoTo adding3:
Print #1, newinfo$(info)
Print
Input "Do you want to add more (Y/N):", yn$
If Left$(yn$, 1) = "y" Or Left$(yn$, 1) = "Y" Then info = info + 1: GoTo addingbegin:
Close #1
name$ = ""
newm = m
newy = y
loady = 0
loadm = 0
Return
loading:
Cls
'Files "*.txt"
againload:
Print
Input " Which year to load: ", loady
If loady <> Int(loady) Then Print " Cannot use decimals, try again.": GoTo againload:
If loady < 1753 Or loady > 9999 Then Print " The year can only be between 1753 and 9999, try again.": GoTo againload:
againload2:
loady$ = Str$(loady)
loady$ = RTrim$(loady$)
loady$ = LTrim$(loady$)
Print: Print: Print
Print " " + "Saved Months For " + loady$: Print
Do
monthname = monthname + 1
If monthname > 12 Then GoTo askmonth:
monthn$ = Str$(monthname)
monthn$ = LTrim$(monthn$)
monthn$ = RTrim$(monthn$)
filen$ = monthn$ + "-" + loady$ + ".txt"
filen$ = LTrim$(filen$)
filen$ = RTrim$(filen$)
theFileExists = _FileExists(filen$)
If theFileExists = -1 Then
If monthname = 1 Then Print " " + Str$(monthname) + " January"
If monthname = 2 Then Print " " + Str$(monthname) + " February"
If monthname = 3 Then Print " " + Str$(monthname) + " March"
If monthname = 4 Then Print " " + Str$(monthname) + " April"
If monthname = 5 Then Print " " + Str$(monthname) + " May"
If monthname = 6 Then Print " " + Str$(monthname) + " June"
If monthname = 7 Then Print " " + Str$(monthname) + " July"
If monthname = 8 Then Print " " + Str$(monthname) + " August"
If monthname = 9 Then Print " " + Str$(monthname) + " September"
If monthname = 10 Then Print " " + Str$(monthname) + " October"
If monthname = 11 Then Print " " + Str$(monthname) + " November"
If monthname = 12 Then Print " " + Str$(monthname) + " December"
Else
mn = mn + 1
If mn > 11 Then Print: Input " No months saved for this year, press Enter to go back to calendar.", a2$: GoTo calculate2:
End If
Loop
askmonth:
Print
Input " Which month number to load: ", loadm
If loadm < 1 Or loadm > 12 Then Print " Month must be between 1 and 12, try again.": GoTo againload2:
If loadm <> Int(loadm) Then Print " Cannot use decimals, try again.": GoTo againload2:
loady$ = LTrim$(Str$(loady))
loady$ = RTrim$(loady$)
loadm$ = LTrim$(Str$(loadm))
loadm$ = RTrim$(loadm$)
name2$ = loadm$ + "-" + loady$ + ".txt"
name2$ = LTrim$(name2$)
name2$ = RTrim$(name2$)
theFileExists = _FileExists(name2$)
If theFileExists <> -1 Then
Print " This file does not exist."
Print " Would you like to (S)tart over or go back to the (C)alendar? (Press S or C): "
asking:
aa$ = InKey$
If aa$ = "s" Or aa$ = "S" Then GoTo loading:
If aa$ = "c" Or aa$ = "C" Then GoTo make:
If aa$ = Chr$(27) Then GoTo make:
GoTo asking:
End If
For t = 0 To 31
dayinfo(t) = 0
newinfo$(t) = ""
Next t
info2 = 0
Open name2$ For Input As #1
Do Until EOF(1)
Input #1, dayinfo(info2)
Input #1, newinfo$(info2)
info2 = info2 + 1
Loop
Close #1
name2$ = ""
For snd = 100 To 700 Step 100
Sound snd, 2
Next snd
Cls
y = loady
m = loadm
yy = y
mm = m
load = 1
newy = 0
newm = 0
GoTo calculate2:
'Color all Sundays and holidays
coloring:
If ye = 1 Then Return
Line (dayx - 4, weeky - 9)-(dayx + 102, weeky + 68), _RGB32(255, 255, 127), BF: Color _RGB32(0, 0, 0), _RGB32(255, 255, 127)
Return
'Find the right date for Easter.
PAQUES:
PQM = Int(PQA / 100): PQ1 = PQA - PQM * 100: PQJ = Int(((PQA / 19 - Int(PQA / 19)) + .001) * 19)
PQ2 = Int(PQM / 4): PQ3 = Int(((PQM / 4) - PQ2 + .001) * 4): PQ4 = Int((8 + PQM) / 25)
PQ5 = Int((1 + PQM - PQ4 + .001) / 3): PQ4 = (15 + 19 * PQJ + PQM - PQ2 - PQ5 + .001) / 30: PQ4 = PQ4 - Int(PQ4)
PQ4 = Int(PQ4 * 30): PQ5 = Int(PQ1 / 4): PQ6 = ((PQ1 / 4) - PQ5) * 4
PQ7 = (32 + 2 * PQ3 + 2 * PQ5 - PQ4 - PQ6 + .001) / 7: PQ7 = (PQ7 - Int(PQ7)) * 7: PQ6 = (PQJ + 11 * PQ4 + 22 * PQ7) / 451
PQ6 = Int(PQ6): PQ2 = (114 + PQ4 + PQ7 - 7 * PQ6) / 31: PQM = Int(PQ2): PQJ = Int((PQ2 - PQM + .001) * 31 + 1)
Return
'This section saves the calendar to a BMP file along with the SUB at the end of this program.
saving:
If loops = 1 Then GoTo more2:
mo$ = Str$(m)
mo$ = LTrim$(RTrim$(mo$))
year2$ = Str$(y)
year2$ = LTrim$(RTrim$(year2$))
nm$ = mo$ + "-"
nm$ = LTrim$(RTrim$(nm$))
nm$ = nm$ + year2$
nm$ = LTrim$(RTrim$(nm$))
SaveImage 0, nm$ 'saves entire program screen,"
Cls
nm2$ = nm$ + ".bmp"
nm2$ = LTrim$(RTrim$(nm2$))
Print: Print: Print
Print " Saving"
Print
Print " "; nm2$; " has been saved to your computer."
Print
Print
Input " Do you wish to go back to your calendar (Y/N)"; ag$
If Left$(ag$, 1) = "y" Or Left$(ag$, 1) = "Y" Then ag$ = "": GoTo calculate2:
Print
Print
Print " Goodbye."
End
'This section gets the right weekday.
Sub GetDay (mm, dd, yy, weekday) 'use 4 digit year
'From Zeller's congruence: https://en.wikipedia.org/wiki/Zeller%27s_congruence
If mm < 3 Then yy = yy - 1
If mm < 3 Then mm = mm + 12
century = yy Mod 100
zerocentury = yy \ 100
weekday = (dd + Int(13 * (mm + 1) / 5) + century + Int(century / 4) + Int(zerocentury / 4) + 5 * zerocentury) Mod 7
End Sub
'This section saves the .bmp picture file.
Sub SaveImage (image As Long, filename As String)
bytesperpixel& = _PixelSize(image&)
If bytesperpixel& = 0 Then Print "Text modes unsupported!": End
If bytesperpixel& = 1 Then bpp& = 8 Else bpp& = 24
x& = _Width(image&)
y& = _Height(image&)
b$ = "BM????QB64????" + MKL$(40) + MKL$(x&) + MKL$(y&) + MKI$(1) + MKI$(bpp&) + MKL$(0) + "????" + String$(16, 0) 'partial BMP header info(???? to be filled later)
If bytesperpixel& = 1 Then
For c& = 0 To 255 ' read BGR color settings from JPG image + 1 byte spacer(CHR$(0))
cv& = _PaletteColor(c&, image&) ' color attribute to read.
b$ = b$ + Chr$(_Blue32(cv&)) + Chr$(_Green32(cv&)) + Chr$(_Red32(cv&)) + Chr$(0) 'spacer byte
Next
End If
Mid$(b$, 11, 4) = MKL$(Len(b$)) ' image pixel data offset(BMP header)
lastsource& = _Source
_Source image&
If ((x& * 3) Mod 4) Then padder$ = String$(4 - ((x& * 3) Mod 4), 0)
For py& = y& - 1 To 0 Step -1 ' read JPG image pixel color data
r$ = ""
For px& = 0 To x& - 1
c& = Point(px&, py&) 'POINT 32 bit values are large LONG values
If bytesperpixel& = 1 Then r$ = r$ + Chr$(c&) Else r$ = r$ + Left$(MKL$(c&), 3)
Next px&
d$ = d$ + r$ + padder$
Next py&
_Source lastsource&
Mid$(b$, 35, 4) = MKL$(Len(d$)) ' image size(BMP header)
b$ = b$ + d$ ' total file data bytes to create file
Mid$(b$, 3, 4) = MKL$(Len(b$)) ' size of data file(BMP header)
If LCase$(Right$(filename$, 4)) <> ".bmp" Then ext$ = ".bmp"
f& = FreeFile
Open filename$ + ext$ For Output As #f&: Close #f& ' erases an existing file
Open filename$ + ext$ For Binary As #f&
Put #f&, , b$
Close #f&
End Sub