So here is the PBWin 10 version. It is what it is, etc.
Code:
'-----------------------------------------------------------------------------
' Calendar with clickable days
' written 13-6-2006 Chris Holbrook for public use
' not properly tested
' only restriction - if you use it, take my name off!
' using PBWin 8.01 & PBForms 1.51
'
' to run, enter the month (at least 1st 3 digits of english month name)
' and year at the top left and click the button next.
' Clicking each day toggles the background colour.
' terminate with Alt-F4
' drag with left mouse button down (not on a day).
'
' implementation:
' - each cell in the calendar is a cell in a static control array.
' - there is a corresponding array g_calday() of cell attributes
' - the controls are all subclassed to the same function, but can
' - have different OnClick functions.
'
' changes:
' 13-6-2006 fixed GDI object leak in SubclassStaticProc
' 22-4-2016 this version compiles with PBWin 10
'------------------------------------------------------------------------------
#compile exe
#dim all
#include "WIN32API.INC"
'
%IDD_caldlg = 101
%IDC_LABEL1 = 1001
%IDC_LABEL2 = 1002
%IDC_LABEL3 = 1003
%IDC_LABEL4 = 1004
%IDC_LABEL5 = 1005
%IDC_LABEL6 = 1006
%IDC_LABEL7 = 1007
%IDC_month_tb = 1091
%IDC_GO_BN = 1092
%IDC_MONTH_LAB = 1093
%IDC_YEAR_LAB = 1094
'------------------------------------------------------------------------------
type daycontrol
hW as long ' window handle
r as rect ' rect structure for client area of window
Ctl as long ' control number
SubClassProc as dword ' current subclassproc
OldSubClassProc as dword ' previous subclassproc
ClickFn as dword ' codeptr to function to call when single click detectedend type
hD as dword ' dialog handle
colour as dword ' background colour of control
ztext as asciz * 3 ' text value (1..31)
end type
declare function OnClickFnPrototype ( n as long) as long
global g_calday() as daycontrol
'------------------------------------------------------------------------------
' subclassed stuff
'----------------------------------------------------------------------------
' this function takes care of messages for the subclassed control
'
function SubClassStaticProc(byval hWnd as dword, byval wMsg as long, _
byval wParam as long, byval lParam as long) as long
static hDC, i as long
select case wMsg
case %wm_paint
for i = 1 to ubound(g_calday)
if g_calday(i).hW = hWnd then
exit for
end if
next
' don't need a DC, BeginPaint does it! hDC = GetDC(hWnd)
call PaintW(i, 0)
function = 0
exit function
case %WM_ERASEBKGND
for i = 1 to ubound(g_calday)
if g_calday(i).hW = hWnd then
exit for
end if
next
call paintW(i, hDC)
releasedc hWnd, hDC
function = 1
exit function
case %wm_lbuttondown
for i = 1 to ubound(g_calday)
if g_calday(i).hW = hWnd then
exit for
end if
next
if g_calday(i).ClickFn <> %NULL then ' call click fn only if one was set up
call dword g_calday(i).Clickfn using OnClickFnPrototype (i)
end if
function = 1
exit function
'A Label control by default returns HTTRANSPARENT when it receives the WM_NCHITTEST
'message. As a result, mouse messages are passed directly to the window underneath the
'label control. To receive mouse messages for the label control, add the following
'code to the subclass procedure for the label control. ~ DOMINIC MITCHELL
case %wm_nchittest
function = %HTCLIENT
exit function
end select
' Pass the message on to the original window procedure... the DDT engine!
function = CallWindowProc(g_calday(i).OldSubClassProc, hWnd, wMsg, wParam, lParam)
end function '-----------------------------------------------------------------------------
' 1st param is the subscript to g_imgr table for current static image control
' 2nd is DC is called for a WM_ERASEBKGND message, zero for a WM_PAINT message
'
sub PaintW(I as long, hDCin as long)
local ps as PAINTSTRUCT
'LOCAL r AS RECT
local hdc, hG as dword
local result, tx, ty, framex, framey, ofsx, ofsy as long
local high as single
local tlb as LOGBRUSH ' specifies information used to create background
local hbrush as dword
local oldBk as integer
if hDCin = 0 then
hDC = BeginPaint(g_calday(I).hW, ps)
else
hDC = hDCin
end if
tlb.lbStyle = %BS_SOLID
tlb.lbColor = g_calday(I).colour
tlb.lbHatch = 0
hBrush = CreateBrushIndirect(tlb)
FillRect hdc, g_calday(I).r, hBrush
DeleteObject hBrush
oldBk = SetBkMode(hdc, %TRANSPARENT)
DrawTextEx hdc,g_calday(I).ztext, len(g_calday(I).ztext), g_calday(I).r, %DT_SINGLELINE or %DT_LEFT or %DT_VCENTER or %DT_END_ELLIPSIS, byval %NULL
SetBkMode hdc, OldBk
' if DC was passed in, let caller release it!
if hDCin = 0 then EndPaint(g_calday(I).hW, ps)
end sub
'------------------------------------------------------------------------------
' ** Main Application Entry Point **
'------------------------------------------------------------------------------
function pbmain()
Showcaldlg %hwnd_desktop
end function
'------------------------------------------------------------------------------
function dayof1st ( year as long, month as long) as long
local st as systemtime, ft as filetime
' find which day of the week starts June 2006:
st.wMonth = month
st.wYear = year
st.wDay = 1
SystemTimeToFileTime st, ft
FileTimeToSystemTime ft, st
function = St.wDayofWeek '( 0=Sun, 1 = Mon,...)
end function
'---------------------------------------------------------
function daysinmonth ( year as long, month as long) as long
select case month
case 9,4,6,11
function = 30
case 2
function = 28
if year mod 1000 = 0 then
function = 28
else
if year\4 = year/4 then function = 29
end if
case else
function = 31
end select
end function
'-----------------------------------------------------------------------------
function month_number ( s as string) as long
local m as string
local p as long
local month as long
m = ".JAN.FEB.MAR.APR.MAY.JUN.JUL.AUG.SEP.OCT.NOV.DEC."
p = instr(m, "." + ucase$(left$(s,3)) + ".")
if p = 0 then exit function
month = (p \ 4)+ 1
function = month
end function
'-------------------------------------------------------------------
' declared to conform with OnClickFnPrototype
function Beepfn ( i as long) as long
beep
end function
'-------------------------------------------------------------------
' declared to conform with OnClickFnPrototype
function toggledaycolour ( i as long ) as long
if trim$(g_calday(i).ztext) = "" then exit function
if g_calday(i).colour = %ltgray then
g_calday(i).colour = rgb(147, 201, 227)
else
g_calday(i).colour = %ltgray
end if
invalidaterect(g_calday(i).hW,g_calday(i).r,%false)
end function
'------------------------------------------------------------------------------
' ** CallBacks **
'------------------------------------------------------------------------------
callback function ShowcaldlgProc()
static i, j, start as long
static year as long
static month as long
static s as string
local lastday, offset1st as long
select case as long cbmsg
case %wm_initdialog
' Initialization handler
control set text cbhndl, %idc_month_tb , "JUNE 2006"
month = 6
year = 2006
offset1st = dayof1st(year, month)
dim g_calday(42)
for i = 1008 to 1049
j = i - 1007
g_calday(j).Ctl = i
control handle cbhndl, i to g_calday(j).hW
getClientRect (g_calday(j).hW, g_calday(j).r)
g_calday(j).ClickFn = codeptr(BeepFn)
g_calday(j).hD = cbhndl
g_calday(j).colour = rgb(147, 201, 227)
' clear day numbers
g_calday(j).ztext = ""
g_calday(j).OldSubClassProc = SetWindowLong(g_calday(j).hW, %GWL_WNDPROC, codeptr(SubClassStaticProc))
next
case %wm_ncactivate
static hWndSaveFocus as dword
if isfalse cbwparam then
' Save control focus
hWndSaveFocus = GetFocus()
elseif hWndSaveFocus then
' Restore control focus
SetFocus(hWndSaveFocus)
hWndSaveFocus = 0
end if
case %wm_lbuttondown
SendMessage cbhndl, %wm_nclbuttondown, %HTCAPTION, byval %NULL ' force drag
case %wm_command
' Process control notifications
select case as long cbctl
case %IDC_go_bn
' extract month & year from text box
control get text cbhndl, %idc_month_tb to s
month = month_number(parse$(s," ",1))
if month = 0 then
beep
year = 2006: month = 6
exit select
end if
year = val(parse$(s," ",2))
if year < 1900 then
beep
year = 2006: month = 6
exit select
end if
offset1st = dayof1st(year, month)
for i = 1008 to 1049
j = i - 1007
g_calday(j).ztext = ""
' set up text to equal string of day number
if (j > offset1st) and ((j - offset1st) <= daysinmonth(year, month)) then
g_calday(j).ztext = trim$(str$(j - offset1st ))
g_calday(j).ClickFn = codeptr(ToggleDayColour)
end if
next
dialog redraw cbhndl
end select
case %wm_destroy
for i = 1008 to 1049
j = i - 1007
SetWindowLong g_calday(j).hW, %GWL_WNDPROC, g_calday(j).OldSubClassProc
next
end select
end function
'------------------------------------------------------------------------------
' ** Dialogs **
'------------------------------------------------------------------------------
function Showcaldlg(byval hParent as dword) as long
local lRslt as long
local col, i, row, x, y as long
local hDlg as dword
dialog new hParent, "", 71, 71, 140,80,%ws_popup or %ws_thickframe or _
%ws_clipsiblings or %ws_visible or %ds_3dlook or %ds_nofailcreate or _
%ds_setfont, %ws_ex_controlparent or %ws_ex_toolwindow or _
%ws_ex_topmost or %ws_ex_left or %ws_ex_ltrreading or _
%ws_ex_rightscrollbar, to hDlg
control add label, hDlg, %IDC_LABEL1, "Sun", 0, 10, 20, 10, %ws_child or _
%ws_visible or %ss_center or %ss_centerimage, %ws_ex_left or _
%ws_ex_ltrreading
control set color hDlg, %IDC_LABEL1, -1, rgb(79, 169, 217)
control add label, hDlg, %IDC_LABEL2, "Mon", 20, 10, 20, 10, %ws_child or _
%ws_visible or %ss_center or %ss_centerimage, %ws_ex_left or _
%ws_ex_ltrreading
control set color hDlg, %IDC_LABEL2, -1, rgb(79, 169, 217)
control add label, hDlg, %IDC_LABEL3, "Tues", 40, 10, 20, 10, %ws_child or _
%ws_visible or %ss_center or %ss_centerimage, %ws_ex_left or _
%ws_ex_ltrreading
control set color hDlg, %IDC_LABEL3, -1, rgb(79, 169, 217)
control add label, hDlg, %IDC_LABEL4, "Wed", 60, 10, 20, 10, %ws_child or _
%ws_visible or %ss_center or %ss_centerimage, %ws_ex_left or _
%ws_ex_ltrreading
control set color hDlg, %IDC_LABEL4, -1, rgb(79, 169, 217)
control add label, hDlg, %IDC_LABEL5, "Thu", 80, 10, 20, 10, %ws_child or _
%ws_visible or %ss_center or %ss_centerimage, %ws_ex_left or _
%ws_ex_ltrreading
control set color hDlg, %IDC_LABEL5, -1, rgb(79, 169, 217)
control add label, hDlg, %IDC_LABEL6, "Fri", 100, 10, 20, 10, %ws_child or _
%ws_visible or %ss_center or %ss_centerimage, %ws_ex_left or _
%ws_ex_ltrreading
control set color hDlg, %IDC_LABEL6, -1, rgb(79, 169, 217)
control add label, hDlg, %IDC_LABEL7, "Sat", 120, 10, 20, 10, %ws_child or _
%ws_visible or %ss_center or %ss_centerimage, %ws_ex_left or _
%ws_ex_ltrreading
control set color hDlg, %IDC_LABEL7, -1, rgb(79, 169, 217)
control add textbox, hDlg, %IDC_month_tb, "", 0, 0, 54, 10, %ws_child or _
%ws_visible or %ws_ex_left or %ws_ex_ltrreading or %es_uppercase
control set color hDlg, %IDC_month_tb, -1, rgb(147, 201, 227)
control add button, hDlg, %IDC_go_bn, ">", 55, 0,10,10
for i = 1008 to 1049
col = (i - 1001) mod 7 : x = col * 20
row = (i-1001) \ 7: y = 10 + (row * 10)
control add label, hDlg, i, "", x, y, 20, 10, %ws_child or _
%ws_visible or %ss_center or %ss_centerimage, %ws_ex_left or _
%ws_ex_ltrreading or %ws_ex_staticedge
control set color hDlg, i, -1, rgb(147, 201, 227)
next
dialog show modal hDlg, call ShowcaldlgProc to lRslt
function = lRslt
end function
Leave a comment: