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