Simple Calendar (Show only one month)

[lrcvs]

Hi!

A simple Calendar program, show only one month

Code: Select all

'PROGRAM:CALENDAR, SHOW ONLY ONE MONTH

DIM AS INTEGER a,c,d,dm,ds,f,j,k,m,n,y
DIM u (49) AS STRING
DIM v (6,7) AS STRING

d = 1

CLS
INPUT "Month number 1...12 = ";m
INPUT "Year number yyyy = ";y
CLS

IF m = 1 OR m = 3 OR m = 5 OR m = 7 OR m = 8 OR m = 10 OR m = 12 THEN dm = 31
IF m = 4 OR m = 6 OR m = 9 OR m = 11 THEN dm = 30
IF m = 2 THEN dm = 28

IF m = 2 AND ((y MOD 4) =  0 OR ((y MOD 100) = 0 AND (y MOD 400)) = 0) THEN dm = 29

a = INT((14 - m) / 12)
y = y - a
m = m + (12 * a) - 2
ds =((d + y + INT(y / 4) - INT(y / 100) + INT(y / 400) + INT((31 * m) / 12)) MOD 7)

IF ds = 0 THEN ds = ds +7
IF ds > 0 THEN ds = ds -1

FOR n = 1 TO 49
    u(n) = "  "
NEXT n

FOR n = 1 TO dm
    f =  LEN(LTRIM(STR(n)))
    IF f =1 THEN
        u(n+ds) = " " + LTRIM(STR(n))
    ELSE
        u(n+ds) = LTRIM(STR(n))
    END IF   
NEXT n

c = 1

FOR j = 1 TO 6
    FOR k = 1 TO 7
        v(j,k) = MID(u(c),1,3)
        c = c + 1
    NEXT k
NEXT j
   
PRINT "Mo Tu We Th Fr Sa Su"
   
FOR j = 1 TO 6
    FOR k = 1 TO 7
        PRINT v(j, k) ;" ";
    NEXT k
    PRINT
NEXT j

SLEEP
END


Regards

[Tourist Trap]

A simple Calendar program, show only one month

Nice, it works at least for 2016. We won't have to wait a long time before testing it with 2017 ;)

[Lothar Schirm]

Ircvs,
FreeBASIC offers a nice function for such applications: DateSerial. This could simplify your code very much. Example:

Code: Select all

#Include "vbcompat.bi"

Dim As Integer d, m, y, a, col

Cls
Input "Month number 1...12 = ";m
Input "Year number yyyy = ";y
Cls

Print "Mo Tu We Th Fr Sa Su"
For d = 1 To 31
   a = DateSerial(y, m, d)
   If Month(a) = m Then
      If WeekDay(a) > 1 Then
         'Monday to Saturday:
         col = 1 + (WeekDay(a) - 2) * 3
         Locate , col
         Print Format(d, "00");
      Else
      'Sunday:
         col = 1 + 18
         Locate , col
         Print Format(d, "00")
      End If
   End If
Next

End

Should also work in 2017. Happy New Year!

[bcohio2001]

There is also:

Code: Select all

Print MonthName(m)

[lrcvs]

Hi, all!

Happy New Year 2.017!!!

:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

To Tourist Tramp:

The formula used is: "Zeller's Congruence"

See:
https://es.wikipedia.org/wiki/Congruencia_de_Zeller

But... I have my doubts...,
...because the years: 1700-1800-1900-2100-2200-2300 ..., they say: "... they are not leap ..."
... then I have my doubts in knowing if the month of February of all those years, has 28 or 29 days?

... Well, if these years ... "They are not leap"..., then, between 1896 and 1900, you have spent 4 years ...

Where is that February 29th?


'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

To Lothar Schirm:

Thanks for your code!

I know: #Include "vbcompat.bi" and "Date Serial"

But... I also have my doubts ...
... because the years: 1700-1800-1900-2100-2200-2300 ..., they say: "... they are not leap ..."
... then I have my doubts in knowing if the month of February of all those years, has 28 or 29 days?

... Well, if these years ... "They are not leap"..., then, between 1896 and 1900, you have spent 4 years ...

Where is that February 29th?

:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

For example:

The year: 1900, the month of February.
Using: #Include "vbcompat.bi" and "Date Serial"

February, has 28 days, starts Thursday and ends Wednesday. "<<< !!!"

March, has 31 days, starts Thursday and ends Saturday.

............................................................................................................
Well, now the same example: year 1900, February.
Using: "Zeller's Congruence"

February, has 29 days, starts Thursday and ends Thursday. "<<< !!!!"

March, has 31 days, starts Thursday and ends Saturday. "<<< !!!!"
............................................................................................................


As we see, ("there may be" ("a possible error") in this formula or Date Serial?)

[lrcvs]

Hi,
To bcohio2001:

I will see!

Regards!

[Zippy]

