## Simple Calendar (Show only one month)

General FreeBASIC programming questions.
lrcvs
Posts: 569
Joined: Mar 06, 2008 19:27
Location: Spain

### Simple Calendar (Show only one month)

Hi!

A simple Calendar program, show only one month

Code: Select all

`'PROGRAM:CALENDAR, SHOW ONLY ONE MONTHDIM AS INTEGER a,c,d,dm,ds,f,j,k,m,n,yDIM u (49) AS STRINGDIM v (6,7) AS STRINGd = 1CLSINPUT "Month number 1...12 = ";mINPUT "Year number yyyy = ";yCLSIF m = 1 OR m = 3 OR m = 5 OR m = 7 OR m = 8 OR m = 10 OR m = 12 THEN dm = 31IF m = 4 OR m = 6 OR m = 9 OR m = 11 THEN dm = 30IF m = 2 THEN dm = 28IF m = 2 AND ((y MOD 4) =  0 OR ((y MOD 100) = 0 AND (y MOD 400)) = 0) THEN dm = 29a = INT((14 - m) / 12)y = y - am = m + (12 * a) - 2ds =((d + y + INT(y / 4) - INT(y / 100) + INT(y / 400) + INT((31 * m) / 12)) MOD 7)IF ds = 0 THEN ds = ds +7IF ds > 0 THEN ds = ds -1FOR n = 1 TO 49    u(n) = "  "NEXT nFOR 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 nc = 1FOR j = 1 TO 6    FOR k = 1 TO 7        v(j,k) = MID(u(c),1,3)        c = c + 1    NEXT kNEXT 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    PRINTNEXT jSLEEPEND`

Regards
Tourist Trap
Posts: 2792
Joined: Jun 02, 2015 16:24

### Re: Simple Calendar (Show only one month)

lrcvs wrote: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
Posts: 333
Joined: Sep 28, 2013 15:08
Location: Bavaria, Germany

### Re: Simple Calendar (Show only one month)

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, colClsInput "Month number 1...12 = ";mInput "Year number yyyy = ";yClsPrint "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 IfNextEnd`

Should also work in 2017. Happy New Year!
bcohio2001
Posts: 550
Joined: Mar 10, 2007 15:44
Location: Ohio, USA
Contact:

### Re: Simple Calendar (Show only one month)

There is also:

Code: Select all

`Print MonthName(m)`
lrcvs
Posts: 569
Joined: Mar 06, 2008 19:27
Location: Spain

### Re: Simple Calendar (Show only one month)

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:

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
Posts: 569
Joined: Mar 06, 2008 19:27
Location: Spain

### Re: Simple Calendar (Show only one month)

Hi,
To bcohio2001:

I will see!

Regards!
Zippy
Posts: 1295
Joined: Feb 10, 2006 18:05

### Re: Simple Calendar (Show only one month)

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 datedeclare 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
Posts: 3332
Joined: Jun 02, 2013 9:27
Location: Switzerland

### Re: Simple Calendar (Show only one month)

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 datedeclare function printcal(ds as string) as long'start Main'printcal(EU String Date: "DD.MM.YYYY")Dim As Long retret = printcal("01.02.2016")'ret = printcal("01.02.2017")Print : Print "DateSerial: "; Str(ret)sleep' end Mainfunction 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 7End Function`
Happy 2017, to all!
lrcvs
Posts: 569
Joined: Mar 06, 2008 19:27
Location: Spain

### Re: Simple Calendar (Show only one month)

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 MONTHDIM AS INTEGER a,c,d,dm,ds,f,j,k,m,n,y, ZDIM u (49) AS STRINGDIM v (6,7) AS STRINGd = 1CLSINPUT "Month number 1...12 = ";mINPUT "Year number yyyy = ";yCLSIF m = 2 THEN dm = 28If 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 = 31IF m = 4 OR m = 6 OR m = 9 OR m = 11 THEN dm = 30a = INT((14 - m) / 12)y = y - am = m + (12 * a) - 2ds =((d + y + INT(y / 4) - INT(y / 100) + INT(y / 400) + INT((31 * m) / 12)) MOD 7)IF ds = 0 THEN ds = ds +7IF ds > 0 THEN ds = ds -1FOR n = 1 TO 49    u(n) = "  "NEXT nFOR 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 nc = 1FOR j = 1 TO 6    FOR k = 1 TO 7        v(j,k) = MID(u(c),1,3)        c = c + 1    NEXT kNEXT 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    PRINTNEXT jSLEEPEND`

Happy New Year 2.017 !!!
Lothar Schirm
Posts: 333
Joined: Sep 28, 2013 15:08
Location: Bavaria, Germany

