« previous next »
Pages: [1]   Go Down

Author Topic: Free Calendar  (Read 5358 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)
  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("ARLRDBD.ttf", 24, "MONOSPACE")
  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
  27. 'test font, in box? for 5 above 5 below height = 30
  28. LINE (5, 5)-STEP(CW * LEN(monthNames$(1) + STR$(2018)), 30), , B
  29. _PRINTSTRING (10, 10), monthNames$(1) + STR$(2018)
  30.  
  31. FH2 = _LOADFONT("ARLRDBD.ttf", 18, "MONOSPACE")
  32. IF FH2 <= 0 THEN PRINT "Trouble with font load file, goodbye.": SLEEP: END
  33. CH2 = _FONTHEIGHT(FH2): CW2 = CH2 * .5 'this make printing char by char the same as printing a string for ARLRDBD.ttf
  34. _FONT FH2
  35. LINE (5, 45)-STEP(CW2 * LEN("testing smaller font 1, 2, 3, 31"), 25), , B
  36. _PRINTSTRING (10, 50), "testing smaller font 1, 2, 3, 31"
  37.  
  38. y = 2019 'free calendar
  39. FOR m = 1 TO 12
  40.     'WHILE 1
  41.     'LOCATE 10, 1
  42.     'LINE INPUT "Enter Month Number,Year Number ", ln$
  43.     'ln$ = "8, 2018" '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< just plug in year here until debugged
  44.     'm = VAL(leftOf$(ln$, ","))
  45.     'y = VAL(rightOf$(ln$, ","))
  46.     'IF m = 0 OR y = 0 THEN END
  47.  
  48.  
  49.     COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
  50.     CLS
  51.  
  52.     'day month starts, probably the most crucial formula from the SnallBASIC program
  53.     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
  54.     ' fix leap year for true = -1
  55.     IF y MOD 400 = 0 THEN b1 = 1 ELSE b1 = 0
  56.     IF y MOD 100 <> 0 THEN b2 = 1 ELSE b2 = 0
  57.     IF b1 = 1 OR b2 = 1 THEN b3 = 1 ELSE b3 = 0
  58.     IF y MOD 4 = 0 THEN b1 = 1 ELSE b1 = 0
  59.     IF b1 = 1 AND b3 = 1 THEN add = 1 ELSE add = 0
  60.     monthDays(2) = 28 + add
  61.     'from these calcs for month year determine amount of rows calendar will need
  62.     rows = (monthDays(m) + d + 6) \ 7
  63.     boxW = INT((XMAX - 2 * sideMar) / 7)
  64.     monthYear$ = monthNames$(m) + STR$(y)
  65.     _FONT FH2
  66.     IF rows = 5 THEN
  67.         yTitle = tMar + 5
  68.         yDayNames = tMar + 40 'strings  line above is -5 and line below is yTopGrid
  69.         yTopGrid = yDayNames + 20
  70.         boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
  71.         yBottomGrid = yTopGrid + rows * boxH
  72.  
  73.         'center monthYear$ at top
  74.         _FONT FH
  75.         _PRINTSTRING ((XMAX - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
  76.         _FONT FH2
  77.     ELSE
  78.         yDayNames = tMar + 5 ' for day name strings,  line above is -5 and line below is yTopGrid
  79.         yTopGrid = yDayNames + 20
  80.         boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
  81.         yBottomGrid = yTopGrid + rows * boxH
  82.         yTitle = yTopGrid + .5 * boxH - 10
  83.         ' print month year title after the rest of the calendar is done
  84.     END IF
  85.  
  86.     LINE (sideMar, yDayNames - 5)-STEP(7 * boxW, 1), , BF
  87.     'verticals and daytitles
  88.     FOR day = 0 TO 7
  89.         x = sideMar + day * boxW
  90.         LINE (x, yDayNames - 5)-(x + 1, yBottomGrid), , BF
  91.         IF day < 7 THEN
  92.             xoff = (boxW - LEN(dayNames$(day)) * CW2) / 2
  93.             _PRINTSTRING (x + xoff, yDayNames), dayNames$(day)
  94.         END IF
  95.     NEXT
  96.     LINE (sideMar, yTopGrid)-STEP(7 * boxW, 1), , BF
  97.     ' horizontals
  98.     FOR n = 1 TO rows
  99.         LINE (sideMar, yTopGrid + boxH * n)-STEP(7 * boxW, 1), , BF
  100.     NEXT
  101.     ' dates
  102.     FOR i = 0 TO monthDays(m) - 1
  103.         row = (d + i) \ 7
  104.         col = (d + i) MOD 7
  105.         _PRINTSTRING (col * boxW + sideMar + 5, row * boxH + yTopGrid + 5), LTRIM$(STR$(i + 1))
  106.     NEXT
  107.     IF rows = 6 THEN 'insert month name in top row about 200 in?
  108.         'first clear lines in first 4 blocks
  109.         LINE (sideMar + 2, yTopGrid + 2)-STEP(4 * boxW - 4, boxH - 3), _RGB32(255, 255, 255), BF
  110.         'center monthYear$ in first 4 blocks (never used in 6 row calendar)
  111.         _FONT FH
  112.         _PRINTSTRING (sideMar + (4 * boxW - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
  113.         _FONT FH2
  114.     END IF
  115.     'printer prep
  116.     landscape& = _NEWIMAGE(YMAX, XMAX, 32)
  117.     _MAPTRIANGLE (XMAX, 0)-(0, 0)-(0, YMAX), 0 TO(0, 0)-(0, XMAX)-(YMAX, XMAX), landscape&
  118.     _MAPTRIANGLE (XMAX, 0)-(XMAX, YMAX)-(0, YMAX), 0 TO(0, 0)-(YMAX, 0)-(YMAX, XMAX), landscape&
  119.     '_PRINTIMAGE landscape&     '<<<<<<<<<<<<<<<<<<<<<<<<< debug first before wasting paper and ink
  120.     _DELAY 5
  121.     'wend
  124.  
  125. FUNCTION leftOf$ (source$, of$)
  126.     posOf = INSTR(source$, of$)
  127.     IF posOf > 0 THEN leftOf$ = MID$(source$, 1, posOf - 1)
  129.  
  130. FUNCTION rightOf$ (source$, of$)
  131.     posOf = INSTR(source$, of$)
  132.     IF posOf > 0 THEN rightOf$ = MID$(source$, posOf + LEN(of$))
  134.  
  135.  
Logged

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.
Logged
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 »
Logged

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

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

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
Logged
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?). ;)
Logged

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
Logged
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/
Pages: [1]   Go Up
« previous next »