Author Topic: Free Calendar  (Read 5134 times)

0 Members and 1 Guest are viewing this topic.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Free Calendar
« on: December 08, 2018, 04:32:38 pm »
I never considered printing calendar out from BASIC program until I saw discussion on _PRINTIMAGE.

Hey, it works (with my system) after converting to landscape view.

Nobody in my family likes using glossy paper for calendar notes, plus want space maximized without ads or pictures, store month in 3 ring binder...

Code: QB64: [Select]
  1. _TITLE "Calendar" 'B+ 2018-12-08 from SmallBASIC old FLTK files (PalmOS version)
  2. ' This program creates 5 or 6 row calendars (Sun thru Sat) depending upon needs of month.
  3. ' You will see the preview on the screen.
  4. ' I used _MAPTRIANGLE to put the calendar in landscape view so will print on normal
  5. ' typewriter sheet: 8.5 X 11 inches, USA measure, with Windows 10 and HP envy 5530 printer.
  6.  
  7. CONST XMAX = 1100
  8. CONST YMAX = 760
  9. CONST tMar = 40 'top margin allows room for 3 hole binder punch on top (landscape orientation) or left side (portrait orientation)
  10. CONST sideMar = 10
  11. SCREEN _NEWIMAGE(XMAX, YMAX, 32)
  12. DIM dayNames$(0 TO 6), monthNames$(1 TO 12), monthDays(1 TO 12) AS INTEGER
  13. FOR i = 0 TO 6: READ dayNames$(i): NEXT
  14. DATA "Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday"
  15. FOR i = 1 TO 12: READ monthNames$(i): NEXT
  16. DATA "January","February","March","April","May","June","July","August","September","October","November","December"
  17. FOR i = 1 TO 12: READ monthDays(i): NEXT
  18. DATA 31,28,31,30,31,30,31,31,30,31,30,31
  19.  
  20. ' this loads and checks fonts (Windows 10)
  21. DIM SHARED FH, CH, CW, FH2, CH2, CW2
  22. FH = _LOADFONT("ARLRDBD.ttf", 24, "MONOSPACE")
  23. IF FH <= 0 THEN PRINT "Trouble with font load file, goodbye.": SLEEP: END
  24. CH = _FONTHEIGHT(FH): CW = CH * .6 'this make printing char by char the same as printing a string for ARLRDBD.ttf
  25. 'test font, in box? for 5 above 5 below height = 30
  26. LINE (5, 5)-STEP(CW * LEN(monthNames$(1) + STR$(2018)), 30), , B
  27. _PRINTSTRING (10, 10), monthNames$(1) + STR$(2018)
  28.  
  29. FH2 = _LOADFONT("ARLRDBD.ttf", 18, "MONOSPACE")
  30. IF FH2 <= 0 THEN PRINT "Trouble with font load file, goodbye.": SLEEP: END
  31. CH2 = _FONTHEIGHT(FH2): CW2 = CH2 * .5 'this make printing char by char the same as printing a string for ARLRDBD.ttf
  32. _FONT FH2
  33. LINE (5, 45)-STEP(CW2 * LEN("testing smaller font 1, 2, 3, 31"), 25), , B
  34. _PRINTSTRING (10, 50), "testing smaller font 1, 2, 3, 31"
  35.  
  36. y = 2019 'free calendar
  37. FOR m = 1 TO 12
  38.     'WHILE 1
  39.     'LOCATE 10, 1
  40.     'LINE INPUT "Enter Month Number,Year Number ", ln$
  41.     'ln$ = "8, 2018" '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< just plug in year here until debugged
  42.     'm = VAL(leftOf$(ln$, ","))
  43.     'y = VAL(rightOf$(ln$, ","))
  44.     'IF m = 0 OR y = 0 THEN END
  45.  
  46.  
  47.     COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
  48.     CLS
  49.  
  50.     'day month starts, probably the most crucial formula from the SnallBASIC program
  51.     d = (1461 * (y + 4800 + (m - 14) \ 12) \ 4 + 367 * (m - 2 - 12 * ((m - 14) \ 12)) \ 12 - 3 * ((y + 4900 + (m - 14) \ 12) \ 100) \ 4 + 1) MOD 7
  52.     ' fix leap year for true = -1
  53.     IF y MOD 400 = 0 THEN b1 = 1 ELSE b1 = 0
  54.     IF y MOD 100 <> 0 THEN b2 = 1 ELSE b2 = 0
  55.     IF b1 = 1 OR b2 = 1 THEN b3 = 1 ELSE b3 = 0
  56.     IF y MOD 4 = 0 THEN b1 = 1 ELSE b1 = 0
  57.     IF b1 = 1 AND b3 = 1 THEN add = 1 ELSE add = 0
  58.     monthDays(2) = 28 + add
  59.     'from these calcs for month year determine amount of rows calendar will need
  60.     rows = (monthDays(m) + d + 6) \ 7
  61.     boxW = INT((XMAX - 2 * sideMar) / 7)
  62.     monthYear$ = monthNames$(m) + STR$(y)
  63.     _FONT FH2
  64.     IF rows = 5 THEN
  65.         yTitle = tMar + 5
  66.         yDayNames = tMar + 40 'strings  line above is -5 and line below is yTopGrid
  67.         yTopGrid = yDayNames + 20
  68.         boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
  69.         yBottomGrid = yTopGrid + rows * boxH
  70.  
  71.         'center monthYear$ at top
  72.         _FONT FH
  73.         _PRINTSTRING ((XMAX - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
  74.         _FONT FH2
  75.     ELSE
  76.         yDayNames = tMar + 5 ' for day name strings,  line above is -5 and line below is yTopGrid
  77.         yTopGrid = yDayNames + 20
  78.         boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
  79.         yBottomGrid = yTopGrid + rows * boxH
  80.         yTitle = yTopGrid + .5 * boxH - 10
  81.         ' print month year title after the rest of the calendar is done
  82.     END IF
  83.  
  84.     LINE (sideMar, yDayNames - 5)-STEP(7 * boxW, 1), , BF
  85.     'verticals and daytitles
  86.     FOR day = 0 TO 7
  87.         x = sideMar + day * boxW
  88.         LINE (x, yDayNames - 5)-(x + 1, yBottomGrid), , BF
  89.         IF day < 7 THEN
  90.             xoff = (boxW - LEN(dayNames$(day)) * CW2) / 2
  91.             _PRINTSTRING (x + xoff, yDayNames), dayNames$(day)
  92.         END IF
  93.     NEXT
  94.     LINE (sideMar, yTopGrid)-STEP(7 * boxW, 1), , BF
  95.     ' horizontals
  96.     FOR n = 1 TO rows
  97.         LINE (sideMar, yTopGrid + boxH * n)-STEP(7 * boxW, 1), , BF
  98.     NEXT
  99.     ' dates
  100.     FOR i = 0 TO monthDays(m) - 1
  101.         row = (d + i) \ 7
  102.         col = (d + i) MOD 7
  103.         _PRINTSTRING (col * boxW + sideMar + 5, row * boxH + yTopGrid + 5), LTRIM$(STR$(i + 1))
  104.     NEXT
  105.     IF rows = 6 THEN 'insert month name in top row about 200 in?
  106.         'first clear lines in first 4 blocks
  107.         LINE (sideMar + 2, yTopGrid + 2)-STEP(4 * boxW - 4, boxH - 3), _RGB32(255, 255, 255), BF
  108.         'center monthYear$ in first 4 blocks (never used in 6 row calendar)
  109.         _FONT FH
  110.         _PRINTSTRING (sideMar + (4 * boxW - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
  111.         _FONT FH2
  112.     END IF
  113.     'printer prep
  114.     landscape& = _NEWIMAGE(YMAX, XMAX, 32)
  115.     _MAPTRIANGLE (XMAX, 0)-(0, 0)-(0, YMAX), 0 TO(0, 0)-(0, XMAX)-(YMAX, XMAX), landscape&
  116.     _MAPTRIANGLE (XMAX, 0)-(XMAX, YMAX)-(0, YMAX), 0 TO(0, 0)-(YMAX, 0)-(YMAX, XMAX), landscape&
  117.     '_PRINTIMAGE landscape&     '<<<<<<<<<<<<<<<<<<<<<<<<< debug first before wasting paper and ink
  118.     _DELAY 5
  119.     'wend
  120.  
  121. FUNCTION leftOf$ (source$, of$)
  122.     posOf = INSTR(source$, of$)
  123.     IF posOf > 0 THEN leftOf$ = MID$(source$, 1, posOf - 1)
  124.  
  125. FUNCTION rightOf$ (source$, of$)
  126.     posOf = INSTR(source$, of$)
  127.     IF posOf > 0 THEN rightOf$ = MID$(source$, posOf + LEN(of$))
  128.  
  129.  

Offline Ashish

  • Forum Resident
  • Posts: 630
  • Never Give Up!
    • View Profile
Re: Free Calendar
« Reply #1 on: December 09, 2018, 11:48:48 am »
Neat Work! You can try reducing your program resolution as it does not fit into my screen.
if (Me.success) {Me.improve()} else {Me.tryAgain()}


My Projects - https://github.com/AshishKingdom?tab=repositories
OpenGL tutorials - https://ashishkingdom.github.io/OpenGL-Tutorials

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Free Calendar
« Reply #2 on: December 09, 2018, 12:43:00 pm »
Sure, reduce XMAX, YMAX but keep them proportional to the size paper printing on for proper preview.

CONST XMAX = 1100 / 1.3
CONST YMAX = 760 / 1.3

But all the pixel measures are not scaled so printout of font gets misaligned, my printout for January 2019 has "Wednesday" running into the right side of label box, in preview screen too with above screen size, XMAX for Width, YMAX for height.
(Wow the lines and letters are much thicker too.)

Eh, would require complete rework because pixel measures based on font size. All the line drawing remains proportional though.
« Last Edit: December 09, 2018, 12:53:36 pm by bplus »

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
    • View Profile
Re: Free Calendar
« Reply #3 on: December 09, 2018, 01:56:43 pm »
I don't have that font you used, but yesterday I tried it with lucon font, and it worked, but like Ashish, mine went off the screen. I retooled 3 lines and added pete = 8 to change the xoff values, and it looks nice, fits perfectly, on my screen...

Code: QB64: [Select]
  1. pete = 8
  2. _TITLE "Calendar" 'B+ 2018-12-08 from SmallBASIC old FLTK files (PalmOS version)
  3. ' This program creates 5 or 6 row calendars (Sun thru Sat) depending upon needs of month.
  4. ' You will see the preview on the screen.
  5. ' I used _MAPTRIANGLE to put the calendar in landscape view so will print on normal
  6. ' typewriter sheet: 8.5 X 11 inches, USA measure, with Windows 10 and HP envy 5530 printer.
  7.  
  8. CONST XMAX = 1100 / 1.2
  9. CONST YMAX = 760 / 1.2
  10. CONST tMar = 40 'top margin allows room for 3 hole binder punch on top (landscape orientation) or left side (portrait orientation)
  11. CONST sideMar = 10
  12. SCREEN _NEWIMAGE(XMAX, YMAX, 32)
  13. DIM dayNames$(0 TO 6), monthNames$(1 TO 12), monthDays(1 TO 12) AS INTEGER
  14. FOR i = 0 TO 6: READ dayNames$(i): NEXT
  15. DATA "Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday"
  16. FOR i = 1 TO 12: READ monthNames$(i): NEXT
  17. DATA "January","February","March","April","May","June","July","August","September","October","November","December"
  18. FOR i = 1 TO 12: READ monthDays(i): NEXT
  19. DATA 31,28,31,30,31,30,31,31,30,31,30,31
  20.  
  21. ' this loads and checks fonts (Windows 10)
  22. DIM SHARED FH, CH, CW, FH2, CH2, CW2
  23. FH = _LOADFONT("lucon.ttf", 26)
  24. IF FH <= 0 THEN PRINT "Trouble with font load file, goodbye.": SLEEP: END
  25. CH = _FONTHEIGHT(FH): CW = CH * .6 'this make printing char by char the same as printing a string for ARLRDBD.ttf
  26. 'test font, in box? for 5 above 5 below height = 30
  27. LINE (5, 5)-STEP(CW * LEN(monthNames$(1) + STR$(2018)), 30), , B
  28. _PRINTSTRING (10, 10), monthNames$(1) + STR$(2018)
  29.  
  30. FH2 = _LOADFONT("lucon.ttf", 20)
  31. IF FH2 <= 0 THEN PRINT "Trouble with font load file, goodbye.": SLEEP: END
  32. CH2 = _FONTHEIGHT(FH2): CW2 = CH2 * .5 'this make printing char by char the same as printing a string for ARLRDBD.ttf
  33. _FONT FH2
  34. LINE (5, 45)-STEP(CW2 * LEN("testing smaller font 1, 2, 3, 31"), 25), , B
  35. _PRINTSTRING (10, 50), "testing smaller font 1, 2, 3, 31"
  36.  
  37. y = 2019 'free calendar
  38. FOR m = 1 TO 12
  39.     'WHILE 1
  40.     'LOCATE 10, 1
  41.     'LINE INPUT "Enter Month Number,Year Number ", ln$
  42.     'ln$ = "8, 2018" '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< just plug in year here until debugged
  43.     'm = VAL(leftOf$(ln$, ","))
  44.     'y = VAL(rightOf$(ln$, ","))
  45.     'IF m = 0 OR y = 0 THEN END
  46.  
  47.  
  48.     COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
  49.     CLS
  50.  
  51.     'day month starts, probably the most crucial formula from the SnallBASIC program
  52.     d = (1461 * (y + 4800 + (m - 14) \ 12) \ 4 + 367 * (m - 2 - 12 * ((m - 14) \ 12)) \ 12 - 3 * ((y + 4900 + (m - 14) \ 12) \ 100) \ 4 + 1) MOD 7
  53.     ' fix leap year for true = -1
  54.     IF y MOD 400 = 0 THEN b1 = 1 ELSE b1 = 0
  55.     IF y MOD 100 <> 0 THEN b2 = 1 ELSE b2 = 0
  56.     IF b1 = 1 OR b2 = 1 THEN b3 = 1 ELSE b3 = 0
  57.     IF y MOD 4 = 0 THEN b1 = 1 ELSE b1 = 0
  58.     IF b1 = 1 AND b3 = 1 THEN add = 1 ELSE add = 0
  59.     monthDays(2) = 28 + add
  60.     'from these calcs for month year determine amount of rows calendar will need
  61.     rows = (monthDays(m) + d + 6) \ 7
  62.     boxW = INT((XMAX - 2 * sideMar) / 7)
  63.     monthYear$ = monthNames$(m) + STR$(y)
  64.     _FONT FH2
  65.     IF rows = 5 THEN
  66.         yTitle = tMar + 5
  67.         yDayNames = tMar + 40 'strings  line above is -5 and line below is yTopGrid
  68.         yTopGrid = yDayNames + 20
  69.         boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
  70.         yBottomGrid = yTopGrid + rows * boxH
  71.  
  72.         'center monthYear$ at top
  73.         _FONT FH
  74.         _PRINTSTRING ((XMAX - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
  75.         _FONT FH2
  76.     ELSE
  77.         yDayNames = tMar + 5 ' for day name strings,  line above is -5 and line below is yTopGrid
  78.         yTopGrid = yDayNames + 20
  79.         boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
  80.         yBottomGrid = yTopGrid + rows * boxH
  81.         yTitle = yTopGrid + .5 * boxH - 10
  82.         ' print month year title after the rest of the calendar is done
  83.     END IF
  84.  
  85.     LINE (sideMar, yDayNames - 5)-STEP(7 * boxW, 1), , BF
  86.     'verticals and daytitles
  87.     FOR day = 0 TO 7
  88.         x = sideMar + day * boxW
  89.         LINE (x, yDayNames - 5)-(x + 1, yBottomGrid), , BF
  90.         IF day < 7 THEN
  91.             xoff = (boxW - LEN(dayNames$(day)) * CW2) / 2 - pete
  92.             _PRINTSTRING (x + xoff, yDayNames), dayNames$(day)
  93.         END IF
  94.     NEXT
  95.     LINE (sideMar, yTopGrid)-STEP(7 * boxW, 1), , BF
  96.     ' horizontals
  97.     FOR n = 1 TO rows
  98.         LINE (sideMar, yTopGrid + boxH * n)-STEP(7 * boxW, 1), , BF
  99.     NEXT
  100.     ' dates
  101.     FOR i = 0 TO monthDays(m) - 1
  102.         row = (d + i) \ 7
  103.         col = (d + i) MOD 7
  104.         _PRINTSTRING (col * boxW + sideMar + 5, row * boxH + yTopGrid + 5), LTRIM$(STR$(i + 1))
  105.     NEXT
  106.     IF rows = 6 THEN 'insert month name in top row about 200 in?
  107.         'first clear lines in first 4 blocks
  108.         LINE (sideMar + 2, yTopGrid + 2)-STEP(4 * boxW - 4, boxH - 3), _RGB32(255, 255, 255), BF
  109.         'center monthYear$ in first 4 blocks (never used in 6 row calendar)
  110.         _FONT FH
  111.         _PRINTSTRING (sideMar + (4 * boxW - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
  112.         _FONT FH2
  113.     END IF
  114.     'printer prep
  115.     landscape& = _NEWIMAGE(YMAX, XMAX, 32)
  116.     _MAPTRIANGLE (XMAX, 0)-(0, 0)-(0, YMAX), 0 TO(0, 0)-(0, XMAX)-(YMAX, XMAX), landscape&
  117.     _MAPTRIANGLE (XMAX, 0)-(XMAX, YMAX)-(0, YMAX), 0 TO(0, 0)-(YMAX, 0)-(YMAX, XMAX), landscape&
  118.     '_PRINTIMAGE landscape&     '<<<<<<<<<<<<<<<<<<<<<<<<< debug first before wasting paper and ink
  119.     _DELAY 5
  120.     'wend
  121.  
  122. FUNCTION leftOf$ (source$, of$)
  123. posOf = INSTR(source$, of$)
  124. IF posOf > 0 THEN leftOf$ = MID$(source$, 1, posOf - 1)
  125.  
  126. FUNCTION rightOf$ (source$, of$)
  127. posOf = INSTR(source$, of$)
  128. IF posOf > 0 THEN rightOf$ = MID$(source$, posOf + LEN(of$))
  129.  
  130.  
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Free Calendar
« Reply #4 on: December 09, 2018, 02:43:33 pm »
Nice one Pete.

I tried your changes and it previewed fine, so I printed March 2019, a 6 row month, and it came out fine, all day names nicely spaced. :)

BTW if the size issue is just screen height, I think I did most of the coding with YMAX = 700 to fit my screen.

I think Pete has Wednesday better centered than my original code!
« Last Edit: December 09, 2018, 02:56:29 pm by bplus »

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
    • View Profile
Re: Free Calendar
« Reply #5 on: December 09, 2018, 03:10:12 pm »
Your stuff is awesome (shut up Bill) so glad to be of some small service... Again, Bill!

I eventually made a SCREEN 0 calendar many moons ago, early 2000s maybe? I needed one for my office software.  I think I have it posted somewhere at The QBasic Forum but rather than try to look it up, I do have the non-mouse one saved...

Code: QB64: [Select]
  1. DECLARE SUB CALENDAR (DATEX$)
  2. CALL CALENDAR(DATEX$)
  3.  
  4. SUB CALENDAR (DATEX$)
  5. BORDER = 14
  6. SCREEN 0, 0, 4, 5
  7. IF SMODE% = 0 THEN PCOPY 0, 5
  8. IF SMODE% = 1 THEN PCOPY 1, 5
  9. PCOPY 5, 4
  10. LOCATE , , 0, 7, 0
  11.  
  12. COLOR 7, 0
  13. DATEX$ = DATE$
  14. SPRVAR$ = "GETDOW": KW$ = MID$(DATEX$, 4, 2): GOSUB CALSUB
  15. ACT$ = "MAIN"
  16. GOSUB CALSUB
  17. IF SMODE% = 0 THEN SCREEN 0, 0, 0, 0
  18. IF SMODE% = 1 THEN SCREEN 0, 0, 1, 1
  19. GOTO ENDCALSUB
  20.  
  21. BOX:
  22. COLOR BORDER, 1: LOCATE W1 - 1, W2: PRINT CHR$(218) + STRING$(50, 196) + CHR$(191);
  23. LOCATE W1, W2
  24. FOR I = 1 TO W3
  25.     A$ = ""
  26.     COLOR 7, 1
  27.     LOCATE , W2
  28.     IF INSTR(A$, CHR$(2)) <> 0 THEN A$ = MID$(A$, 1, INSTR(A$, CHR$(2)) - 1)
  29.     A$ = A$ + SPACE$(W4 - LEN(A$))
  30.  
  31.     PRINT A$;
  32.  
  33.     COLOR 9, 1: PRINT CHR$(219) + CHR$(219)
  34.  
  35. LOCATE , W2 + 1: PRINT STRING$(W4 + 1, 219);
  36. COLOR 7, 0
  37.  
  38. CALSUB:
  39. COLOR 7, 0
  40.  
  41. CHNGMOYR:
  42. MO = VAL(MID$(DATEX$, 1, 2))
  43. YR = VAL(MID$(DATEX$, 7, 4))
  44.  
  45. SETCAL:
  46.     CASE 1: MONTH$ = "JANUARY"
  47.     CASE 2: MONTH$ = "FEBRUARY"
  48.     CASE 3: MONTH$ = "MARCH"
  49.     CASE 4: MONTH$ = "APRIL"
  50.     CASE 5: MONTH$ = "MAY"
  51.     CASE 6: MONTH$ = "JUNE"
  52.     CASE 7: MONTH$ = "JULY"
  53.     CASE 8: MONTH$ = "AUGUST"
  54.     CASE 9: MONTH$ = "SEPTEMBER"
  55.     CASE 10: MONTH$ = "OCTOBER"
  56.     CASE 11: MONTH$ = "NOVEMBER"
  57.     CASE 12: MONTH$ = "DECEMBER"
  58.  
  59. XDAYS = (YR - 1) * 365 + (YR - 1) \ 4 - (YR - 1) \ 400
  60. FOR I = 1 TO MO - 1
  61.     X = 30
  62.     IF I = 1 OR I = 3 OR I = 5 OR I = 7 OR I = 8 OR I = 10 OR I = 12 THEN X = 31
  63.     IF I = 2 THEN
  64.         X = 28
  65.         IF YR MOD 4 = 0 THEN
  66.             IF YR MOD 100 = 0 THEN
  67.                 IF YR MOD 400 = 0 THEN
  68.                     X = 29
  69.                 END IF
  70.             ELSE
  71.                 X = 29
  72.             END IF
  73.         END IF
  74.     END IF
  75.     XDAYS = XDAYS + X
  76. XNOD = 30
  77. IF I = 1 OR I = 3 OR I = 5 OR I = 7 OR I = 8 OR I = 10 OR I = 12 THEN XNOD = 31
  78. IF I = 2 THEN XNOD = 28
  79. IF MO = 2 AND YR MOD 4 = 0 THEN
  80.     IF YR MOD 100 = 0 THEN
  81.         IF YR MOD 400 = 0 THEN XNOD = XNOD + 1
  82.     ELSE
  83.         XNOD = XNOD + 1
  84.     END IF
  85. XOVER = (XDAYS + 6) MOD 7: IF XOVER = 0 THEN XOVER = 7
  86. IF A1$ <> "" OR SPRVAR$ = "GETDOW" THEN GOTO GETDOW: REM MAKES AN ENDLESS LOOP WHEN MIXED WITH ENTERING A NEW PATIENT.
  87. XL = 4
  88. A1$ = CHR$(218) + STRING$(XL, CHR$(196)) + CHR$(191)
  89. A2$ = CHR$(179) + STRING$(XL, CHR$(32)) + CHR$(179)
  90. A3$ = CHR$(192) + STRING$(XL, CHR$(196)) + CHR$(217)
  91. B1$ = A1$: B2$ = A2$: B3$ = A3$
  92. FOR I = 1 TO 7 - 1
  93.     A1$ = A1$ + " " + B1$
  94.     A2$ = A2$ + " " + B2$
  95.     A3$ = A3$ + " " + B3$
  96.  
  97. XX = 4: YY = 40 - INT(LEN(A1$) / 2)
  98. W1 = XX: W2 = YY - 1 - 1: W4 = LEN(A1$) + 2 + 2: W3 = 19
  99.  
  100. IF SPRVAR$ <> "NOSCSV" THEN
  101.     IF XBOXSAVE = 0 THEN
  102.         LOCATE XX, YY: GOSUB BOX: XBOXSAVE = 1
  103.         COLOR 11, 1
  104.         LOCATE 25, 1: PRINT SPACE$(80);: LOCATE 25, 1
  105.         PRINT "  CHOOSE A DATE AND PRESS [ENTER] TO SELECT IT. PRESS [ESC] TO CLOSE CALENDER.";
  106.     END IF
  107.     LOCATE XX + 1, YY, 0, 7, 0
  108.     COLOR 11, 1
  109.     PRINT " Sun.   Mon.   Tue.   Wed.   Thu.   Fri.   Sat. "
  110.  
  111.     NXTCAL:
  112.     COLOR BORDER, 1
  113.     LOCATE XX - 1, W2 + 1: PRINT STRING$(W4 - 2, 196);
  114.     COLOR BORDER, 1
  115.     LOCATE XX - 1, 40 - (LEN(MONTH$) + LEN(LTRIM$(STR$(YR)))) \ 2 - 1: PRINT "<" + MONTH$ + "/" + LTRIM$(STR$(YR)) + ">"
  116.     COLOR BORDER, 1
  117.     LOCATE XX + 2, YY
  118.     FOR I = 1 TO 5
  119.         PRINT A1$
  120.         FOR J = 1 TO 1
  121.             LOCATE CSRLIN, YY
  122.             PRINT A2$
  123.         NEXT J
  124.         LOCATE CSRLIN, YY
  125.         PRINT A3$;: XEND = POS(1): PRINT
  126.         LOCATE CSRLIN, YY
  127.     NEXT I
  128.  
  129.     IF SPRVAR$ = "NOSCSV" THEN SPRVAR$ = ""
  130.  
  131. LOCATE XX + 2, YY - 3
  132. J = CSRLIN + 1
  133. LOCATE J, POS(1) + -7 + 7 * XOVER
  134.  
  135. LOCDATE = VAL(MID$(DATEX$, 4, 2))
  136.  
  137. FOR I = 1 TO XNOD
  138.     LOCATE J, POS(1) + 5
  139.     IF I < 10 THEN XI$ = " " + LTRIM$(STR$(I)) ELSE XI$ = LTRIM$(STR$(I))
  140.  
  141.     IF I >= 30 AND POS(1) >= XEND THEN
  142.         LOCATE CSRLIN, YY + 1
  143.  
  144.         IF I = 30 THEN
  145.             COLOR 11, 1
  146.             IF LOCDATE = 23 THEN COLOR 1, 3
  147.             PRINT "23";
  148.             COLOR 7, 1
  149.             IF LOCDATE = 30 THEN COLOR 7, 3
  150.             PRINT "30";
  151.             IF XNOD = 30 THEN EXIT FOR
  152.         END IF
  153.  
  154.         IF I = 31 AND XNOD = 31 THEN
  155.             COLOR 11, 1
  156.             IF LOCDATE = 24 THEN COLOR 11, 3
  157.             PRINT "24";
  158.             COLOR 7, 1
  159.             IF LOCDATE = 31 THEN COLOR 7, 3
  160.             PRINT "31": EXIT FOR
  161.         END IF
  162.  
  163.         IF I = 30 AND XNOD = 31 THEN
  164.             COLOR 14, 1
  165.             IF LOCDATE = 24 THEN COLOR 14, 4
  166.             LOCATE CSRLIN, YY + 1 + 7: PRINT "24";
  167.             COLOR 7, 1
  168.             IF LOCDATE = 31 THEN COLOR 7, 3
  169.             PRINT "31": EXIT FOR
  170.         END IF
  171.     END IF
  172.  
  173.     IF POS(1) >= XEND THEN
  174.         J = J + 3: LOCATE J, YY + 2
  175.         COLOR 3, 1
  176.     ELSE
  177.         COLOR 14, 1
  178.     END IF
  179.  
  180.     IF I = LOCDATE THEN
  181.         YY1 = POS(1): COLOR 14, 4
  182.         IF YY1 <= W2 + 1 + 3 THEN COLOR 1, 3: REM  - 1
  183.     ELSE IF (I + XOVER - 1) MOD 7 = 1 THEN COLOR 11, 1 ELSE COLOR 14, 1
  184.     END IF
  185.  
  186.     PRINT XI$;
  187.  
  188. COLOR 3, 1
  189. LOCATE XX + 17, YY + 21: PRINT "[PgUp/PgDn]=Mo [Bksp]=Today";
  190. LOCATE XX + 17, YY: PRINT "["; CHR$(24); "/"; CHR$(25); "/"; CHR$(27); "/"; CHR$(26); "]=Find Date";
  191. COLOR 15, 1
  192.  
  193.     IF ACT$ = "CALHOME" OR ACT$ = "CALEND" THEN
  194.         IF YY1 <= W2 + 1 + 3 OR YY1 >= XEND - 4 THEN ACT$ = "": REM  - 1
  195.         IF LOCDATE = XNOD OR LOCDATE = 1 THEN ACT$ = ""
  196.     END IF
  197.  
  198.     SELECT CASE ACT$
  199.         CASE "CALHOME": B$ = " G": EXIT DO
  200.         CASE "CALEND": B$ = " O": EXIT DO
  201.         CASE "CALUP": XNT = XNT + 1: B$ = " H": IF XNT = 7 THEN XNT = 0: ACT$ = "" ELSE EXIT DO
  202.         CASE "CALDN": XNT = XNT + 1: B$ = " P": IF XNT = 7 THEN XNT = 0: ACT$ = "" ELSE EXIT DO
  203.     END SELECT
  204.  
  205.     COLOR BORDER, 1: LOCATE W1 + W3 - 1, W2: PRINT CHR$(192) + STRING$(50, 196) + CHR$(217);
  206.     LOCATE W1, W2
  207.     FOR I = 1 TO W3 - 1
  208.         PRINT CHR$(179);: LOCATE , W2 + W4 - 1: PRINT CHR$(179)
  209.         LOCATE , W2
  210.     NEXT I
  211.  
  212.     COLOR 15, 1
  213.     SCREEN 0, 0, 5, 5: LOCATE XX, YY: SCREEN 0, 0, 4, 5
  214.     PCOPY 4, 5: SMODE = 4: LOCATE XX, YY
  215.     Z1 = TIMER: DO
  216.         B$ = INKEY$
  217.         IF B$ = "/" OR B$ = "?" THEN B$ = CHR$(27)
  218.         IF B$ <> "" THEN IF INSTR("KMHPIQOGuw", MID$(B$, 2, 1)) <> 0 OR B$ = CHR$(27) THEN EXIT DO
  219.         Z2 = TIMER
  220.         IF ABS(Z1 - Z2) >= W9 THEN B$ = CHR$(27)
  221.     LOOP
  222.  
  223.     IF KW$ <> "" THEN EXIT DO
  224.  
  225. IF LEN(KW$) = 1 THEN KW$ = "0" + KW$
  226. IF B$ = CHR$(27) THEN LOCATE XX, YY: DATEX$ = "": GOTO ENDCAL1
  227. IF B$ = CHR$(8) THEN DATEX$ = DATE$: MO = VAL(MID$(DATEX$, 1, 2)): YR = VAL(MID$(DATEX$, 7, 4)): SPRVAR$ = "": A1$ = "": GOTO GETDOW
  228. A1$ = "": SPRVAR$ = "NOSCSV"
  229. CALB:
  230. SELECT CASE MID$(B$, 2, 1)
  231.     CASE "I": SPRVAR$ = "": MID$(DATEX$, 4, 2) = "01": MO = MO - 1: IF MO = 0 THEN MO = 12: YR = YR - 1
  232.     CASE "Q": SPRVAR$ = "": MID$(DATEX$, 4, 2) = "01": MO = MO + 1: IF MO = 13 THEN MO = 1: YR = YR + 1
  233.     CASE "G": IF YY1 <> W2 + 1 + 3 THEN B$ = "0K": ACT$ = "CALHOME": GOTO CALB: REM  - 1
  234.     CASE "O": IF YY1 <> XEND THEN B$ = "0M": ACT$ = "CALEND": GOTO CALB
  235.     CASE "H": B$ = "0K": ACT$ = "CALUP": GOTO CALB
  236.     CASE "P": B$ = "0M": ACT$ = "CALDN": GOTO CALB
  237.     CASE "M"
  238.         IF LOCDATE = XNOD THEN
  239.             KW$ = "01": MO = MO + 1: IF MO = 13 THEN MO = 1: YR = YR + 1
  240.             B$ = LTRIM$(STR$(MO)): IF LEN(B$) = 1 THEN B$ = "0" + B$
  241.             DATEX$ = B$ + "-01-" + LTRIM$(STR$(YR))
  242.             SPRVAR$ = ""
  243.             GOTO SETCAL
  244.         END IF
  245.         SPRVAR$ = "PLUSX": GOSUB NEXTDAY: SPRVAR$ = "": KW$ = MID$(DATEX$, 4, 2): SPRVAR$ = "NOSCSV"
  246.     CASE "u"
  247.         B$ = LTRIM$(STR$(XNOD)): IF LEN(B$) = 1 THEN B$ = "0" + B$
  248.         MID$(DATEX$, 4, 2) = B$: GOTO CHNGMOYR
  249.     CASE "w": MID$(DATEX$, 4, 2) = "01": GOTO CHNGMOYR
  250.     CASE "K"
  251.         A1$ = MID$(DATEX$, 1, 2): SPRVAR$ = "MINUS"
  252.         GOSUB NEXTDAY: SPRVAR$ = ""
  253.         IF A1$ <> MID$(DATEX$, 1, 2) THEN A1$ = "": MO = VAL(MID$(DATEX$, 1, 2)): YR = VAL(MID$(DATEX$, 7, 4)): GOTO SETCAL
  254.         KW$ = MID$(DATEX$, 4, 2): SPRVAR$ = "NOSCSV"
  255.         A1$ = ""
  256.  
  257. GETDOW:
  258. SELECT CASE (VAL(KW$) + XOVER - 1) MOD 7
  259.     CASE 1: SELDT$ = "SUNDAY"
  260.     CASE 2: SELDT$ = "MONDAY"
  261.     CASE 3: SELDT$ = "TUESDAY"
  262.     CASE 4: SELDT$ = "WEDNESDAY"
  263.     CASE 5: SELDT$ = "THURSDAY"
  264.     CASE 6: SELDT$ = "FRIDAY"
  265.     CASE 7: SELDT$ = "SATURDAY"
  266. IF (VAL(KW$) + XOVER - 1) MOD 7 = 0 THEN SELDT$ = "SATURDAY"
  267. SELDT$ = SELDT$ + ", " + MONTH$ + "-" + KW$ + "-" + LTRIM$(STR$(YR))
  268.  
  269. IF B$ = CHR$(13) THEN
  270.     IF VAL(KW$) < 1 OR VAL(KW$) > XNOD THEN KW$ = "": GOTO SETCAL: REM ILLEGAL #
  271.     ACT$ = "MAIN": MID$(DATEX$, 4, 2) = KW$: GOTO ENDCAL1
  272.  
  273. LOCATE 1, 1
  274. IF SPRVAR$ = "GETDOW" THEN ELSE GOTO SETCAL
  275.  
  276. ENDCAL1:
  277. IF SPRVAR$ <> "GETDOW" THEN
  278.     SPRVAR$ = ""
  279. IF B$ = CHR$(27) AND ACT$ = "MAIN" THEN ACT$ = "": DATEX$ = ""
  280. IF SPRVAR$ = "NOSCSV" THEN SPRVAR$ = ""
  281.  
  282. NEXTDAY:
  283. IF SPRVAR$ = "MINUS" THEN GOTO MINUSX
  284. PLUSX:
  285.     X = VAL(MID$(DATEX$, 4, 2))
  286.     I = VAL(MID$(DATEX$, 1, 2))
  287.     J = VAL(MID$(DATEX$, 7, 4))
  288.     IF X < 28 THEN X = X + 1: EXIT DO
  289.  
  290.     IF I = 2 AND X >= 28 THEN
  291.         'IF X = 29 THEN I = I + 1: X = 1: REM NOT NEEDED. INCLUDED TO MATCH OTHER CALENDAR.
  292.         IF J MOD 4 = 0 THEN X = X + 1 ELSE I = I + 1: X = 1
  293.         EXIT DO
  294.     END IF
  295.  
  296.     IF X = 31 THEN I = I + 1: X = 1
  297.  
  298.     IF X = 30 THEN
  299.         IF I = 4 OR I = 6 OR I = 9 OR I = 11 THEN I = I + 1: X = 1 ELSE X = X + 1
  300.         EXIT DO
  301.     END IF
  302.  
  303.     IF X = 28 OR X = 29 THEN X = X + 1
  304.  
  305.     IF I = 13 THEN I = 1: X = 1: J = J + 1
  306.     EXIT DO
  307. GOTO MKDATE
  308.  
  309. MINUSX:
  310.     X = VAL(MID$(DATEX$, 4, 2))
  311.     I = VAL(MID$(DATEX$, 1, 2))
  312.     J = VAL(MID$(DATEX$, 7, 4))
  313.     X = X - 1
  314.  
  315.     IF X = 0 THEN
  316.         I = I - 1: IF I = 0 THEN J = J - 1: X = 31: I = 12: EXIT DO
  317.         IF I = 2 THEN
  318.             IF J MOD 4 = 0 THEN X = 29: EXIT DO ELSE X = 28: EXIT DO
  319.             X = 28: EXIT DO
  320.         END IF
  321.         IF I = 4 OR I = 6 OR I = 9 OR I = 11 THEN X = 30 ELSE X = 31
  322.     END IF
  323.  
  324.     EXIT DO
  325.  
  326. MKDATE:
  327. A$ = "00"
  328. A$ = "0" + LTRIM$(STR$(I)): IF LEN(A$) > 2 THEN A$ = MID$(A$, 2)
  329. MID$(DATEX$, 1, 2) = A$
  330. A$ = "0" + LTRIM$(STR$(X)): IF LEN(A$) > 2 THEN A$ = MID$(A$, 2)
  331. MID$(DATEX$, 4, 2) = A$
  332. A$ = "0000" + LTRIM$(STR$(J)): IF LEN(A$) > 4 THEN A$ = MID$(A$, LEN(A$) - 3)
  333. MID$(DATEX$, 7, 4) = A$
  334.  
  335. ENDCALSUB:
  336.  

The one I used for my office worked with a mouse. This one is bare bones, and only works with the keys shown at the bottom. The PCOPY is for using it as a pop up when another screen is present. Stuff on screen, blah, blah, blah, press a key to call the calendar, the calendar pops up over the existing screen, press esc or select dat, and the calendar pop up would close an control was returned to the window underneath it.

Pete
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Free Calendar
« Reply #6 on: December 09, 2018, 04:49:56 pm »
Again nice, handy for getting / setting dates.

I think I see leap year calculation but still looking for day month starts calc (no big long formula?). ;)

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
    • View Profile
Re: Free Calendar
« Reply #7 on: December 09, 2018, 05:33:08 pm »
It's been a very long time, but I would bet I found the stat date at say year zero, counted the number of leap years that would have transpired, and did a mod 7 to find how many units away from that start day.

I made very few REM statements back in those days. In fact, the original code wasn't even indented. I used the QB64 IDE to do that, before posting it.

Pete
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/