Posts: 1
Threads: 1
Joined: Mar 2024
Reputation:
0
Hello,
I really enjoy working with qb64PE. However, I am missing some functions.
Would it be possible to add some date functions? They are completely missing and I need them often.
such as: day of the week, day of the year
It would also be nice if you could calculate with the day numbers
Posts: 2,128
Threads: 218
Joined: Apr 2022
Reputation:
100
Here's a very old routine of mine you are welcome to pull some date feature from...
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
Posts: 375
Threads: 56
Joined: Apr 2022
Reputation:
13
Hi Pete - I see where March 24 and March 31 appear in the same calendar box, is that because Feb had that leap year 29th day?
Posts: 129
Threads: 12
Joined: Apr 2022
Reputation:
14
03-04-2024, 04:00 PM
(This post was last modified: 03-05-2024, 07:56 AM by mdijkens.)
My TIM library:
Code: (Select All)
Dim As _Unsigned _Integer64 stamp, now, utc
Dim As _Unsigned Long days, secs
stamp = TIM.stamps("2024-03-04 16:45:22") 'seconds since 01-01-0001
stamp = TIM.stamp(2024, 3, 4, 16, 45, 22) 'seconds since 01-01-0001
Print TIM.format$(stamp) 'long format
now = TIM.now: Print "now="; TIM.string$(now)
utc = TIM.utc: Print "utc="; TIM.string$(utc)
Print TIM.dateTime$(stamp, year%, month%, day%, hour%, minute%, seconds%) ' fills vars & returns datetime without -/:
days = TIM.days(year%, month%, day%) 'days since 01-01-0001
secs = TIM.seconds(hour%, minute%, seconds%) 'seconds since midnight
Print "is"; year%; " a leapyear:"; TIM.leapYear(year%)
Print "weekday (0=sun - 6=sat)"; TIM.weekDay(now)
Print TIM.dst(now, 1) 'added seconds to UTC for CET (UTC+1) daylight savings
End
Function TIM.stamps~&& (dt$)
year% = Val(Left$(dt$, 4)): month% = Val(Mid$(dt$, 6, 2)): day% = Val(Mid$(dt$, 9, 2))
hour% = Val(Mid$(dt$, 12, 2)): minute% = Val(Mid$(dt$, 15, 2)): second% = Val(Mid$(dt$, 18, 2))
TIM.stamps~&& = TIM.stamp(year%, month%, day%, hour%, minute%, second%)
End Function
Function TIM.string$ (dt~&&)
dt$ = TIM.dateTime$(dt~&&, year%, month%, day%, hour%, minute%, second%)
TIM.string$ = Left$(dt$, 4) + "-" + Mid$(dt$, 5, 2) + "-" + Mid$(dt$, 7, 2) + " " + _
Mid$(dt$, 9, 2) + ":" + Mid$(dt$, 11, 2) + ":" + Mid$(dt$, 13, 2)
End Function
Function TIM.now~&& ()
dat$ = Date$: tim~& = Timer
month% = Val(Left$(dat$, 2))
day% = Val(Mid$(dat$, 4, 2))
year% = Val(Mid$(dat$, 7, 4))
TIM.now~&& = TIM.days~&(year%, month%, day%) * 86400~&& + tim~&
End Function
Function TIM.utc~&& ()
Type UTCtype
year As Integer
month As Integer
weekday As Integer
day As Integer
hour As Integer
minute As Integer
second As Integer
millis As Integer
End Type
Declare Dynamic Library "Kernel32"
Sub GetUTC Alias GetSystemTime (lpSystemTime As UTCtype)
End Declare
Dim utc As UTCtype: GetUTC utc
TIM.utc~&& = TIM.stamp~&&(utc.year, utc.month, utc.day, utc.hour, utc.minute, utc.second)
End Function
Function TIM.stamp~&& (year%, month%, day%, hour%, minute%, second%)
TIM.stamp~&& = TIM.days~&(year%, month%, day%) * 86400~&& + TIM.seconds~&(hour%, minute%, second%)
End Function
Function TIM.days~& (year%, month%, day%)
leap% = TIM.leapYear(year%): prevYear% = year% - 1
dPrevYears& = ((((prevYear% * 365) + (prevYear% \ 4)) - (prevYear% \ 100)) + (prevYear% \ 400))
Select Case month%
Case 1: TIM.days~& = ((dPrevYears&) + day%) - 1
Case 2: TIM.days~& = ((dPrevYears& + 31) + day%) - 1
Case 3: TIM.days~& = ((dPrevYears& + 59 - leap%) + day%) - 1
Case 4: TIM.days~& = ((dPrevYears& + 90 - leap%) + day%) - 1
Case 5: TIM.days~& = ((dPrevYears& + 120 - leap%) + day%) - 1
Case 6: TIM.days~& = ((dPrevYears& + 151 - leap%) + day%) - 1
Case 7: TIM.days~& = ((dPrevYears& + 181 - leap%) + day%) - 1
Case 8: TIM.days~& = ((dPrevYears& + 212 - leap%) + day%) - 1
Case 9: TIM.days~& = ((dPrevYears& + 243 - leap%) + day%) - 1
Case 10: TIM.days~& = ((dPrevYears& + 273 - leap%) + day%) - 1
Case 11: TIM.days~& = ((dPrevYears& + 304 - leap%) + day%) - 1
Case 12: TIM.days~& = ((dPrevYears& + 334 - leap%) + day%) - 1
Case Else: TIM.days~& = 0
End Select
End Function
Function TIM.seconds~& (hour%, minute%, second%)
TIM.seconds~& = hour% * 3600 + minute% * 60 + second%
End Function
Function TIM.dateTime$ (timestmp~&&, year%, month%, day%, hour%, minute%, second%)
tdays~& = timestmp~&& \ 86400 + 306
secs~& = timestmp~&& Mod 86400
era% = tdays~& \ 146097
doe~& = tdays~& Mod 146097 ' [0, 146096]
yoe% = (doe~& - doe~& \ 1460 + doe~& \ 36524 - doe~& \ 146096) \ 365 ' [0, 399]
year% = yoe% + era% * 400
doy% = doe~& - (365 * yoe% + yoe% \ 4 - yoe% \ 100) ' [0, 365]
mp% = (5 * doy% + 2) \ 153 ' [0, 11]
day% = doy% - (153 * mp% + 2) \ 5 + 1 ' [1, 31]
If mp% < 10 Then month% = mp% + 3 Else month% = mp% - 9 ' [1, 12]
year% = year% - (month% <= 2)
dat$ = Right$(Str$(year% + 10000), 4) + Right$(Str$(month% + 100), 2) + Right$(Str$(day% + 100), 2)
hour% = secs~& \ 3600
minsec% = secs~& - (hour% * 3600)
minute% = minsec% \ 60
second% = minsec% - (minute% * 60)
TIM.dateTime$ = dat$ + Right$(Str$(hour% + 100), 2) + _
Right$(Str$(minute% + 100), 2) + Right$(Str$(second% + 100), 2)
End Function
Function TIM.format$ (ts~&&)
dt$ = TIM.dateTime$(ts~&&, year, month, day, hour, minute, second)
dt2$ = Mid$("SuMoTuWeThFrSa", TIM.weekDay(ts~&&) * 2 + 1, 2)+" " + _
Mid$(dt$, 7, 2) + "-" + Mid$(dt$, 5, 2) + "-" + Mid$(dt$, 1, 4) + " " + _
Mid$(dt$, 9, 2) + ":" + Mid$(dt$, 11, 2) + ":" + Mid$(dt$, 13, 2)
TIM.format$ = dt2$
End Function
Function TIM.leapYear% (year%)
If (year% Mod 4) <> 0 Then
TIM.leapYear% = 0
ElseIf (year% Mod 100) = 0 Then
TIM.leapYear% = (year% Mod 400) = 0
Else
TIM.leapYear% = Not 0
End If
End Function
Function TIM.weekDay% (ts~&&)
tdays~& = ts~&& \ 86400
TIM.weekDay% = (tdays~& + 1) Mod 7
End Function
Function TIM.dst& (ts~&&, timezone%)
dt$ = TIM.dateTime$(ts~&&, year%, month%, day%, hour%, minute%, second%)
summer~&& = TIM.stamps(Right$(Str$(year% + 10000), 4) + "-03-31 01:00:00") 'UTC
summer~&& = summer~&& - (TIM.weekDay(summer~&&) * 86400)
winter~&& = TIM.stamps(Right$(Str$(year% + 10000), 4) + "-10-31 01:00:00") 'UTC
winter~&& = winter~&& - (TIM.weekDay(winter~&&) * 86400)
If ts~&& >= summer~&& And ts~&& < winter~&& Then
TIM.dst = timezone% * 3600 + 3600 ' UTC + timezone% + dst (summer)
Else
TIM.dst = timezone% * 3600 ' ' UTC + timezone% (winter)
End If
End Function
45y and 2M lines of MBASIC>BASICA>QBASIC>QBX>QB64 experience
Posts: 375
Threads: 56
Joined: Apr 2022
Reputation:
13
So, this doesn't have everything you were looking for dritter. It's needs some modernization in term of the new language choices we have. Pretty well functions as an opening screen in which you can display tasks and mainly displaying the same code you see with the other examples
Code: (Select All) Cls
Screen _NewImage(1200, 800, 32) ' now my favourite screen. top left (1,1)...top right (1,149) .... bottom left ( 48,1).....bottom right (48,149) = for the text
Dim Shared White&
Dim Shared Black&
Dim Shared LightGreen&
Dim Shared DarkGreen&
Dim Shared Teal&
Dim Shared Blue&
Dim Shared LightBlue&
Dim Shared Orange&
Dim Shared Red&
Dim Shared Grey&
Dim Shared Purple&
Dim Shared LightPurple&
Dim Shared LightBrown&
Dim Shared Yellow&
Dim Shared Pink&
White& = _RGB(255, 255, 255)
Black& = _RGB(0, 0, 0)
LightGreen& = _RGB(0, 255, 0)
DarkGreen& = _RGB32(0, 129, 0)
Teal& = _RGB(0, 129, 129)
Yellow& = _RGB(255, 255, 0)
Blue& = _RGB(0, 0, 129)
LightBlue& = _RGB(0, 0, 255)
Orange& = _RGB(255, 129, 0)
Red& = _RGB(255, 0, 0)
Grey& = _RGB(133, 133, 150)
Purple& = _RGB(129, 0, 129)
LightPurple& = _RGB(129, 0, 205)
LightBrown& = _RGB(172, 100, 61)
Yellow& = _RGB(255, 255, 0)
Pink& = _RGB(216, 50, 166)
OpeningScreenBox
OpeningScreenBoxHeaders
Sub OpeningScreenBox
Cls
'************************************ OPENING SCREEN BOX **************************
Line (0, 0)-(1199, 81), White&, B ' main top box - also to be use for Error Messaging
Line (1, 1)-(1198, 80), Black&, BF
Line (0, 81)-(1198, 160), White&, B ' the TASK menu box
Line (0, 160)-(1198, 780), White&, B
End Sub
Sub OpeningScreenBoxHeaders
'**************************************** OPENING SCREEN HEADINGS *********************
'Top Box - center = 600,30
Color LightGreen&, Black&
_PrintString (500, 10), "LET'S GET STARTED"
TodayTime$ = Time$
m$ = Left$(TodayTime$, 2): Dt = Val(m$) ' TodayTime$ will carry todays correct time in 24 hr format = HH:MM:SS
If Dt >= 1 And Dt < 12 Then
Greet$ = "Good Morning "
Locate 3, 2
Color Yellow&
Print Greet$
End If
'm$ = LEFT$(TodayTime$, 2): Dt = VAL(m$)
If Dt >= 12 And Dt < 18 Then ' Greet$ will carry one of three greeting depending on the HH of Time of Day - ie 1 to 12 = Morning : 12:01 to 6 pm = Afternoon : 6:01 to midnight = Evening
Greet$ = "Good Afternoon "
Locate 3, 2
Color Orange&
Print Greet$
End If
'm$ = LEFT$(TodayTime$, 2): Dt = VAL(m$)
If Dt >= 18 And Dt < 24 Then
Greet$ = "Good Evening "
Locate 3, 2
Color DarkGreen&
Print Greet$
End If
Today$ = Date$
mth$ = Left$(Today$, 2): M = Val(mth$)
day$ = Mid$(Today$, 4, 2): D = Val(day$)
day$ = Str$(D)
year$ = Right$(Today$, 4): Yr = Val(year$)
Select Case M ' Month$ will now carry the correct Month : D will carry the correct Day : Yr will carry the correct Year
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
If Month$ = "May" Then Locate 2, 2
If Month$ = "June" Or Month$ = "July" Then Locate 2, 2
If Month$ = "March" Or Month$ = "April" Then Locate 2, 2
If Month$ = "August" Then Locate 2, 2
If Month$ = "January" Or Month$ = "October" Then Locate 2, 2
If Month$ = "February" Or Month$ = "November" Or Month$ = "December" Then Locate 2, 2
If Month$ = "September" Then Locate 2, 2
Color LightGreen&
Print Month$; D; Yr
Close 1
'OPEN "j:LastPrgmRunDate" FOR INPUT AS #1
Open "d:\LastPrgmRunDate" For Input As #1
Input #1, LMonth$, LD, LY
Close #1
LastRunMonth$ = LMonth$
LastRunDay = LD
LastRunYear = LY
Locate 2, 129
Color LightGreen&
Print "Program Last Run Date"
Locate 3, 130
Color LightPurple&
Print LastRunMonth$; " "; LastRunDay; " "; LastRunYear
End Sub
Posts: 2,686
Threads: 326
Joined: Apr 2022
Reputation:
215
You can get day and format options here: https://qb64phoenix.com/forum/showthread.php?tid=2103
Get a timestamp here: https://qb64phoenix.com/forum/showthread.php?tid=65
To figure out how many days is between two dates, get timestamps for both and just subtract. Divide the result by (60 * 60 * 24 for seconds * minutes * hours).
Posts: 1,000
Threads: 50
Joined: May 2022
Reputation:
27
03-04-2024, 06:12 PM
(This post was last modified: 03-04-2024, 06:13 PM by Kernelpanic.)
This all looks mighty mighty complicated, folks. Everything is there in VB-Script to do calculations with dates, and it's easy. The question is, can one integrate a VB script into QB64, because that would really be the easiest way.
Not to forget, these functions are from MS itself and have proven themselves many times over; earlier, when VB-Script was also used in websites.
A little simple program - calculates the days beween two dates.
Code: (Select All)
'Differenz zweier Datumsangaben ermitteln
WScript.Echo DateDiff("d", Now, "1.4.2024") & " Tage bis zum 1. April 2024"
Posts: 3,923
Threads: 175
Joined: Apr 2022
Reputation:
210
If you want your date to function, don't talk about QB64.
b = b + ...
Posts: 1,000
Threads: 50
Joined: May 2022
Reputation:
27
(03-04-2024, 06:16 PM)bplus Wrote: If you want your date to function, don't talk about QB64. That's very ambiguous, bplus!
Posts: 2,128
Threads: 218
Joined: Apr 2022
Reputation:
100
(03-04-2024, 06:16 PM)bplus Wrote: If you want your date to function, don't talk about QB64.
No worries. All my dates are dysfunctional. Functional ones won't date me.
To Dimster: Regarding the doubling up of dates, that happens in any month where we run out if room (squares) to keep a date in. What you will notice is you can click each one, independently.
Pete
|