'inspired by a demo written by Brent Thorn - thanks, Brent!
NoMainWin
DTM.GETSYSTEMTIME = 4097'message flag to retrieve date/time chosen
' nYear=year chosen
' nMon=month number chosen
' nDay=day number
' nMon$=month name chosen
' t$=concatenated date - APR 31, 2051
' oldt$=previously selected date
Struct SYSTEMTIME, _'struct to hold date time info to interact with control
wYear As word, _
wMonth As word, _
wDayOfWeek As word, _ '0 = Sunday, 1 = Monday, etc.
wDay As word, _
wHour As word, _
wMinute As word, _
wSecond As word, _
wMilliseconds As word
struct icex,dwSize As ulong,dwICC As ulong
icex.dwSize.struct = Len(icex.struct)
icex.dwICC.struct = Hexdec("100") 'ICC_DATE_CLASSES
CallDLL #comctl32, "InitCommonControlsEx",icex As struct, r As long
cr$=chr$(13)
m$="Click date to select a day."+cr$
m$=m$+"Click the arrows at the "
m$=m$+"top to change the month."+cr$
m$=m$+"Click the year number to "
m$=m$+"display arrow buttons to"+cr$
m$=m$+" change the year."
WindowWidth=400:WindowHeight=310
UpperLeftX=100:UpperLeftY=100
button #1.default, "Exit",[quit],UL,250,5,130,24
button #1.font1, "Font 1",[font1],UL,250,34,60,24
button #1.font2, "Font 2",[font2],UL,320,34,60,24
statictext #1, "Today:",270,90,120,20
statictext #1.today, "",270,110,120,20
statictext #1, "Chosen",270,150,120,20
statictext #1.chosen, "",270,170,120,20
statictext #1, m$,20,200,360,100
'Note the difference in appearance between window and dialog types
'Open "Month Calendar" for window_nf as #1
Open "Month Calendar" For dialog_nf As #1
#1 "TrapClose [quit]"
#1 "font ms_sans_serif 10"
h1 = hWnd(#1)
hInst=InstanceHandle(h1)
flags=_WS_VISIBLE Or _WS_CHILD Or _WS_DLGFRAME
hDT=CreateWindow(h1,hInst,5,5,230,190,"SysMonthCal32",flags)
print #1.today, GetToday$(hDT)
timer 400, [getDate]
Wait
[quit]
timer 0
if hFont2 then call DeleteObject hFont2
notice "Month Calendar Demo, " + chr$(169) + " 2003, Alyce Watson"
Close #1:End
[getDate]
nYear=GetYear(hDT)
nMon=GetMonth(hDT)
nDay=GetDay(hDT)
nMon$=GetMonth$(hDT)
t$=nMon$+" "+str$(nDay)+", "+str$(nYear)
if t$=oldt$ then wait
oldt$=t$
print #1.chosen, t$
wait
[font1]
'Calendar size is dependent upon font chosen.
'Note that the usual LB font in a dialog is
'different than the usual LB font in a window.
'To change the size of the calendar,
'change the font. This routine uses the
'system's stock GUI font.
hFont=GetStockObject(_DEFAULT_GUI_FONT)
r=SetFont(hDT,hFont)
wait
[font2]
'Calendar size is dependent upon font chosen.
'Note that the usual LB font in a dialog is
'different than the usual LB font in a window.
'To change the size of the calendar,
'change the font. This routine allows you
'to use any face and size font you want.
'Demo is times new roman, size 24pixels, italic.
hFont2=CreateFont("times new roman",0,24,0,1,0,0)
r=SetFont(hDT,hFont2)
wait
'functions and subs:
Function InstanceHandle(hW)
CallDLL #user32, "GetWindowLongA", _
hW As ulong, _GWL_HINSTANCE As long, _
InstanceHandle As ulong
End Function
Function CreateWindow(hW,hInstance,x,y,w,h,class$,style)
CallDLL #user32, "CreateWindowExA", _
0 As long,_ 'extended style
class$ As ptr, _ 'class
"" As ptr, _ 'name
style As long,_ 'window style flags
x As long, y As long,_ 'upper left x,y
w As long, h As long,_ 'width and height
hW As ulong,_ 'parent window handle
0 As long,_ 'menu handle
hInstance As ulong,_ 'instance handle of parent
0 As long, _ 'not used here - extra data
CreateWindow As ulong 'handle of created control
End Function
Function GetYear(hW)
DTM.GETSYSTEMTIME = 4097
CallDLL #user32, "SendMessageA", _
hW As ulong, _ 'handle of control
DTM.GETSYSTEMTIME As long,_ 'flag to get chosen date/time
0 As long, _ 'wparam=0
SYSTEMTIME As struct,_ 'name of struct
ret As long
GetYear=SYSTEMTIME.wYear.struct
End Function
Function GetMonth(hW)
DTM.GETSYSTEMTIME = 4097
CallDLL #user32, "SendMessageA", _
hW As ulong, _ 'handle of control
DTM.GETSYSTEMTIME As long,_ 'flag to get chosen date/time
0 As long, _ 'wparam=0
SYSTEMTIME As struct,_ 'name of struct
ret As long
GetMonth=SYSTEMTIME.wMonth.struct
End Function
Function GetMonth$(hW)
DTM.GETSYSTEMTIME = 4097
CallDLL #user32, "SendMessageA", _
hW As ulong, _ 'handle of control
DTM.GETSYSTEMTIME As long,_ 'flag to get chosen date/time
0 As long, _ 'wparam=0
SYSTEMTIME As struct,_ 'name of struct
ret As long
m$="JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC"
mNum=SYSTEMTIME.wMonth.struct
if mNum<=0 then mNum=1
GetMonth$=word$(m$,mNum)
End Function
Function GetDay(hW)
DTM.GETSYSTEMTIME = 4097
CallDLL #user32, "SendMessageA", _
hW As ulong, _ 'handle of control
DTM.GETSYSTEMTIME As long,_ 'flag to get chosen date/time
0 As long, _ 'wparam=0
SYSTEMTIME As struct,_ 'name of struct
ret As long
GetDay=SYSTEMTIME.wDay.struct
End Function
Function GetToday$(hndle)
nYear=GetYear(hndle)
nDay=GetDay(hndle)
nMon$=GetMonth$(hndle)
GetToday$=nMon$+" "+str$(nDay)+", "+str$(nYear)
End Function
Function GetStockObject(obj)
CallDLL #gdi32, "GetStockObject",obj As Long,_
GetStockObject As uLong
End Function
Function CreateFont(face$,width,height,bold,italic,underline,strikeout)
'bold, italic, underline strikeout = 1 for yes, 0 for no
'width can be 0 for default width
If bold>0 Then bold=700
CallDLL #gdi32, "CreateFontA", height As Long, _
width As Long,escapement As Long,0 As Long, _
weight As Long,italic As Long, _
underline As Long,strikeout As Long, _
0 As Long,0 As Long,0 As Long,0 As Long,0 As Long, _
face$ As Ptr, CreateFont As uLong
End Function
Sub DeleteObject hObject
CallDLL #gdi32,"DeleteObject",_
hObject As uLong,r As Boolean
End Sub
Function SetFont(hControl,hFont)
calldll #user32, "SendMessageA",_
hControl as ulong,_ 'handle of control
_WM_SETFONT as word,_ 'message
hFont as ulong,_ 'new font
1 as long,_ 'repaint=1, no repaint=0
result as long 'not used
SetFont=result
End Function