This is an example using Zeller's that accommodates leaps. I've today modded the 10yo code for 64-bit compatibility - it should remain 32-bit able but didn't test.

Code: Select all

'Perpetual calendar >year 1582
'
'#define MondayStartZ
 
'function returns dateserial of date
declare function printcal(ds as string) as long
'
'printcal(date)
printcal("02-01-2016")
'printcal("02-01-2017")

sleep
'
function printcal(ds as string) as long
    dim as string  dstr,mstr,t1
    dim as long dow,sdow,ds1,ds2,ndays
    dim as long y,yy,m,mm,d,dd,a,c,tds
    '   
    dstr="Sunday   Monday   Tuesday  Wednesday" & _
         "Thursday Friday   Saturday "
    mstr="January  February March    April    May" & _
         "      June     July     August   " & _
         "SeptemberOctober  November December "
    '         
    'ds=date string mm-dd-yyyy
    yy=val(right(ds,4)) 'year must be >1582
    mm=val(left(ds,2))
    dd=val(mid(ds,4,2))
    y=yy:m=mm:d=dd
    '
    if m<3 then m+=12:y-=1:end if 'Zeller's month mod
    'get numeric day of week, where 0 = Sunday
    dow=(2+d+(13*m-2)\5+y+y\4-y\100+y\400) mod 7
    'get absolute number of days, Zeller
    tds=(d+(153*m-2)\5+365*y+y\4-y\100+y\400)
    'convert to M$ dateserial for function return, not otherwise used
    printcal = tds-693991 'base = 12-30-1899, = M$ dateserial
    '
    'get the month's start day of week   
    d=1:m=mm:y=yy
    if m<3 then m+=12:y-=1:end if
    ds1=(d+(153*m-2)\5+365*y+y\4-y\100+y\400) 'dateserial first day of month
    sdow=(2+d+(13*m-2)\5+y+y\4-y\100+y\400) mod 7
'mod for Monday start of week   
#if defined (MondayStartZ)
    sdow-=1:if sdow<0 then sdow=0
#endif
    '
    'get number of days in month   
    m=mm:y=yy
    m+=1:if m>12 then m=1:y+=1:end if
    if m<3 then m+=12:y-=1:end if
    'get dateserial of first day of next month
    ds2=(d+(153*m-2)\5+365*y+y\4-y\100+y\400)
    ndays=ds2-ds1 'if dd>ndays then..bad..day
    '
    'print calendar   
    t1=trim(mid(mstr,(mm-1)*9+1,9)) & " " & yy
    print:print space(11-len(t1)\2);t1
'mod for Monday start of week
#if defined (MondayStartZ)
    print:print " Mo Tu We Th Fr Sa Su"
#else
    print:print " Su Mo Tu We Th Fr Sa"
#endif
    a = 1-sdow:c=0
    while a<=ndays
        if a>=1 then
            color iif(a=dd,15,7),0
            print using "###";a;
        else
            print space(3);
        end if
        a+=1:c+=1
        if c=7 then c=0:print:end if
    wend
    '
    print
    print:color 15,0
    print trim(mid(dstr,dow*9+1,9)) & ", " & _
          trim(mid(mstr,(mm-1)*9+1,9)) & _
          " " & dd & ", " & yy
    color 7,0
'
end function


I posted a unicode internationalized version in 2006 that user voodoattack helped me with. I also have a version that prints both a month-by and year-by calendar, I don't rem if I posted that one. Note in this code the ability to define a Monday start date for the week.

@lrcvs: Not trying to step on your post. I hope you find this helpful. Happy New Year!
.

[MrSwiss]

Hi all,