### Re: Simple Calendar (Show only one month)

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.
Last edited by Lothar Schirm on Jan 01, 2017 12:16, edited 1 time in total.
BasicCoder2
Posts: 3422
Joined: Jan 01, 2009 7:03

### Re: Simple Calendar (Show only one month)

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?

.
Last edited by BasicCoder2 on Jan 01, 2017 14:35, edited 3 times in total.
lrcvs
Posts: 569
Joined: Mar 06, 2008 19:27
Location: Spain

### Re: Simple Calendar (Show only one month)

Hi:

To Lothar Schirm:

See:

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

To BasicCoder2

Thanks!

Regards
Last edited by lrcvs on Jan 07, 2017 13:01, edited 1 time in total.
dodicat
Posts: 6102
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Simple Calendar (Show only one month)

BasicCoder2 wrote: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,yresScreen 19,32,1,FB.GFX_ALPHA_PRIMITIVESScreeninfo xres,yresWindowtitle "FreeBASIC CALENDAR"#macro incircle(cx,cy,radius,x,y)(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius#endmacroType box    As String text    As Ulong colour    As Long value,tx,ty,bx,byEnd TypeType Calendar_Month    Number As Long      Month_name As String End TypeDeclare 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 LongDeclare 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_MonthDeclare Sub initdataDeclare Sub initmonthDeclare Sub inityearDeclare Sub initdigitsDeclare Sub dropmonthDeclare Sub dropyearDeclare Sub dropdigit1Declare Sub dropdigit2Declare Sub monthheader()Declare Sub yearheaderDeclare Function inbox(colour As Ulong,x As Long,y As Long) As LongDeclare Sub paintscreenDeclare Sub mouseloop()Declare Sub checkevents(mx As Long,my As Long)Declare Function allflags() As LongDeclare Function checktext() As LongDim Shared As Single m1,m2,y1,y2,BOXWIDTH,d11,d12,d21,d22,digitboxwidthDim Shared As Long monthflag,yearflag,digit1flag,digit2flag,printflag,endflag,nowflagDim Shared As fb.event eDim Shared As Long _month,_yearDim Shared As String monthtext,yeartext,digit1text,digit2text,mday,_yr,mn,verseboxwidth=.07m1=.1:m2=m1+.07'.2y1=m2:y2=y1+.07digitboxwidth=.04d11=y2:d12=y2+digitboxwidthd21=d12:d22=d21+digitboxwidthDim 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 ___________initdatainitmonthinityearinitdigitsmouseloop'___________________'PROCEDURES __________________Sub initdata    Restore dat2    For I As Long = 1 To 12        Read MonthData(I).Month_name, MonthData(I).Number    Next End SubSub 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)    RestoreEnd SubSub 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 SubSub 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 xEnd SubSub 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 xEnd SubSub 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 xEnd SubSub 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 xEnd SubSub 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 xEnd SubSub 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).colourEnd SubSub 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 SubFunction 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 IfNext xFor 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),bEnd IfNext x'HEADERSIf (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 SubEnd 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 IfNext xFor 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 SubEnd IfNext xFor 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 SubEnd IfNext xFor 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 SubEnd IfNext 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 SubEnd If'LAST EVENT REACHED (date filled)If incircle(.5*xres,.05*yres,xres/30,mx,my) Then     printflag=1    Exit SubEnd IfEnd If 'e.type  End If 'screventEnd SubFunction allflags() As Long    Dim sum As Long=monthflag+yearflag+digit1flag+digit2flag    If sum=4 Then        Return -1    Else        Return 0    End IfEnd FunctionFunction checktext() As Long    If monthtext="" Then Return 0    If yeartext="" Then Return 0    If digit1text="" Then Return 0    If digit2text="" Then Return 0    Return -1End FunctionSub 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=1End SubSub 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 7End SubFunction IsLeapYear (N As Long) As Long    IsLeapYear = (N Mod 4 = 0 And N Mod 100 <> 0) Or (N Mod 400 = 0)End FunctionSub 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 xEnd SubSub 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 Subdat1: 'for boxesData "Month","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC"dat2:'for calendarData "January", 31, "February", 28,  "March", 31Data "April", 30,   "May", 31, "June", 30, "July", 31, "August", 31Data "September",   30, "October", 31, "November", 30, "December", 31Sub 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 zEnd Sub   `
Tourist Trap
Posts: 2792
Joined: Jun 02, 2015 16:24

### Re: Simple Calendar (Show only one month)

lrcvs wrote:Hi, all!

Happy New Year 2.017!!!

As for you Ircvs, and all fb community :)
lrcvs
Posts: 569
Joined: Mar 06, 2008 19:27
Location: Spain

### Re: Simple Calendar (Show only one month)

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!