Print Page - Free Calendar

Title: Free Calendar
Post by: bplus 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]

_TITLE "Calendar" 'B+ 2018-12-08 from SmallBASIC old FLTK files (PalmOS version)
' This program creates 5 or 6 row calendars (Sun thru Sat) depending upon needs of month.
' You will see the preview on the screen.
' I used _MAPTRIANGLE to put the calendar in landscape view so will print on normal
' typewriter sheet: 8.5 X 11 inches, USA measure, with Windows 10 and HP envy 5530 printer.
 
CONST XMAX = 1100
CONST YMAX = 760
CONST tMar = 40 'top margin allows room for 3 hole binder punch on top (landscape orientation) or left side (portrait orientation)
CONST sideMar = 10
SCREEN _NEWIMAGE(XMAX, YMAX, 32)
_SCREENMOVE 100, 0
DIM dayNames$(0 TO 6), monthNames$(1 TO 12), monthDays(1 TO 12) AS INTEGER
FOR i = 0 TO 6: READ dayNames$(i): NEXT
DATA "Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday"
FOR i = 1 TO 12: READ monthNames$(i): NEXT
DATA "January","February","March","April","May","June","July","August","September","October","November","December"
FOR i = 1 TO 12: READ monthDays(i): NEXT
DATA 31,28,31,30,31,30,31,31,30,31,30,31
 
' this loads and checks fonts (Windows 10)
DIM SHARED FH, CH, CW, FH2, CH2, CW2
FH = _LOADFONT("ARLRDBD.ttf", 24, "MONOSPACE")
IF FH <= 0 THEN PRINT "Trouble with font load file, goodbye.": SLEEP: END
CH = _FONTHEIGHT(FH): CW = CH * .6 'this make printing char by char the same as printing a string for ARLRDBD.ttf
_FONT FH
'test font, in box? for 5 above 5 below height = 30
LINE (5, 5)-STEP(CW * LEN(monthNames$(1) + STR$(2018)), 30), , B
_PRINTSTRING (10, 10), monthNames$(1) + STR$(2018)
 
FH2 = _LOADFONT("ARLRDBD.ttf", 18, "MONOSPACE")
IF FH2 <= 0 THEN PRINT "Trouble with font load file, goodbye.": SLEEP: END
CH2 = _FONTHEIGHT(FH2): CW2 = CH2 * .5 'this make printing char by char the same as printing a string for ARLRDBD.ttf
_FONT FH2
LINE (5, 45)-STEP(CW2 * LEN("testing smaller font 1, 2, 3, 31"), 25), , B
_PRINTSTRING (10, 50), "testing smaller font 1, 2, 3, 31"
 