recoded ex. from Zippy (hope you don't mind) to reflect EU style Date-Format:

Code: Select all

'Perpetual calendar > year 1582, original by Zippy
' recoded for EU Date format, by MrSwiss

#define MondayStartZ
 
'function returns dateserial of date
declare function printcal(ds as string) as long

'start Main
'printcal(EU String Date: "DD.MM.YYYY")
Dim As Long ret

ret = printcal("01.02.2016")
'ret = printcal("01.02.2017")
Print : Print "DateSerial: "; Str(ret)

sleep
' end Main

function printcal(ByRef ds as string) as long
    dim as string  dstr, mstr, t1
    dim as long    dow, sdow, ds1, ds2, ndays
    dim as long    y, yy, m, mm, d, dd, a, c, tds

    dstr = "Sunday   Monday   Tuesday  Wednesday" + _
           "Thursday Friday   Saturday "
    mstr = "January  February March    April    May" + _
           "      June     July     August   " + _
           "SeptemberOctober  November December "

    ' ds = date string dd.mm.yyyy (EU format)
    yy = ValInt(right(ds,4)) 'year must be >1582
    dd = ValInt(left(ds,2))  ' exchanged mm and dd for EU formated string
    mm = ValInt(mid(ds,4,2))
    y = yy : m = mm : d = dd
    '
    if m < 3 then m += 12 : y -= 1 'Zeller's month mod
    'get numeric day of week, where 0 = Sunday
    dow = (2 + d + (13 * m - 2) \ 5 + y + y \ 4 - y \ 100 + y \ 400) mod 7
    'get absolute number of days, Zeller
    tds = (d + (153 * m - 2) \ 5 + 365 * y + y \ 4 - y \ 100 + y \ 400)

    'convert to M$ dateserial for function return, not otherwise used
    printcal = tds - 693991 'base = 30.12.1899, = M$ dateserial

    'get the month's start day of week   
    d = 1 : m = mm : y = yy
    if m < 3 then m += 12 : y -= 1

    ds1 = (d + (153 * m - 2) \ 5 + 365 * y + y \ 4 - y \ 100 + y \ 400) 'dateserial first day of month
    sdow = (2 + d + (13 * m - 2) \ 5 + y + y \ 4 - y\ 100 + y \ 400) mod 7

'mod for Monday start of week   
#ifdef MondayStartZ
    sdow -= 1 : If sdow < 0 then sdow = 0
#endif

    'get number of days in month   
    m = mm : y = yy
    m += 1 : If m > 12 then m = 1 : y += 1
    if m < 3 then m += 12 : y -= 1
    'get dateserial of first day of next month
    ds2 = (d + (153 * m - 2) \ 5 + 365 * y + y \ 4 - y \ 100 + y \ 400)
    ndays = ds2 - ds1 'if dd > ndays then..bad..day
    'print calendar
    t1 = Trim(Mid(mstr, (mm - 1) * 9 + 1, 9)) + " " + Str(yy)
    Print : Print Space(11 - Len(t1) \ 2); t1

'mod for Monday start of week
#ifdef MondayStartZ
    Print : Print " Mo Tu We Th Fr Sa Su"
#else
    Print : Print " Su Mo Tu We Th Fr Sa"
#EndIf

    a = 1 - sdow : c = 0
    while a <= ndays
        if a >= 1 then
            color iif(a = dd, 15, 7)
            print using "###"; a;
        else
            print space(3);
        end if
        a += 1 : c += 1
        if c = 7 then c = 0 : Print
    wend

    Print : Print : Color 15

    ' recoded to reflect EU tsyle format
    Print Trim(Mid(dstr, dow * 9 + 1, 9)) + ", " + Str(dd) + _
          ". " + Trim(Mid(mstr, (mm - 1) * 9 + 1, 9)) + " " + Str(yy)
    color 7
End Function

Happy 2017, to all!

[lrcvs]

Hi!
Thank you all!!!
Solved the error.
The error was in my program, in the line to calculate the leap year.
Now, apparently, it's perfect.

Code: Select all

'PROGRAM:CALENDAR, SHOW ONLY ONE MONTH

DIM AS INTEGER a,c,d,dm,ds,f,j,k,m,n,y, Z
DIM u (49) AS STRING
DIM v (6,7) AS STRING

d = 1

CLS
INPUT "Month number 1...12 = ";m
INPUT "Year number yyyy = ";y
CLS

IF m = 2 THEN dm = 28

If m = 2 And (y Mod 400 = 0) And (y Mod 4 = 0) or (y Mod 100 <> 0) And (y Mod 4 = 0) Then dm = 29

IF m = 1 OR m = 3 OR m = 5 OR m = 7 OR m = 8 OR m = 10 OR m = 12 THEN dm = 31
IF m = 4 OR m = 6 OR m = 9 OR m = 11 THEN dm = 30

a = INT((14 - m) / 12)
y = y - a
m = m + (12 * a) - 2
ds =((d + y + INT(y / 4) - INT(y / 100) + INT(y / 400) + INT((31 * m) / 12)) MOD 7)

IF ds = 0 THEN ds = ds +7
IF ds > 0 THEN ds = ds -1

FOR n = 1 TO 49
    u(n) = "  "
NEXT n

FOR n = 1 TO dm
    f =  LEN(LTRIM(STR(n)))
    IF f =1 THEN
        u(n+ds) = " " + LTRIM(STR(n))
    ELSE
        u(n+ds) = LTRIM(STR(n))
    END IF   
NEXT n

c = 1

FOR j = 1 TO 6
    FOR k = 1 TO 7
        v(j,k) = MID(u(c),1,3)
        c = c + 1
    NEXT k
NEXT j
   
PRINT "Mo Tu We Th Fr Sa Su"
   
FOR j = 1 TO 6
    FOR k = 1 TO 7
        PRINT v(j, k) ;" ";
    NEXT k
    PRINT
NEXT j

SLEEP
END


Happy New Year 2.017 !!!

[Lothar Schirm]

Wikipedia (Leap Year - Gregorian Calendar) says:
Every year that is exactly divisible by four is a leap year, except for years that are exactly divisible by 100, but these centurial years are leap years if they are exactly divisible by 400. For example, the years 1700, 1800, and 1900 were not leap years, but the years 1600 and 2000 were.[.
So regarding Ircvs' example for 1900 it seems that DateSerial is ok.

[BasicCoder2]

Now you have the engine that generates the days for a given month in a given year you can use FreeBasic graphics to produce a really nice calendar display. It could have a nice GUI interface with maybe each day having an little edit box to make notes for that day.

Maybe this is a good project for someone to make a Calendar object to show off their OOP skills?

.

[lrcvs]

Hi:

To Lothar Schirm:

See:

https://es.wikipedia.org/wiki/Anexo:A%C ... XXI_y_XXII

To BasicCoder2

Thanks!

Regards

[dodicat]

Now you have the engine that generates the days for a given month in a given year you can use FreeBasic graphics to produce a really nice calendar display. It could have a nice GUI interface with maybe each day having an little edit box to make notes for that day.

Maybe this is a good project for someone to make a Calendar object to show off their OOP skills?

.

Nice simple -- and accurate -- calendar Ircvs.
IMHO better your own engine than Dateserial.

Basiccoder2
I made a gui thingy a few years ago.
The engine was an old quickbasic format.
Here it is with integers changed to longs for the 64 bit compiler.
It should cover the whole lifetime of the oldest forum member and the whole lifetime, to come, of the youngest

Code: Select all



'CALENDAR
#include "fbgfx.bi"
Dim Shared As Integer xres,yres
Screen 19,32,1,FB.GFX_ALPHA_PRIMITIVES
Screeninfo xres,yres
Windowtitle "FreeBASIC CALENDAR"
#macro incircle(cx,cy,radius,x,y)
(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro

Type box
    As String text
    As Ulong colour
    As Long value,tx,ty,bx,by
End Type
Type Calendar_Month
    Number As Long 
    Month_name As String
End Type
Declare Sub digits(t As String,x As Long,y As Long,clr As Ulong,sz As Long,img As Any Pointer=0)
Declare Function IsLeapYear(N As Long) As Long
Declare Sub PrintCalendar (_year As Long, _month As Long)
Declare Sub ComputeMonth (_year As Long, _month As Long, Byref StartDay As Long, Byref TotalDays As Long)
Declare Sub inspect(mx As Long,my As Long,mw As Long)
Dim Shared MonthData(1 To 12)   As Calendar_Month
Declare Sub initdata
Declare Sub initmonth
Declare Sub inityear
Declare Sub initdigits
Declare Sub dropmonth
Declare Sub dropyear
Declare Sub dropdigit1
Declare Sub dropdigit2
Declare Sub monthheader()
Declare Sub yearheader
Declare Function inbox(colour As Ulong,x As Long,y As Long) As Long
Declare Sub paintscreen
Declare Sub mouseloop()
Declare Sub checkevents(mx As Long,my As Long)
Declare Function allflags() As Long
Declare Function checktext() As Long
Dim Shared As Single m1,m2,y1,y2,BOXWIDTH,d11,d12,d21,d22,digitboxwidth
Dim Shared As Long monthflag,yearflag,digit1flag,digit2flag,printflag,endflag,nowflag
Dim Shared As fb.event e
Dim Shared As Long _month,_year
Dim Shared As String monthtext,yeartext,digit1text,digit2text,mday,_yr,mn,verse
boxwidth=.07
m1=.1:m2=m1+.07'.2
y1=m2:y2=y1+.07
digitboxwidth=.04
d11=y2:d12=y2+digitboxwidth
d21=d12:d22=d21+digitboxwidth
Dim Shared  As box mon(1 To 13),montxt(1 To 13)
Dim Shared  As box yr(1 To 4),yrtxt(1 To 4)
Dim Shared  As box digit1(9),digit1txt(9)
Dim Shared  As box digit2(9),digit2txt(9)
Dim Shared As Ulong offwhite=Rgb(250,251,252)
'_ MAIN ___________
initdata
initmonth
inityear
initdigits
mouseloop
'___________________


'PROCEDURES __________________

Sub initdata
    Restore dat2
    For I As Long = 1 To 12
        Read MonthData(I).Month_name, MonthData(I).Number
    Next
End Sub

Sub initmonth
    Dim s As String
    Dim count As Long
    Restore dat1
    For x As Long=1 To 13
        Read s
        mon(x).text=s
        mon(x).value=x-1
        mon(x).colour=Rgb(0,200,x)
        montxt(x).colour=Rgb(255,255,200+x)
    Next x
    mon(1).colour=Rgb(200,200,1)
    Restore
End Sub
Sub inityear
    yr(1).text="Year"
    yr(2).text="18"
    yr(3).text="19"
    yr(4).text="20"
    For x As Long=1 To 4
        yr(x).colour=Rgb(200,0,x)
        yrtxt(x).colour=Rgb(254,254,200+x)
    Next x
    yr(1).colour=Rgb(0,0,200)
End Sub
Sub initdigits
    For x As Long=0 To 9
        digit1(x).text=Str(x)
        digit2(x).text=Str(x)
        digit1(x).colour=Rgb(101,101,101+x)
        digit2(x).colour=Rgb(102,102,102+x)
        digit1txt(x).colour=Rgb(253,253,200+x)
        digit2txt(x).colour=Rgb(252,252,200+x)
    Next x
End Sub
Sub dropmonth
    Dim k As Long:Dim sz As Long=30
    For x As Long=1 To 13
        Line(m1*xres,.1*yres+k)-(m2*xres,.1*yres+sz+k),mon(x).colour,BF
        Line(m1*xres,.1*yres+k)-(m2*xres,.1*yres+sz+k),Rgb(0,0,0),B
        mon(x).tx=m1*xres:mon(x).ty=.1*yres+k
        mon(x).bx=m2*xres:mon(x).by=.1*yres+sz+k
        Draw String((m1+.01)*xres,.11*yres+k),mon(x).text,montxt(x).colour
        k=k+sz
    Next x
End Sub

Sub dropyear
    Dim k As Long:Dim sz As Long=30
    For x As Long=1 To 4
        Line(y1*xres,.1*yres+k)-(y2*xres,.1*yres+sz+k),yr(x).colour,BF
        Line(y1*xres,.1*yres+k)-(y2*xres,.1*yres+sz+k),Rgb(0,0,0),B
        yr(x).tx=y1*xres:yr(x).ty=.1*yres+k
        yr(x).bx=y2*xres:yr(x).by=.1*yres+sz+k
        Draw String((y1+.01)*xres,.11*yres+k),yr(x).text,yrtxt(x).colour
        k=k+sz
    Next x
End Sub

Sub dropdigit1
    Dim k As Long:Dim sz As Long=30
    For x As Long=0 To 9
        Line(d11*xres,.1*yres+k)-(d12*xres,.1*yres+sz+k),digit1(x).colour,BF
        Line(d11*xres,.1*yres+k)-(d12*xres,.1*yres+sz+k),Rgb(0,0,0),B
        digit1(x).tx=d11*xres:digit1(x).ty=.1*yres+k
        digit1(x).bx=d12*xres:digit1(x).by=.1*yres+sz+k
        Draw String((d11+.01)*xres,.11*yres+k),digit1(x).text,digit1txt(x).colour
        k=k+sz
    Next x
End Sub
Sub dropdigit2
    Dim k As Long:Dim sz As Long=30
    For x As Long=0 To 9
        Line(d21*xres,.1*yres+k)-(d22*xres,.1*yres+sz+k),digit2(x).colour,BF
        Line(d21*xres,.1*yres+k)-(d22*xres,.1*yres+sz+k),Rgb(0,0,0),B
        digit2(x).tx=d21*xres:digit2(x).ty=.1*yres+k
        digit2(x).bx=d22*xres:digit2(x).by=.1*yres+sz+k
        Draw String((d21+.01)*xres,.11*yres+k),digit2(x).text,digit2txt(x).colour
        k=k+sz
    Next x
End Sub

Sub monthheader()
    Dim k As Long
    Dim sz As Long=30
    Dim count As Long=1
    Line(m1*xres,.1*yres+k)-(m2*xres,.1*yres+sz+k),mon(1).colour,BF
    Line(m1*xres,.1*yres+k)-(m2*xres,.1*yres+sz+k),Rgb(0,0,0),B
    Draw String((m1+.01)*xres,.11*yres+k),mon(1).text,montxt(1).colour
End Sub
Sub yearheader
    Dim k As Long
    Dim sz As Long=30
    Dim count As Long
    Line(y1*xres,.1*yres+k)-(y2*xres,.1*yres+sz+k),yr(1).colour,BF
    Line(y1*xres,.1*yres+k)-(y2*xres,.1*yres+sz+k),Rgb(0,0,0),B
    Draw String((y1+.01)*xres,.11*yres+k),yr(1).text,yrtxt(1).colour
End Sub

Function inbox(colour As Ulong,x As Long,y As Long) As Long
    If Point(x,y)=colour  Then
        Return -1
    Else
        Return 0
        Endif
    End Function
   
    Sub paintscreen
        Line(.1*xres,.1*yres)-(.9*xres,.9*yres),Rgb(2,2,2),B
        Paint (0,0),Rgb(236,233,216),Rgb(2,2,2)
        Paint(xres/2,yres/2),Rgb(255,255,255),Rgb(2,2,2)
        Line(.4*xres,.2*yres)-(.89*xres,.7*yres),Rgb(0,0,0),BF 'black box
        For k As Long=-3 To 3 'blue frame
            Line(.4*xres+k,.2*yres-k)-(.89*xres-k,.7*yres+k),Rgb(0,150+30*k,236),B
        Next k
    End Sub
   
    Sub checkevents(mx As Long,my As Long)
        'highlight month
        For x As Long = 2 To 13
            If  inbox(mon(x).colour,mx,my) Or inbox(montxt(x).colour,mx,my) Then
                Line(mon(x).tx,mon(x).ty)-(mon(x).bx,mon(x).by),Rgb(255,255,255),b
            End If
        Next x
        'highlight year
        For x As Long = 2 To 4
            If inbox(yr(x).colour,mx,my) Or inbox(yrtxt(x).colour,mx,my)Then
            Line(yr(x).tx,yr(x).ty)-(yr(x).bx,yr(x).by),Rgb(255,255,255),b
        End If
    Next x
    'highlight digits
    For x As Long = 0 To 9 
        If inbox(digit1(x).colour,mx,my) Or inbox(digit1txt(x).colour,mx,my)Then
        Line(digit1(x).tx,digit1(x).ty)-(digit1(x).bx,digit1(x).by),Rgb(255,255,255),b
    End If
Next x
For x As Long = 0 To 9 
    If inbox(digit2(x).colour,mx,my) Or inbox(digit2txt(x).colour,mx,my)Then
    Line(digit2(x).tx,digit2(x).ty)-(digit2(x).bx,digit2(x).by),Rgb(255,255,255),b
End If
Next x

'HEADERS
If (Screenevent(@e)) Then
    If e.type=13 Then End
   
    If e.type=fb.EVENT_MOUSE_BUTTON_PRESS Then
       
        If inbox(mon(1).colour,mx,my) Or inbox(montxt(1).colour,mx,my)Then
        monthflag=1
        nowflag=0
        Exit Sub
    End If
   
    If  inbox(yr(1).colour,mx,my) Or inbox(yrtxt(1).colour,mx,my)Then
    yearflag=1
    nowflag=0
    Exit Sub
End If
'OTHERS (drop menus)

For x As Long = 2 To 13 
    If  inbox(mon(x).colour,mx,my) Or inbox(montxt(x).colour,mx,my) Then
        _month=mon(x).value
        monthtext=mon(x).text
        Line(mon(x).tx,mon(x).ty)-(mon(x).bx,mon(x).by),Rgb(255,255,255),bf
        Exit Sub
    End If
Next x

For x As Long = 2 To 4 
    If inbox(yr(x).colour,mx,my) Or inbox(yrtxt(x).colour,mx,my)Then
    yeartext=yr(x).text
    '_year=yr(x).value
    Line(yr(x).tx,yr(x).ty)-(yr(x).bx,yr(x).by),Rgb(255,255,255),bf
    Exit Sub
End If
Next x

For x As Long = 0 To 9 
    If inbox(digit1(x).colour,mx,my) Or inbox(digit1txt(x).colour,mx,my)Then
    digit1text=digit1(x).text
    digit1flag=1
    Line(digit1(x).tx,digit1(x).ty)-(digit1(x).bx,digit1(x).by),Rgb(255,255,255),bf
    Exit Sub
End If
Next x

For x As Long = 0 To 9 
    If  inbox(digit2(x).colour,mx,my) Or inbox(digit2txt(x).colour,mx,my)Then
    digit2text=digit2(x).text
    digit2flag=1
    Line(digit2(x).tx,digit2(x).ty)-(digit2(x).bx,digit2(x).by),Rgb(255,255,255),bf
    Exit Sub
End If
Next x   
If incircle(.5*xres,.8*yres,35,mx,my) Then
    _year=Valint(_yr): _month= Valint(mn )
    nowflag=1
    yearflag=0
    monthflag=0
    monthtext=""
    yeartext=""
    digit1text=""
    digit2text=""
    Exit Sub
End If
'LAST EVENT REACHED (date filled)

If incircle(.5*xres,.05*yres,xres/30,mx,my) Then
    printflag=1
    Exit Sub
End If

End If 'e.type 

End If 'screvent
End Sub
Function allflags() As Long
    Dim sum As Long=monthflag+yearflag+digit1flag+digit2flag
    If sum=4 Then
        Return -1
    Else
        Return 0
    End If
End Function

Function checktext() As Long
    If monthtext="" Then Return 0
    If yeartext="" Then Return 0
    If digit1text="" Then Return 0
    If digit2text="" Then Return 0
    Return -1
End Function


Sub mouseloop()
   
    Dim As Long mx,my
    Do
        Getmouse mx,my
        mday=Mid(Date,4,2)
        _yr=Mid(Date,7,4)
        mn=Mid(Date,1,2)
        Screenlock
        Cls
        paintscreen
        If allflags And printflag Then
            For z As Single=35 To 30 Step -.1
                Circle(.5*xres,.8*yres),z,Rgb(0,150+30*z,236)
            Next z
            Circle(.5*xres,.8*yres),30,Rgb(0,0,0),,,,f
            Draw String(.485*xres,.79*yres),"Now"
        End If
        If nowflag=1 Then
            digits(Time,.52*xres,.13*yres,Rgb(100,0,0),10)
            Draw String(.215*xres,.37*yres),"Now",Rgb(0,0,0)
            #define pt(n) Draw String(.2*xres-n,.8*yres),verse,Rgb(0,00,0)
            ' dim as long temp3=12 (for testing rymes)
            Select Case _month
            Case 1
                verse="January brings the snow, Makes our feet and fingers glow."
                Draw String(.2*xres,.8*yres),verse,Rgb(0,00,0)
            Case 2
                verse="February brings the rain, Thaws the frozen lake again."
                pt(Len(verse))
            Case 3
                verse="March brings breezes loud and shrill, Stirs the golden daffodil."
                pt(Len(verse))
            Case 4
                verse="April brings the primrose sweet, Scatters daisies at our feet."
                pt(Len(verse))
            Case 5
                verse="May brings flocks of pretty lambs, Skipping by their fleecy dams."
                pt(Len(verse))
            Case 6
                verse="June brings tulips, lillies, roses, Fills the children's hands with posies."
                pt(Len(verse))
            Case 7
                verse="Hot July brings cooling showers, Apricots and gillyflowers."
                pt(Len(verse))
            Case 8
                verse="August brings the sheaves of corn, Then the harvest home is borne."
                pt(Len(verse))
            Case 9
                verse="Warm September brings the fruit, Sportsmen then begin to shoot."
                pt(Len(verse))
            Case 10
                verse="Fresh October brings the pheasant, Then to gather nuts is pleasant."
                pt(Len(verse))
            Case 11
                verse="Dull November brings the blast, Then the leaves are falling past."
                pt(Len(verse))
            Case 12
                verse="Chill December brings the sleet, Blazing fire and Christmas treat."
                pt(Len(verse))
            End Select
            inspect(185,230,2.5)
        End If
        monthheader
        yearheader
        If printflag=1 Then PrintCalendar _year, _month
        If monthflag=1 Then dropmonth:Draw String (.1*xres,.05*yres),monthtext,Rgb(0,0,0)
        If yearflag=1 Then
            dropyear:Draw String (.15*xres,.05*yres),yeartext,Rgb(0,0,0)
            dropdigit1:Draw String (.17*xres,.05*yres),digit1text,Rgb(0,0,0)
            dropdigit2:Draw String (.18*xres,.05*yres),digit2text,Rgb(0,0,0)
        End If
        If (allflags And checktext) Then
            If printflag=0 Then 
                Circle(.5*xres,.05*yres),xres/30,Rgb(100,100,100),,,,f
                Draw String(.475*xres,.04*yres),"Start",offwhite
            End If
            If nowflag=0 Then  _year=Valint(yeartext+digit1text+digit2text)
           
        End If
        If _year<1899 Then
            printflag=0
            Draw String(10,10),"NOT BEFORE 1899 PLEASE",Rgb(255,0,0)
        End If
       
        checkevents(mx,my)
        Screenunlock
        Sleep 1,1
    Loop Until Inkey=Chr(27) Or endflag=1
End Sub
Sub ComputeMonth (_year As Long, _month As Long, Byref StartDay As Long,Byref TotalDays As Long)
    Const LEAP = 366 Mod 7
    Const NORMAL = 365 Mod 7
    Dim As Long NumDays,I
    For I  = 1899 To _year- 1
        If IsLeapYear(I) Then           
            NumDays = NumDays + LEAP   
        Else                               
            NumDays = NumDays + NORMAL
        End If
    Next
   
    For I = 1 To _month - 1
        NumDays = NumDays + MonthData(I).Number
    Next
    TotalDays = MonthData(_month).Number
    If IsLeapYear(_year) Then
        If _month > 2 Then
            NumDays = NumDays + 1
        Elseif _month = 2 Then
            TotalDays = TotalDays + 1
        End If
    End If
    StartDay = NumDays Mod 7
End Sub
Function IsLeapYear (N As Long) As Long
    IsLeapYear = (N Mod 4 = 0 And N Mod 100 <> 0) Or (N Mod 400 = 0)
End Function

Sub inspect(mx As Long,my As Long,mw As Long)
    If mw=0 Then mw=1
    mw=Abs(mw)
    For z As Long=0 To 16
        Line(mx-40+z,my-40+z)-(mx+40-z,my+40-z),Rgb(50*z/40,50*z/4,50*z/3.2),B
    Next z
    Dim As Ulong array(1 To 6561)
    Dim As Long count
    For x As Long=mx-40 To mx+40
        For y As Long=my-40 To my+40
            count=count+1
            array(count)=Point(x,y)
        Next y
    Next x
    count=0
    For x As Long=mx-40 To mx+40
        For y As Long=my-40 To my+40
            count=count+1
            Var NewX=mw*(x-mx)+mx
            Var NewY=mw*(y-my)+my
            Line(NewX-mw/2,NewY-mw/2)-(NewX+mw/2,NewY+mw/2),array(count),BF
        Next y
    Next x
End Sub
Sub PrintCalendar (_year As Long, _month As Long) 'STATIC
    Dim As String header
    Dim As Long totaldays,_pos,_csrlin
    Dim As Long startday,leftmargin
    ComputeMonth _year, _month, StartDay, TotalDays
    Header = Rtrim(MonthData(_month).Month_name) + ", " + Str(_year)
    LeftMargin = (35 - Len(Header)) \ 2
    Locate 15
    Print Tab(LeftMargin+50); Header
    Print
    Print Tab(50);"Su    M   Tu    W   Th    F   Sa"
    Print
    LeftMargin = 5 * StartDay + 1
    Print Tab(LeftMargin+49);
    For I As Long = 1 To TotalDays
        Print Using "##_   "; I;
        If I=Valint(mday) Then
            _pos=Pos
            _csrlin=Csrlin
            If nowflag=1 Then Circle(  (xres*(_pos)/100)-38,yres*_csrlin/37-15),13,Rgba(200,0,0,150),,,,f
        End If
        If Pos(0) > 82 Then Print Tab(50);
       
    Next
   
End Sub

dat1: 'for boxes
Data "Month","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC"
dat2:'for calendar
Data "January", 31, "February", 28,  "March", 31
Data "April", 30,   "May", 31, "June", 30, "July", 31, "August", 31
Data "September",   30, "October", 31, "November", 30, "December", 31
Sub digits(t As String,x As Long,y As Long,clr As Ulong,sz As Long,img As Any Pointer=0)
    x=x-2*sz
    Dim As Single s=Any,c=Any
    #macro thickline(x1,y1,x2,y2)
    s=(y1-y2)/10
    c=(x2-x1)/10
    Line img,(x1-s,y1-c)-(x2+s,y2+c),clr,bf
    #endmacro
    #macro display(_a,_b,_c,_d,_e,_f,_g)
    x=x+2*sz
    If _a=1 Then :thickline(x,y,(x+sz),y):End If
    If _b=1 Then :thickline((x+sz),y,(x+sz),(y+sz)):End If
    If _c=1 Then :thickline((x+sz),(y+sz),(x+sz),(y+2*sz)):End If
    If _d=1 Then :thickline((x+sz),(y+2*sz),x,(y+2*sz)):End If
    If _e=1 Then :thickline(x,(y+2*sz),x,(y+sz)):End If
    If _f=1 Then :thickline(x,(y+sz),x,y):End If
    If _g=1 Then :thickline(x,(y+sz),(x+sz),(y+sz)):End If
    #endmacro
    For z As Long=0 To Len(t)-1
        Select Case As Const t[z]
        Case 48 :display(1,1,1,1,1,1,0)             '"0"
        Case 49 :display(0,1,1,0,0,0,0)             '"1"
        Case 50 :display(1,1,0,1,1,0,1)             '"2"
        Case 51 :display(1,1,1,1,0,0,1)             '"3"
        Case 52 :display(0,1,1,0,0,1,1)             '"4"
        Case 53 :display(1,0,1,1,0,1,1)             '"5"
        Case 54 :display(1,0,1,1,1,1,1)             '"6"
        Case 55 :display(1,1,1,0,0,0,0)             '"7"
        Case 56 :display(1,1,1,1,1,1,1)             '"8"
        Case 57 :display(1,1,1,1,0,1,1)            '"9"
        Case 58                                     '":"                   
            Circle((x+2*sz),(y+sz/2)),(sz/5),clr,,,,f
            Circle((x+2*sz),(y+1.5*sz)),(sz/5),clr,,,,f
            x=x+sz
        Case 45 :display(0,0,0,0,0,0,1)              '"-"                       
        Case 46                                      '"."                       
            Circle((x+2*sz),(y+1.9*sz)),(sz/5),clr,,,,f
            x=x+sz
        Case 32                                      '" "
            x=x+sz
        End Select
    Next z
End Sub 

 

[Tourist Trap]

Hi, all!

Happy New Year 2.017!!!

As for you Ircvs, and all fb community :)

[lrcvs]

Hi!

@ dodicat:

As always thanks for your good opinion!

Here, in Spain, we say:
"... that inspiration finds me working ..."
... It has just been a moment of lucidity ...
The merit is from "Zeller's congruence".

@ Tourist Trap: Equally for you!