Announcement

**Dominic Mitchell** · 13 Jun 2006, 09:14 AM

Looks nice, but it is a GDI hog at 96 GDI objects on startup.
You have a serious resource leak. Everytime the IDC_GO_BN button (">") is clicked,
an additional 84 GDI objects are created and never freed. XP more or less gave up at
10000 objects.

Yikes! Wrong forum.

[This message has been edited by Dominic Mitchell (edited June 13, 2006).]

**Chris Holbrook** · 13 Jun 2006, 05:40 PM

[QUOTE]Originally posted by Dominic Mitchell:
Looks nice, but it is a GDI hog

The bug mentioned by Dominic is fixed by update to the above code.
Now uses only 15 GDI objects, no known leaks - try it and find one!

------------------

**Chris Holbrook** · 22 Apr 2016, 12:20 PM

Needing something like this, I made it work with PBWin 10.04, but didn't use it, shame to waste the effort (twenty minutes!).
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

Announcement

Forum Guidelines

month-at-a-view calendar, click on days

month-at-a-view calendar, click on days

Comment

Comment

Comment