03-04-2024, 06:43 AM
Here's a very old routine of mine you are welcome to pull some date feature from...
Pete
Code: (Select All)
WIDTH 101, 30
_FONT 16
PALETTE 5, 63
COLOR 0, 5: CLS
datex$ = DATE$:
calendar datex$, xnod, xover, getfirstday
SUB calendar (DATEX$, xnod, xover, getfirstday)
DIM m_trigr(5), m_trigc(7)
holddatex$ = DATEX$
BORDER = 14
IF getfirstday = 0 THEN PCOPY 0, 1: REM gen_pcopy 0, 1, t
LOCATE , , 0 ' Hide cursor.
COLOR 7, 0
IF getfirstday = 0 THEN DATEX$ = DATE$
SPRVAR$ = "GETDOW": KW$ = MID$(DATEX$, 4, 2): GOSUB CALSUB ' Setup
ACT$ = "MAIN"
DO
curdatex$ = DATEX$
GOSUB CALSUB ' Working calendar.
REM REESTABLISH PCOPY / SCREEN HERE.
IF setcal = 0 OR getfirstday THEN
IF setcal = 0 THEN
PCOPY 1, 0: REM gen_pcopy 1, 0, t
END IF
EXIT SUB ' Non-zero will stay in the calsub loop.
END IF
LOOP
CALSUB:
WHILE -1 ' Falx loop.
IF setcal = 0 THEN
MO = VAL(MID$(DATEX$, 1, 2))
YR = VAL(MID$(DATEX$, 7, 4))
ELSE
setcal = 0
END IF
SELECT CASE MO
CASE 1: MONTH$ = "JAN"
CASE 2: MONTH$ = "FEB"
CASE 3: MONTH$ = "MAR"
CASE 4: MONTH$ = "APR"
CASE 5: MONTH$ = "MAY"
CASE 6: MONTH$ = "JUN"
CASE 7: MONTH$ = "JUL"
CASE 8: MONTH$ = "AUG"
CASE 9: MONTH$ = "SEP"
CASE 10: MONTH$ = "OCT"
CASE 11: MONTH$ = "NOV"
CASE 12: MONTH$ = "DEC"
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 getfirstday THEN RETURN
IF A1$ <> "" OR SPRVAR$ = "GETDOW" THEN EXIT WHILE: 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
W1 = 7 ' Top
W2 = INT(_WIDTH \ 2 - LEN(A1$) \ 2) - 2 ' Left margin
W3 = 18 ' Height
W4 = LEN(A1$) + 4 ' Width
yy = W1: xx = INT(_WIDTH \ 2 - LEN(A1$) \ 2) ' Left top corner.
IF SPRVAR$ <> "NOSCSV" THEN
IF XBOXSAVE = 0 THEN
COLOR BORDER, 1: LOCATE W1 - 1, W2: PRINT CHR$(218) + STRING$(W4 - 2, 196) + CHR$(191);
' Create box-----------------------------------------------------------------------
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 8, 0: PRINT CHR$(SCREEN(CSRLIN, POS(0)));: PRINT CHR$(SCREEN(CSRLIN, POS(0)))
NEXT I
' ---------------------------------------------------------------------------------
LOCATE , W2 + 1
FOR I = 1 TO W4 + 1
PRINT CHR$(SCREEN(CSRLIN, POS(0)));
NEXT
COLOR 7, 0
XBOXSAVE = 1
END IF
LOCATE yy + 1, xx, 0 ' Hide cursor.
COLOR 11, 1
PRINT " Sun. Mon. Tue. Wed. Thu. Fri. Sat. "
' Display the date at the top of the calendar popup.
NXTCAL:
LOCATE yy - 1, W2 + W4 - 4
COLOR 1, 4
y_close = CSRLIN: x_close = POS(0) + 1
PRINT "ÝXÞ";
COLOR BORDER, 1
LOCATE yy - 1, _WIDTH / 2 - (LEN(MONTH$) + LEN(LTRIM$(STR$(YR)))) \ 2 - 4
y_arrows = CSRLIN
x_moback = POS(0)
PRINT "<";
PRINT MONTH$;
x_mofwd = POS(0)
PRINT ">";
PRINT "ù";
x_yrback = POS(0)
PRINT "<";
PRINT LTRIM$(STR$(YR));
x_yrfwd = POS(0)
PRINT ">";
' Make the squares to display the days.
COLOR BORDER, 1
LOCATE yy + 2, xx
FOR I = 1 TO 5
m_trigr(I) = CSRLIN
PRINT A1$
LOCATE CSRLIN, xx
PRINT A2$
LOCATE CSRLIN, xx
PRINT A3$;: XEND = POS(0): PRINT
LOCATE CSRLIN, xx
FOR j = 1 TO 7
m_trigc(j) = xx + (j - 1) * 7
NEXT j
NEXT I
ELSE
IF SPRVAR$ = "NOSCSV" THEN SPRVAR$ = ""
END IF
' Display the days in the squares.
j = yy + 3
LOCATE j, W2 - 8 + 7 * xover
LOCDATE = VAL(MID$(DATEX$, 4, 2))
FOR I = 1 TO xnod
LOCATE j, POS(0) + 5
IF I < 10 THEN XI$ = " " + LTRIM$(STR$(I)) ELSE XI$ = LTRIM$(STR$(I))
IF I >= 30 AND POS(0) >= XEND THEN
LOCATE CSRLIN, xx + 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, xx + 1 + 7: PRINT "24";
COLOR 7, 1
IF LOCDATE = 31 THEN COLOR 7, 3
PRINT "31": EXIT FOR
END IF
END IF
IF POS(0) >= XEND THEN
j = j + 3: LOCATE j, xx + 2
COLOR 3, 1
ELSE
COLOR 14, 1
END IF
IF I = LOCDATE THEN
YY1 = POS(0): 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
REM Increase w3 by 1 and add any line of info to the bottom of the calendar popup here.
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": mykey$ = " G": EXIT DO
CASE "CALEND": mykey$ = " O": EXIT DO
CASE "CALUP": XNT = XNT + 1: mykey$ = " H": IF XNT = 7 THEN XNT = 0: ACT$ = "" ELSE EXIT DO
CASE "CALDN": XNT = XNT + 1: mykey$ = " 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
REM PCOPY AND SCREEN HERE.
LOCATE yy, xx
DO
MyMouse_keyboard lb, rb, my, mx, sgnmw, dblclk, drag, drag2, mykey$, shift%, alt%, ctrl%, sbcol%, lhold
IF lb > 0 THEN
IF my = y_close AND mx = x_close THEN
mykey$ = CHR$(27): EXIT DO
END IF
IF my = y_arrows THEN
SELECT CASE mx
CASE IS = x_moback
SPRVAR$ = "": MID$(DATEX$, 4, 2) = "01": MO = MO - 1: IF MO = 0 THEN MO = 12: YR = YR - 1
A1$ = "": EXIT WHILE
CASE IS = x_mofwd
SPRVAR$ = "": MID$(DATEX$, 4, 2) = "01": MO = MO + 1: IF MO = 13 THEN MO = 1: YR = YR + 1
A1$ = "": EXIT WHILE
CASE IS = x_yrback
SPRVAR$ = "": YR = YR - 1
A1$ = "": EXIT WHILE
CASE IS = x_yrfwd
SPRVAR$ = "": YR = YR + 1
A1$ = "": EXIT WHILE
END SELECT
ELSE
FOR j = 1 TO 5
IF my >= m_trigr(j) AND my <= m_trigr(j) + 1 THEN
FOR k = 1 TO 7
IF mx >= m_trigc(k) AND mx <= m_trigc(k) + 4 THEN
mouse_click = (j - 1) * 7 + k - xover + 1
IF mouse_click > 0 AND mouse_click <= xnod THEN
IF j = 5 AND mouse_click = 23 AND xnod >= 30 THEN
IF mx >= m_trigc(k) AND mx <= m_trigc(k) + 2 THEN mouse_click = 23 ELSE mouse_click = 30
END IF
IF j = 5 AND mouse_click = 24 AND xnod = 31 THEN
IF mx >= m_trigc(k) AND mx <= m_trigc(k) + 2 THEN mouse_click = 24 ELSE mouse_click = 31
END IF
tmp$ = LTRIM$(STR$(mouse_click))
IF LEN(tmp$) = 1 THEN tmp$ = "0" + tmp$
MID$(DATEX$, 4, 2) = tmp$
IF DATEX$ = curdatex$ THEN RETURN ' This also acts as a pseudo-double click when not on the current date.
curdatex$ = DATEX$
SPRVAR$ = "": A1$ = "": EXIT WHILE
END IF
END IF
NEXT
END IF
NEXT
END IF
ELSEIF sgnmw THEN
IF sgnmw < 0 THEN mykey$ = CHR$(0) + "H"
IF sgnmw > 0 THEN mykey$ = CHR$(0) + "P"
sgnmw = 0: _DELAY .05: EXIT DO
END IF
IF mykey$ <> "" THEN IF INSTR("KMHPIQOGuw", MID$(mykey$, 2, 1)) <> 0 OR mykey$ = CHR$(27) THEN EXIT DO
LOOP
IF KW$ <> "" THEN EXIT DO
LOOP
IF LEN(KW$) = 1 THEN KW$ = "0" + KW$
IF mykey$ = CHR$(27) THEN LOCATE yy, xx: DATEX$ = holddatex$: GOSUB ENDCAL1: RETURN
IF mykey$ = CHR$(8) THEN DATEX$ = DATE$: MO = VAL(MID$(DATEX$, 1, 2)): YR = VAL(MID$(DATEX$, 7, 4)): SPRVAR$ = "": A1$ = "": EXIT WHILE
A1$ = "": SPRVAR$ = "NOSCSV"
CALB:
DO
IF mykey$ = CHR$(13) THEN
ACT$ = "MAIN": MID$(DATEX$, 4, 2) = KW$: GOSUB ENDCAL1: setcal = 0: RETURN
END IF
SELECT CASE MID$(mykey$, 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 mykey$ = "0K": ACT$ = "CALHOME": _CONTINUE: REM - 1
CASE "O": IF YY1 <> XEND THEN mykey$ = "0M": ACT$ = "CALEND": _CONTINUE
CASE "H": mykey$ = "0K": ACT$ = "CALUP": _CONTINUE
CASE "P": mykey$ = "0M": ACT$ = "CALDN": _CONTINUE
CASE "M"
IF LOCDATE = xnod THEN
KW$ = "01": MO = MO + 1: IF MO = 13 THEN MO = 1: YR = YR + 1
mykey$ = LTRIM$(STR$(MO)): IF LEN(mykey$) = 1 THEN mykey$ = "0" + mykey$
DATEX$ = mykey$ + "-01-" + LTRIM$(STR$(YR))
SPRVAR$ = "": setcal = 1: recal = 1: EXIT DO ' To calsub
END IF
SPRVAR$ = "PLUSX": GOSUB NEXTDAY: SPRVAR$ = "": KW$ = MID$(DATEX$, 4, 2): SPRVAR$ = "NOSCSV"
CASE "u"
mykey$ = LTRIM$(STR$(xnod)): IF LEN(mykey$) = 1 THEN mykey$ = "0" + mykey$
MID$(DATEX$, 4, 2) = mykey$: recal = 1: EXIT DO ' To calsub
CASE "w": MID$(DATEX$, 4, 2) = "01": recal = 1: EXIT DO ' To calsub
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))
setcal = 1: recal = 1: EXIT DO ' To calsub
END IF
KW$ = MID$(DATEX$, 4, 2): SPRVAR$ = "NOSCSV"
A1$ = ""
END SELECT
EXIT DO
LOOP
IF setcal = 0 AND recal = 0 THEN EXIT WHILE
recal = 0
WEND
GOSUB GETDOW
IF SPRVAR$ = "GETDOW" THEN GOSUB ENDCAL1 ELSE setcal = 2
RETURN
'--------------------------------------------------------------------
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))
RETURN
ENDCAL1:
IF SPRVAR$ <> "GETDOW" THEN
ELSE
SPRVAR$ = ""
END IF
IF mykey$ = CHR$(27) AND ACT$ = "MAIN" THEN ACT$ = "": DATEX$ = holddatex$
IF SPRVAR$ = "NOSCSV" THEN SPRVAR$ = ""
RETURN
NEXTDAY:
IF SPRVAR$ = "MINUS" THEN
REM 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
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
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
ELSE
REM 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
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
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
END IF
REM 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
END SUB
SUB MyMouse_keyboard (lb, rb, my, mx, sgnmw, dblclk, drag, drag2, mykey$, shift%, alt%, ctrl%, sbcol%, lhold)
STATIC oldmy, oldmx, mw, oldmw, z1
_LIMIT 60
WHILE _MOUSEINPUT
mw = mw + _MOUSEWHEEL
IF mw AND mw <> oldmw THEN sgnmw = SGN(mw - oldmw): oldmw = mw
WEND
my = _MOUSEY
mx = _MOUSEX
IF my = 0 OR mx = 0 THEN EXIT SUB
IF alt% THEN IF _KEYDOWN(100307) = 0 AND _KEYDOWN(100308) = 0 THEN alt% = 0 ' Alt key toggle off.
IF ctrl% THEN IF _KEYDOWN(100305) = 0 AND _KEYDOWN(100306) = 0 THEN ctrl% = 0 ' Ctrl key toggle off.
IF _KEYDOWN(100305) OR _KEYDOWN(100306) THEN IF ctrl% = 0 THEN ctrl% = -1 ' Ctrl key toggle on.
IF _KEYDOWN(100307) OR _KEYDOWN(100308) THEN IF alt% = 0 THEN alt% = -1 ' Alt key toggle on.
IF _KEYDOWN(100303) OR _KEYDOWN(100304) THEN shift% = -1 ELSE IF shift% THEN shift% = 0
mykey$ = INKEY$
IF _MOUSEBUTTON(1) THEN
IF lb THEN IF ABS(TIMER - z1) > .33 THEN lhold = 1
IF lb = 1 THEN lb = -1 ' Use this to prevent mouse button hold down retriggering one-time events.
IF lb = 0 THEN
lb = 1
IF ABS(TIMER - z1) < .3 THEN dblclk = -1 ELSE dblclk = 0: z1 = TIMER
END IF
IF oldmy AND oldmy <> my THEN
IF my <> oldmy AND mx = sbcol% THEN
drag = SGN(my - oldmy) ' Prevent zero which can occur if mouse moves off row when being dragged horizontally.
END IF
END IF
ELSE
IF lb THEN lb = 0: drag = 0: lhold = 0
IF drag2 THEN drag2 = 0
END IF
IF _MOUSEBUTTON(2) AND rb = 0 THEN
rb = 1
ELSE
IF _MOUSEBUTTON(2) = 0 AND rb THEN rb = 0
END IF
oldmy = my: oldmx = mx
END SUB
Pete