viewtopic.php?p=53982&hilit=calendar#p53982
and took the liberty to pimp it a bit.
In essence this code adds:
- cheap month and day localization (without forcing the locale)
- highlight current date
- adds a modicum of customization
- adds basic navigation (month and year) with keyboard, mouse and gamepad
It comes in two flavors:
- fb only ascii
- fb and sdl
For the record the more conventional way would / could be
by doing the heavy lifting with the os there are two demo's
bundled with FB at:
os unix \ gtk version
<drive:>\freebasic\FreeBASIC-1.09.0-gcc-9.3\examples\GUI\GTK+\Tutorials\calendar.bas
os windows version
<drive:>\freebasic\FreeBASIC-1.09.0-gcc-9.3\examples\GUI\win32\calendar.bas
however this approach allows for a bit more freedom in
visual design and are both, to a degree, platform agnostic.
navigation
dpad gamepad or arrow keys keyboard > up - down / year | left - right / month
mouse cursor > left - right / month
mouse wheel > up - down / year
fb ascii version:
Code: Select all
' generic calendar generation with keyboard, mouse and gamepad navigation
' by thrive4 2022
' based on code by zippy see
' https://www.freebasic.net/forum/viewtopic.php?p=53982&hilit=calendar#p53982
#include once "fbgfx.bi"
#include once "vbcompat.bi"
' init screen
dim screenwidth As integer = 180
dim screenheight As integer = 160
dim aspectratio as single = screenwidth / screenheight
' 32 bit
'type calatributes
' foregroundcolor as ulong = RGB(255, 255, 255)
' backgroundcolor as ulong = RGB(0, 0, 0)
' highlightcolor as ulong = rgba(255, 0, 0, 0)
' headercolor as ulong = rgba(125, 125, 125, 0)
'end type
' 8 bit
type calatributes
foregroundcolor as integer = 15
backgroundcolor as integer = 0
highlightcolor as integer = 4
headercolor as integer = 7
customdate as boolean = true
end type
dim cb as calatributes
' customdate force date to other langauage
dim shared customday(1 to 7) as string
customday(1) = "sunday"
customday(2) = "monday"
customday(3) = "tuesday"
customday(4) = "wensday"
customday(5) = "thurseday"
customday(6) = "friday"
customday(7) = "saturday"
dim shared custommonth(1 to 12) as string
custommonth(1) = "january"
custommonth(2) = "february"
custommonth(3) = "march"
custommonth(4) = "april"
custommonth(5) = "may"
custommonth(6) = "june"
custommonth(7) = "july"
custommonth(8) = "august"
custommonth(9) = "september"
custommonth(10) = "oktober"
custommonth(11) = "november"
custommonth(12) = "december"
' init mouse feedback
Type mousecoord
x As integer
y As integer
End Type
dim mouse as mousecoord
Dim As Integer x, y, wheel, wheelup, buttons, buttonsup, res
mouse.x = 0
mouse.y = 0
dim keybbuffer as string = ""
' size of increment move mouse pointer when simulated by keyboard or gamepad
dim pointermove as integer = 10
' init hitbox for month navigation with mouse click
Type hbcoord
x As integer
y As integer
w As integer
h As integer
End Type
dim navleft as hbcoord
navleft.x = 2
navleft.y = 5
navleft.w = 40
navleft.h = 20
dim navright as hbcoord
navright.x = 120
navright.y = 5
navright.w = 60
navright.h = 20
' init gamepad
dim resgp as integer
dim swapgamepad as boolean = false
dim gpbuttons as integer
dim hatlr as single
dim hatud as single
dim chkgp as boolean = false
Const JoystickID = 0
if GetJoystick(JoystickID) then
' no gamepad reversed logic..
chkgp = false
else
chkgp = true
end if
' generate ascii calendar
function asciical(m as integer, y as integer, cb as calatributes) as integer
dim as double db, dn = now
dim as integer d, sdow
dim as integer a, c, ndays
dim as string t
cls
Color (cb.headercolor, cb.backgroundcolor)
d = day(dn)
if m = 0 or m > 12 or m < 0 then
m = month(dn)
end if
if y = 0 then
y = year(dn)
end if
db = dateserial(y,m,1)
sdow = weekday(db,0)
for ndays = 31 to 28 step -1
if month(dateserial(y,m,ndays)) = m then exit for
next
if cb.customdate then
t = custommonth(m) & " " & y
print:print;space(8 - len(t) \ 2);"< ";t;" >"
print
for a = 1 to 7
print " ";left(customday(a), 2);
next
print
else
t = MonthName(m) & " " & y
print:print space(11 - len(t) \ 2);t
print
for a=1 to 7
print " ";left(WeekdayName(a, 1, 0), 2);
next
print
end if
a = 2 - sdow:c = 0
while a <= ndays
if a >= 1 then
' highlight current date when applicable
if a = val(Format(now, "d")) and m = val(format(now, "mm")) and y = val(format(now, "yyyy")) then
Color (cb.foregroundcolor, cb.highlightcolor)
print using "###";a;
else
print using "###";a;
end if
else
print space(3);
end if
Color (cb.foregroundcolor, cb.backgroundcolor)
a += 1:c += 1
if c = 7 then c = 0:print:end if
wend
print
return 0
end function
' main
ScreenRes screenwidth, screenheight, 8,, (FB.GFX_WINDOWED)
SetMouse(screenwidth * 0.5, screenheight * 0.5)
' use 8 x 14 font
Width screenwidth \ 8, screenheight \ 14
' asciical (month(numrical), year, custom(use custom month and day name), cb is calendar attributes)
asciical(0, 0, cb)
' main navigation with mouse, keyboard and gamepad
dim monthbkm as integer = val(format(now, "mm"))
dim yearbkm as integer = val(format(now, "yyyy"))
Do
' note check is needed otherwise calling getjoystick with no gamepad can crash application
if chkgp then
resgp = GetJoystick(JoystickID, gpbuttons,,,,,,, hatlr, hatud)
' reinit gamepad not supported
if gpbuttons = -1 then
swapgamepad = true
exit do
end if
end if
buttonsup = buttons
' catch wheel value to -1 when outside window
if wheel <> -1 then
wheelup = wheel
end if
res = GetMouse (x, y, wheel, buttons)
'Locate 1, 1
If res <> 0 Then '' Failure
#ifdef __FB_DOS__
'Print "Mouse or mouse driver not available"
#else
'Print "Mouse not available or not on window"
#endif
Else
' debug
'Print Using "mouse position: ###:### buttons: "; x; y;
'If buttons And 1 Then Print "l";" hitbox output ";'hboutput
'If buttons And 2 Then Print "r";" "
'If buttons And 4 Then Print "m";" "
' navigate with mouse wheel
if wheel <> wheelup then
if wheel > wheelup then
' scroll up
yearbkm += 1
asciical(monthbkm, yearbkm, cb)
'y = y - pointermove
else
' scroll down
yearbkm -= 1
asciical(monthbkm, yearbkm, cb)
'y = y + pointermove
end if
else
' nop stationary
end if
' naviagte with mouse
mouse.x = x
mouse.y = y
' ghetto hitbox navigate with mouse click left
' left
if ((mouse.x >= navright.x) and (mouse.x < (navright.x + navright.w))_
and (mouse.y >= navright.y) and (mouse.y < (mouse.y + navright.h)))_
and buttons And 1 then
if monthbkm < 12 then
monthbkm += 1
asciical(monthbkm, yearbkm, cb)
end if
end if
' right
if ((mouse.x >= navleft.x) and (mouse.x < (navleft.x + navleft.w))_
and (mouse.y >= navleft.y) and (mouse.y < (mouse.y + navleft.h)))_
and buttons And 1 then
if monthbkm > 1 then
monthbkm -= 1
asciical(monthbkm, yearbkm, cb)
end if
end if
' navigate with keyboard arrow keys a bit klunky
' scancode constants need #include "fbgfx.bi" and using FB
' left
If MultiKey(&h4B) And mouse.x > 0 Then
if monthbkm > 1 then
monthbkm -= 1
asciical(monthbkm, yearbkm, cb)
end if
'SetMouse mouse.x - pointermove, mouse.y
end if
' right
If MultiKey(&h4D) And mouse.x < screenwidth Then
if monthbkm < 12 then
monthbkm += 1
asciical(monthbkm, yearbkm, cb)
end if
'SetMouse mouse.x + pointermove, mouse.y
end if
' up
If MultiKey(&h48) And mouse.y > 0 Then
yearbkm += 1
asciical(monthbkm, yearbkm, cb)
'SetMouse mouse.x, mouse.y - pointermove
end if
' down
If MultiKey(&h50) And mouse.y < screenheight Then
yearbkm -= 1
asciical(monthbkm, yearbkm, cb)
'SetMouse mouse.x, mouse.y + pointermove
end if
If MultiKey(&h1C)Then
' fake mouse button left
buttons = 1
'print "enter"
end if
' naviagte with gamepad dpad input and button A
select case hatud
' hat down
case 1
yearbkm -= 1
asciical(monthbkm, yearbkm, cb)
'SetMouse mouse.x, mouse.y + pointermove
' hat up
case -1
yearbkm += 1
asciical(monthbkm, yearbkm, cb)
'SetMouse mouse.x, mouse.y - pointermove
end select
select case hatlr
' hat right
case 1
if monthbkm < 12 then
monthbkm += 1
asciical(monthbkm, yearbkm, cb)
end if
'SetMouse mouse.x + pointermove, mouse.y
' hat left
case -1
if monthbkm > 1 then
monthbkm -= 1
asciical(monthbkm, yearbkm, cb)
end if
'SetMouse mouse.x - pointermove, mouse.y
end select
select case gpbuttons
' dinput A
case 2
buttons = 1
' xinput A
case 1
buttons = 1
end select
' mouse button up see https://www.freebasic.net/forum/viewtopic.php?p=15237&hilit=mouse+button+up#p15237
' comment coderjeff
if ((buttons And 1) = 1) And ((buttonsup And 1) = 0) then
'keybbuffer = keybbuffer + hboutput
end if
End If
' use sleep to keep cpu usage low also effects naviagtion speed
sleep(120)
Loop While Inkey <> chr$(27)
end
/' sample ini for forced language date
[language-en month]
m1 = january
m2 = february
m3 = march
m4 = april
m5 = may
m6 = june
m7 = july
m8 = august
m9 = september
m10 = oktober
m11 = november
m12 = december
[language-en day]
d1 = monday
d2 = tuesday
d3 = wednesday
d4 = thurseday
d5 = friday
d6 = saturday
d7 = sunday
'/