Login

dritter · 03-04-2024, 05:49 AM

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

***Pete*** · 03-04-2024, 06:43 AM

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

Dimster · 03-04-2024, 03:04 PM

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?

mdijkens · (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

Dimster · 03-04-2024, 04:43 PM

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

**SMcNeill** · 03-04-2024, 05:51 PM

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).

Kernelpanic · (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"

bplus · 03-04-2024, 06:16 PM

If you want your date to function, don't talk about QB64. Smile

Kernelpanic · 03-04-2024, 06:19 PM

(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! Tongue

***Pete*** · 03-04-2024, 06:43 PM

(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. Sad

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

Login
Username/Email:
Password:	Lost Password?
	Remember me