y = 2019 'free calendar
FOR m = 1 TO 12
    'WHILE 1
    'LOCATE 10, 1
    'LINE INPUT "Enter Month Number,Year Number ", ln$
    'ln$ = "8, 2018" '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< just plug in year here until debugged
    'm = VAL(leftOf$(ln$, ","))
    'y = VAL(rightOf$(ln$, ","))
    'IF m = 0 OR y = 0 THEN END
 
 
    COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
    CLS
 
    'day month starts, probably the most crucial formula from the SnallBASIC program
    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
    ' fix leap year for true = -1
    IF y MOD 400 = 0 THEN b1 = 1 ELSE b1 = 0
    IF y MOD 100 <> 0 THEN b2 = 1 ELSE b2 = 0
    IF b1 = 1 OR b2 = 1 THEN b3 = 1 ELSE b3 = 0
    IF y MOD 4 = 0 THEN b1 = 1 ELSE b1 = 0
    IF b1 = 1 AND b3 = 1 THEN add = 1 ELSE add = 0
    monthDays(2) = 28 + add
    'from these calcs for month year determine amount of rows calendar will need
    rows = (monthDays(m) + d + 6) \ 7
    boxW = INT((XMAX - 2 * sideMar) / 7)
    monthYear$ = monthNames$(m) + STR$(y)
    _FONT FH2
    IF rows = 5 THEN
        yTitle = tMar + 5
        yDayNames = tMar + 40 'strings  line above is -5 and line below is yTopGrid
        yTopGrid = yDayNames + 20
        boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
        yBottomGrid = yTopGrid + rows * boxH
 
        'center monthYear$ at top
        _FONT FH
        _PRINTSTRING ((XMAX - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
        _FONT FH2
    ELSE
        yDayNames = tMar + 5 ' for day name strings,  line above is -5 and line below is yTopGrid
        yTopGrid = yDayNames + 20
        boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
        yBottomGrid = yTopGrid + rows * boxH
        yTitle = yTopGrid + .5 * boxH - 10
        ' print month year title after the rest of the calendar is done
    END IF
 
    LINE (sideMar, yDayNames - 5)-STEP(7 * boxW, 1), , BF
    'verticals and daytitles
    FOR day = 0 TO 7
        x = sideMar + day * boxW
        LINE (x, yDayNames - 5)-(x + 1, yBottomGrid), , BF
        IF day < 7 THEN
            xoff = (boxW - LEN(dayNames$(day)) * CW2) / 2
            _PRINTSTRING (x + xoff, yDayNames), dayNames$(day)
        END IF
    NEXT
    LINE (sideMar, yTopGrid)-STEP(7 * boxW, 1), , BF
    ' horizontals
    FOR n = 1 TO rows
        LINE (sideMar, yTopGrid + boxH * n)-STEP(7 * boxW, 1), , BF
    NEXT
    ' dates
    FOR i = 0 TO monthDays(m) - 1
        row = (d + i) \ 7
        col = (d + i) MOD 7
        _PRINTSTRING (col * boxW + sideMar + 5, row * boxH + yTopGrid + 5), LTRIM$(STR$(i + 1))
    NEXT
    IF rows = 6 THEN 'insert month name in top row about 200 in?
        'first clear lines in first 4 blocks
        LINE (sideMar + 2, yTopGrid + 2)-STEP(4 * boxW - 4, boxH - 3), _RGB32(255, 255, 255), BF
        'center monthYear$ in first 4 blocks (never used in 6 row calendar)
        _FONT FH
        _PRINTSTRING (sideMar + (4 * boxW - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
        _FONT FH2
    END IF
    'printer prep
    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&     '<<<<<<<<<<<<<<<<<<<<<<<<< debug first before wasting paper and ink
    _DELAY 5
    'wend
NEXT m
END
 
FUNCTION leftOf$ (source$, of$)
    posOf = INSTR(source$, of$)
    IF posOf > 0 THEN leftOf$ = MID$(source$, 1, posOf - 1)
END FUNCTION
 
FUNCTION rightOf$ (source$, of$)
    posOf = INSTR(source$, of$)
    IF posOf > 0 THEN rightOf$ = MID$(source$, posOf + LEN(of$))
END FUNCTION
 
 

Title: Re: Free Calendar
Post by: Ashish 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.

Title: Re: Free Calendar
Post by: bplus 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.

Title: Re: Free Calendar
Post by: Pete 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]

pete = 8
_TITLE "Calendar" 'B+ 2018-12-08 from SmallBASIC old FLTK files (PalmOS version)
' This program creates 5 or 6 row calendars (Sun thru Sat) depending upon needs of month.
' You will see the preview on the screen.
' I used _MAPTRIANGLE to put the calendar in landscape view so will print on normal
' typewriter sheet: 8.5 X 11 inches, USA measure, with Windows 10 and HP envy 5530 printer.
 
CONST XMAX = 1100 / 1.2
CONST YMAX = 760 / 1.2
CONST tMar = 40 'top margin allows room for 3 hole binder punch on top (landscape orientation) or left side (portrait orientation)
CONST sideMar = 10
SCREEN _NEWIMAGE(XMAX, YMAX, 32)
_SCREENMOVE 100, 0
DIM dayNames$(0 TO 6), monthNames$(1 TO 12), monthDays(1 TO 12) AS INTEGER
FOR i = 0 TO 6: READ dayNames$(i): NEXT
DATA "Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday"
FOR i = 1 TO 12: READ monthNames$(i): NEXT
DATA "January","February","March","April","May","June","July","August","September","October","November","December"
FOR i = 1 TO 12: READ monthDays(i): NEXT
DATA 31,28,31,30,31,30,31,31,30,31,30,31
 
' this loads and checks fonts (Windows 10)
DIM SHARED FH, CH, CW, FH2, CH2, CW2
FH = _LOADFONT("lucon.ttf", 26)
IF FH <= 0 THEN PRINT "Trouble with font load file, goodbye.": SLEEP: END
CH = _FONTHEIGHT(FH): CW = CH * .6 'this make printing char by char the same as printing a string for ARLRDBD.ttf
_FONT FH
'test font, in box? for 5 above 5 below height = 30
LINE (5, 5)-STEP(CW * LEN(monthNames$(1) + STR$(2018)), 30), , B
_PRINTSTRING (10, 10), monthNames$(1) + STR$(2018)
 
FH2 = _LOADFONT("lucon.ttf", 20)
IF FH2 <= 0 THEN PRINT "Trouble with font load file, goodbye.": SLEEP: END
CH2 = _FONTHEIGHT(FH2): CW2 = CH2 * .5 'this make printing char by char the same as printing a string for ARLRDBD.ttf
_FONT FH2
LINE (5, 45)-STEP(CW2 * LEN("testing smaller font 1, 2, 3, 31"), 25), , B
_PRINTSTRING (10, 50), "testing smaller font 1, 2, 3, 31"
 
y = 2019 'free calendar
FOR m = 1 TO 12
    'WHILE 1
    'LOCATE 10, 1
    'LINE INPUT "Enter Month Number,Year Number ", ln$
    'ln$ = "8, 2018" '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< just plug in year here until debugged
    'm = VAL(leftOf$(ln$, ","))
    'y = VAL(rightOf$(ln$, ","))
    'IF m = 0 OR y = 0 THEN END
 
 
    COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
    CLS
 
    'day month starts, probably the most crucial formula from the SnallBASIC program
    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
    ' fix leap year for true = -1
    IF y MOD 400 = 0 THEN b1 = 1 ELSE b1 = 0
    IF y MOD 100 <> 0 THEN b2 = 1 ELSE b2 = 0
    IF b1 = 1 OR b2 = 1 THEN b3 = 1 ELSE b3 = 0
    IF y MOD 4 = 0 THEN b1 = 1 ELSE b1 = 0
    IF b1 = 1 AND b3 = 1 THEN add = 1 ELSE add = 0
    monthDays(2) = 28 + add
    'from these calcs for month year determine amount of rows calendar will need
    rows = (monthDays(m) + d + 6) \ 7
    boxW = INT((XMAX - 2 * sideMar) / 7)
    monthYear$ = monthNames$(m) + STR$(y)
    _FONT FH2
    IF rows = 5 THEN
        yTitle = tMar + 5
        yDayNames = tMar + 40 'strings  line above is -5 and line below is yTopGrid
        yTopGrid = yDayNames + 20
        boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
        yBottomGrid = yTopGrid + rows * boxH
 
        'center monthYear$ at top
        _FONT FH
        _PRINTSTRING ((XMAX - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
        _FONT FH2
    ELSE
        yDayNames = tMar + 5 ' for day name strings,  line above is -5 and line below is yTopGrid
        yTopGrid = yDayNames + 20
        boxH = INT((YMAX - yTopGrid - sideMar) \ rows)
        yBottomGrid = yTopGrid + rows * boxH
        yTitle = yTopGrid + .5 * boxH - 10
        ' print month year title after the rest of the calendar is done
    END IF
 
    LINE (sideMar, yDayNames - 5)-STEP(7 * boxW, 1), , BF
    'verticals and daytitles
    FOR day = 0 TO 7
        x = sideMar + day * boxW
        LINE (x, yDayNames - 5)-(x + 1, yBottomGrid), , BF
        IF day < 7 THEN
            xoff = (boxW - LEN(dayNames$(day)) * CW2) / 2 - pete
            _PRINTSTRING (x + xoff, yDayNames), dayNames$(day)
        END IF
    NEXT
    LINE (sideMar, yTopGrid)-STEP(7 * boxW, 1), , BF
    ' horizontals
    FOR n = 1 TO rows
        LINE (sideMar, yTopGrid + boxH * n)-STEP(7 * boxW, 1), , BF
    NEXT
    ' dates
    FOR i = 0 TO monthDays(m) - 1
        row = (d + i) \ 7
        col = (d + i) MOD 7
        _PRINTSTRING (col * boxW + sideMar + 5, row * boxH + yTopGrid + 5), LTRIM$(STR$(i + 1))
    NEXT
    IF rows = 6 THEN 'insert month name in top row about 200 in?
        'first clear lines in first 4 blocks
        LINE (sideMar + 2, yTopGrid + 2)-STEP(4 * boxW - 4, boxH - 3), _RGB32(255, 255, 255), BF
        'center monthYear$ in first 4 blocks (never used in 6 row calendar)
        _FONT FH
        _PRINTSTRING (sideMar + (4 * boxW - LEN(monthYear$) * CW) / 2, yTitle), monthYear$
        _FONT FH2
    END IF
    'printer prep
    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&     '<<<<<<<<<<<<<<<<<<<<<<<<< debug first before wasting paper and ink
    _DELAY 5
    'wend
NEXT m
END
 
FUNCTION leftOf$ (source$, of$)
posOf = INSTR(source$, of$)
IF posOf > 0 THEN leftOf$ = MID$(source$, 1, posOf - 1)
END FUNCTION
 
FUNCTION rightOf$ (source$, of$)
posOf = INSTR(source$, of$)
IF posOf > 0 THEN rightOf$ = MID$(source$, posOf + LEN(of$))
END FUNCTION
 
 

Title: Re: Free Calendar
Post by: bplus 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!

Title: Re: Free Calendar
Post by: Pete 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]

DECLARE SUB CALENDAR (DATEX$)
CALL CALENDAR(DATEX$)
 
SUB CALENDAR (DATEX$)
BORDER = 14
SCREEN 0, 0, 4, 5
IF SMODE% = 0 THEN PCOPY 0, 5
IF SMODE% = 1 THEN PCOPY 1, 5
PCOPY 5, 4
LOCATE , , 0, 7, 0
VIEW PRINT 1 TO 25
 
COLOR 7, 0
DATEX$ = DATE$
SPRVAR$ = "GETDOW": KW$ = MID$(DATEX$, 4, 2): GOSUB CALSUB
ACT$ = "MAIN"
GOSUB CALSUB
IF SMODE% = 0 THEN SCREEN 0, 0, 0, 0
IF SMODE% = 1 THEN SCREEN 0, 0, 1, 1
GOTO ENDCALSUB
 
BOX:
COLOR BORDER, 1: LOCATE W1 - 1, W2: PRINT CHR$(218) + STRING$(50, 196) + CHR$(191);
LOCATE W1, W2
FOR I = 1 TO W3
    A$ = ""
    COLOR 7, 1
    LOCATE , W2
    IF INSTR(A$, CHR$(2)) <> 0 THEN A$ = MID$(A$, 1, INSTR(A$, CHR$(2)) - 1)
    A$ = A$ + SPACE$(W4 - LEN(A$))
 
    PRINT A$;
 
    COLOR 9, 1: PRINT CHR$(219) + CHR$(219)
NEXT I
 
LOCATE , W2 + 1: PRINT STRING$(W4 + 1, 219);
COLOR 7, 0
RETURN
 
CALSUB:
COLOR 7, 0
 
CHNGMOYR:
MO = VAL(MID$(DATEX$, 1, 2))
YR = VAL(MID$(DATEX$, 7, 4))
 
SETCAL:
SELECT CASE MO
    CASE 1: MONTH$ = "JANUARY"
    CASE 2: MONTH$ = "FEBRUARY"
    CASE 3: MONTH$ = "MARCH"
    CASE 4: MONTH$ = "APRIL"
    CASE 5: MONTH$ = "MAY"
    CASE 6: MONTH$ = "JUNE"
    CASE 7: MONTH$ = "JULY"
    CASE 8: MONTH$ = "AUGUST"
    CASE 9: MONTH$ = "SEPTEMBER"
    CASE 10: MONTH$ = "OCTOBER"
    CASE 11: MONTH$ = "NOVEMBER"
    CASE 12: MONTH$ = "DECEMBER"
END SELECT
 
XDAYS = (YR - 1) * 365 + (YR - 1) \ 4 - (YR - 1) \ 400
FOR I = 1 TO MO - 1
    X = 30
    IF I = 1 OR I = 3 OR I = 5 OR I = 7 OR I = 8 OR I = 10 OR I = 12 THEN X = 31
    IF I = 2 THEN
        X = 28
        IF YR MOD 4 = 0 THEN
            IF YR MOD 100 = 0 THEN
                IF YR MOD 400 = 0 THEN
                    X = 29
                END IF
            ELSE
                X = 29
            END IF
        END IF
    END IF
    XDAYS = XDAYS + X
NEXT I
XNOD = 30
IF I = 1 OR I = 3 OR I = 5 OR I = 7 OR I = 8 OR I = 10 OR I = 12 THEN XNOD = 31
IF I = 2 THEN XNOD = 28
IF MO = 2 AND YR MOD 4 = 0 THEN
    IF YR MOD 100 = 0 THEN
        IF YR MOD 400 = 0 THEN XNOD = XNOD + 1
    ELSE
        XNOD = XNOD + 1
    END IF
END IF
XOVER = (XDAYS + 6) MOD 7: IF XOVER = 0 THEN XOVER = 7
IF A1$ <> "" OR SPRVAR$ = "GETDOW" THEN GOTO GETDOW: REM MAKES AN ENDLESS LOOP WHEN MIXED WITH ENTERING A NEW PATIENT.
XL = 4
A1$ = CHR$(218) + STRING$(XL, CHR$(196)) + CHR$(191)
A2$ = CHR$(179) + STRING$(XL, CHR$(32)) + CHR$(179)
A3$ = CHR$(192) + STRING$(XL, CHR$(196)) + CHR$(217)
B1$ = A1$: B2$ = A2$: B3$ = A3$
FOR I = 1 TO 7 - 1
    A1$ = A1$ + " " + B1$
    A2$ = A2$ + " " + B2$
    A3$ = A3$ + " " + B3$
NEXT I
 
XX = 4: YY = 40 - INT(LEN(A1$) / 2)
W1 = XX: W2 = YY - 1 - 1: W4 = LEN(A1$) + 2 + 2: W3 = 19
 
IF SPRVAR$ <> "NOSCSV" THEN
    IF XBOXSAVE = 0 THEN
        LOCATE XX, YY: GOSUB BOX: XBOXSAVE = 1
        COLOR 11, 1
        LOCATE 25, 1: PRINT SPACE$(80);: LOCATE 25, 1
        PRINT "  CHOOSE A DATE AND PRESS [ENTER] TO SELECT IT. PRESS [ESC] TO CLOSE CALENDER.";
    END IF
    LOCATE XX + 1, YY, 0, 7, 0
    COLOR 11, 1
    PRINT " Sun.   Mon.   Tue.   Wed.   Thu.   Fri.   Sat. "
 
    NXTCAL:
    COLOR BORDER, 1
    LOCATE XX - 1, W2 + 1: PRINT STRING$(W4 - 2, 196);
    COLOR BORDER, 1
    LOCATE XX - 1, 40 - (LEN(MONTH$) + LEN(LTRIM$(STR$(YR)))) \ 2 - 1: PRINT "<" + MONTH$ + "/" + LTRIM$(STR$(YR)) + ">"
    COLOR BORDER, 1
    LOCATE XX + 2, YY
    FOR I = 1 TO 5
        PRINT A1$
        FOR J = 1 TO 1
            LOCATE CSRLIN, YY
            PRINT A2$
        NEXT J
        LOCATE CSRLIN, YY
        PRINT A3$;: XEND = POS(1): PRINT
        LOCATE CSRLIN, YY
    NEXT I
 
ELSE
    IF SPRVAR$ = "NOSCSV" THEN SPRVAR$ = ""
END IF
 
LOCATE XX + 2, YY - 3
J = CSRLIN + 1
LOCATE J, POS(1) + -7 + 7 * XOVER
 
LOCDATE = VAL(MID$(DATEX$, 4, 2))
 
FOR I = 1 TO XNOD
    LOCATE J, POS(1) + 5
    IF I < 10 THEN XI$ = " " + LTRIM$(STR$(I)) ELSE XI$ = LTRIM$(STR$(I))
 
    IF I >= 30 AND POS(1) >= XEND THEN
        LOCATE CSRLIN, YY + 1
 
        IF I = 30 THEN
            COLOR 11, 1
            IF LOCDATE = 23 THEN COLOR 1, 3
            PRINT "23";
            COLOR 7, 1
            IF LOCDATE = 30 THEN COLOR 7, 3
            PRINT "30";
            IF XNOD = 30 THEN EXIT FOR
        END IF
 
        IF I = 31 AND XNOD = 31 THEN
            COLOR 11, 1
            IF LOCDATE = 24 THEN COLOR 11, 3
            PRINT "24";
            COLOR 7, 1
            IF LOCDATE = 31 THEN COLOR 7, 3
            PRINT "31": EXIT FOR
        END IF
 
        IF I = 30 AND XNOD = 31 THEN
            COLOR 14, 1
            IF LOCDATE = 24 THEN COLOR 14, 4
            LOCATE CSRLIN, YY + 1 + 7: PRINT "24";
            COLOR 7, 1
            IF LOCDATE = 31 THEN COLOR 7, 3
            PRINT "31": EXIT FOR
        END IF
    END IF
 
    IF POS(1) >= XEND THEN
        J = J + 3: LOCATE J, YY + 2
        COLOR 3, 1
    ELSE
        COLOR 14, 1
    END IF
 
    IF I = LOCDATE THEN
        YY1 = POS(1): COLOR 14, 4
        IF YY1 <= W2 + 1 + 3 THEN COLOR 1, 3: REM  - 1
    ELSE IF (I + XOVER - 1) MOD 7 = 1 THEN COLOR 11, 1 ELSE COLOR 14, 1
    END IF
 
    PRINT XI$;
NEXT I
 
COLOR 3, 1
LOCATE XX + 17, YY + 21: PRINT "[PgUp/PgDn]=Mo [Bksp]=Today";
LOCATE XX + 17, YY: PRINT "["; CHR$(24); "/"; CHR$(25); "/"; CHR$(27); "/"; CHR$(26); "]=Find Date";
COLOR 15, 1
 
DO
    IF ACT$ = "CALHOME" OR ACT$ = "CALEND" THEN
        IF YY1 <= W2 + 1 + 3 OR YY1 >= XEND - 4 THEN ACT$ = "": REM  - 1
        IF LOCDATE = XNOD OR LOCDATE = 1 THEN ACT$ = ""
    END IF
 
    SELECT CASE ACT$
        CASE "CALHOME": B$ = " G": EXIT DO
        CASE "CALEND": B$ = " O": EXIT DO
        CASE "CALUP": XNT = XNT + 1: B$ = " H": IF XNT = 7 THEN XNT = 0: ACT$ = "" ELSE EXIT DO
        CASE "CALDN": XNT = XNT + 1: B$ = " P": IF XNT = 7 THEN XNT = 0: ACT$ = "" ELSE EXIT DO
    END SELECT
 
    COLOR BORDER, 1: LOCATE W1 + W3 - 1, W2: PRINT CHR$(192) + STRING$(50, 196) + CHR$(217);
    LOCATE W1, W2
    FOR I = 1 TO W3 - 1
        PRINT CHR$(179);: LOCATE , W2 + W4 - 1: PRINT CHR$(179)
        LOCATE , W2
    NEXT I
 
    COLOR 15, 1
    SCREEN 0, 0, 5, 5: LOCATE XX, YY: SCREEN 0, 0, 4, 5
    PCOPY 4, 5: SMODE = 4: LOCATE XX, YY
    Z1 = TIMER: DO
        B$ = INKEY$
        IF B$ = "/" OR B$ = "?" THEN B$ = CHR$(27)
        IF B$ <> "" THEN IF INSTR("KMHPIQOGuw", MID$(B$, 2, 1)) <> 0 OR B$ = CHR$(27) THEN EXIT DO
        Z2 = TIMER
        IF ABS(Z1 - Z2) >= W9 THEN B$ = CHR$(27)
    LOOP
 
    IF KW$ <> "" THEN EXIT DO
LOOP
 
IF LEN(KW$) = 1 THEN KW$ = "0" + KW$
IF B$ = CHR$(27) THEN LOCATE XX, YY: DATEX$ = "": GOTO ENDCAL1
IF B$ = CHR$(8) THEN DATEX$ = DATE$: MO = VAL(MID$(DATEX$, 1, 2)): YR = VAL(MID$(DATEX$, 7, 4)): SPRVAR$ = "": A1$ = "": GOTO GETDOW
A1$ = "": SPRVAR$ = "NOSCSV"
CALB:
SELECT CASE MID$(B$, 2, 1)
    CASE "I": SPRVAR$ = "": MID$(DATEX$, 4, 2) = "01": MO = MO - 1: IF MO = 0 THEN MO = 12: YR = YR - 1
    CASE "Q": SPRVAR$ = "": MID$(DATEX$, 4, 2) = "01": MO = MO + 1: IF MO = 13 THEN MO = 1: YR = YR + 1
    CASE "G": IF YY1 <> W2 + 1 + 3 THEN B$ = "0K": ACT$ = "CALHOME": GOTO CALB: REM  - 1
    CASE "O": IF YY1 <> XEND THEN B$ = "0M": ACT$ = "CALEND": GOTO CALB
    CASE "H": B$ = "0K": ACT$ = "CALUP": GOTO CALB
    CASE "P": B$ = "0M": ACT$ = "CALDN": GOTO CALB
    CASE "M"
        IF LOCDATE = XNOD THEN
            KW$ = "01": MO = MO + 1: IF MO = 13 THEN MO = 1: YR = YR + 1
            B$ = LTRIM$(STR$(MO)): IF LEN(B$) = 1 THEN B$ = "0" + B$
            DATEX$ = B$ + "-01-" + LTRIM$(STR$(YR))
            SPRVAR$ = ""
            GOTO SETCAL
        END IF
        SPRVAR$ = "PLUSX": GOSUB NEXTDAY: SPRVAR$ = "": KW$ = MID$(DATEX$, 4, 2): SPRVAR$ = "NOSCSV"
    CASE "u"
        B$ = LTRIM$(STR$(XNOD)): IF LEN(B$) = 1 THEN B$ = "0" + B$
        MID$(DATEX$, 4, 2) = B$: GOTO CHNGMOYR
    CASE "w": MID$(DATEX$, 4, 2) = "01": GOTO CHNGMOYR
    CASE "K"
        A1$ = MID$(DATEX$, 1, 2): SPRVAR$ = "MINUS"
        GOSUB NEXTDAY: SPRVAR$ = ""
        IF A1$ <> MID$(DATEX$, 1, 2) THEN A1$ = "": MO = VAL(MID$(DATEX$, 1, 2)): YR = VAL(MID$(DATEX$, 7, 4)): GOTO SETCAL
        KW$ = MID$(DATEX$, 4, 2): SPRVAR$ = "NOSCSV"
        A1$ = ""
END SELECT
 
GETDOW:
SELECT CASE (VAL(KW$) + XOVER - 1) MOD 7
    CASE 1: SELDT$ = "SUNDAY"
    CASE 2: SELDT$ = "MONDAY"
    CASE 3: SELDT$ = "TUESDAY"
    CASE 4: SELDT$ = "WEDNESDAY"
    CASE 5: SELDT$ = "THURSDAY"
    CASE 6: SELDT$ = "FRIDAY"
    CASE 7: SELDT$ = "SATURDAY"
END SELECT
IF (VAL(KW$) + XOVER - 1) MOD 7 = 0 THEN SELDT$ = "SATURDAY"
SELDT$ = SELDT$ + ", " + MONTH$ + "-" + KW$ + "-" + LTRIM$(STR$(YR))
 
IF B$ = CHR$(13) THEN
    IF VAL(KW$) < 1 OR VAL(KW$) > XNOD THEN KW$ = "": GOTO SETCAL: REM ILLEGAL #
    ACT$ = "MAIN": MID$(DATEX$, 4, 2) = KW$: GOTO ENDCAL1
END IF
 
LOCATE 1, 1
IF SPRVAR$ = "GETDOW" THEN ELSE GOTO SETCAL
 
ENDCAL1:
IF SPRVAR$ <> "GETDOW" THEN
ELSE
    SPRVAR$ = ""
END IF
IF B$ = CHR$(27) AND ACT$ = "MAIN" THEN ACT$ = "": DATEX$ = ""
IF SPRVAR$ = "NOSCSV" THEN SPRVAR$ = ""
RETURN
 
NEXTDAY:
IF SPRVAR$ = "MINUS" THEN GOTO MINUSX
PLUSX:
DO
    X = VAL(MID$(DATEX$, 4, 2))
    I = VAL(MID$(DATEX$, 1, 2))
    J = VAL(MID$(DATEX$, 7, 4))
    IF X < 28 THEN X = X + 1: EXIT DO
 
    IF I = 2 AND X >= 28 THEN
        'IF X = 29 THEN I = I + 1: X = 1: REM NOT NEEDED. INCLUDED TO MATCH OTHER CALENDAR.
        IF J MOD 4 = 0 THEN X = X + 1 ELSE I = I + 1: X = 1
        EXIT DO
    END IF
 
    IF X = 31 THEN I = I + 1: X = 1
 
    IF X = 30 THEN
        IF I = 4 OR I = 6 OR I = 9 OR I = 11 THEN I = I + 1: X = 1 ELSE X = X + 1
        EXIT DO
    END IF
 
    IF X = 28 OR X = 29 THEN X = X + 1
 
    IF I = 13 THEN I = 1: X = 1: J = J + 1
    EXIT DO
LOOP
GOTO MKDATE
 
MINUSX:
DO
    X = VAL(MID$(DATEX$, 4, 2))
    I = VAL(MID$(DATEX$, 1, 2))
    J = VAL(MID$(DATEX$, 7, 4))
    X = X - 1
 
    IF X = 0 THEN
        I = I - 1: IF I = 0 THEN J = J - 1: X = 31: I = 12: EXIT DO
        IF I = 2 THEN
            IF J MOD 4 = 0 THEN X = 29: EXIT DO ELSE X = 28: EXIT DO
            X = 28: EXIT DO
        END IF
        IF I = 4 OR I = 6 OR I = 9 OR I = 11 THEN X = 30 ELSE X = 31
    END IF
 
    EXIT DO
LOOP
 
MKDATE:
A$ = "00"
A$ = "0" + LTRIM$(STR$(I)): IF LEN(A$) > 2 THEN A$ = MID$(A$, 2)
MID$(DATEX$, 1, 2) = A$
A$ = "0" + LTRIM$(STR$(X)): IF LEN(A$) > 2 THEN A$ = MID$(A$, 2)
MID$(DATEX$, 4, 2) = A$
A$ = "0000" + LTRIM$(STR$(J)): IF LEN(A$) > 4 THEN A$ = MID$(A$, LEN(A$) - 3)
MID$(DATEX$, 7, 4) = A$
RETURN
 
ENDCALSUB:
END SUB
 

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

Title: Re: Free Calendar
Post by: bplus 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?). ;)

Title: Re: Free Calendar
Post by: Pete 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

Text Only | Text with Attachments

QB64.org Forum

Active Forums => Programs => Topic started by: bplus on December 08, 2018, 04:32:38 pm