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