Calendar Control
This PRG source code implements the "Month Calendar" Common Control. The screen shot below is created with the locale of my computer (German). It shows the "Month Calendar Control" where the first day of the week is set to Sunday. The control displays six calender sheets using custom colors (minimum is one calendar sheet, maximum is restricted by the screen size).
Calendar days for Saturdays and Sundays are displayed bold due to the GetDayState() function implemented in PRG code.
// FILE: MonthCalControl.ch // Copyright (c) Hannes Ziegler, 2008 // This file is published as Open Source for The YUKON Project (www.knowleXbase.com) #ifndef _MONTHCAL_CONTROL_CH #define _MONTHCAL_CONTROL_CH #include "YukonEVM.ch" // Constants for preparing the color array queried by the MCM_SETCOLOR callback // (the original #defines start at offset zero, so I had to use new ones) #define MC_CLR_BACKGROUND 1 // Color around the control #define MC_CLR_TEXT 2 // Text color (day numbers) #define MC_CLR_TITLEBK 3 // Title background color #define MC_CLR_TITLETEXT 4 // Title text color #define MC_CLR_MONTHBK 5 // Text background color (day numbers) #define MC_CLR_TRAILINGTEXT 6 // Text color for days of prev/next month #define MC_COLOR_ARRAY Array(6) #endif // _MONTHCAL_CONTROL_CH
// FILE: MonthCalControl.prg
// Copyright (c) Hannes Ziegler, 2008
// This file is published as Open Source for The YUKON Project (www.knowleXbase.com)
// Implementation of the MonthCalControl class
#include "MonthCalControl.ch"
CLASS MonthCalControl FROM ComCtl_MonthCal
PROTECTED:
VAR dateTime
VAR systemTimeStart
VAR systemTimeEnd
EXPORTED:
METHOD init, create, destroy
INLINE ACCESS METHOD currentDate
RETURN ::dateTime:date
INLINE ACCESS METHOD startDate
LOCAL cSave := ::dateTime:toSystemTime()
LOCAL cDate := ::systemTimeStart:str
LOCAL dDate := Ctod( "" )
IF .NOT. cDate == ZeroStr( 16 )
::dateTime:str := cDate
dDate := ::dateTime:date
::dateTime:str := cSave
ENDIF
RETURN dDate
INLINE ACCESS METHOD endDate
LOCAL cSave := ::dateTime:toSystemTime()
LOCAL cDate := ::systemTimeEnd:str
LOCAL dDate := Ctod( "" )
IF .NOT. cDate == ZeroStr( 16 )
::dateTime:str := cDate
dDate := ::dateTime:date
::dateTime:str := cSave
ENDIF
RETURN dDate
// Notifications
METHOD MCN_GetDayState
METHOD MCN_SelChange
METHOD MCN_Select
ENDCLASS
METHOD MonthCalControl:init( oParent, oOwner, aPos, aSize, aPP, lVisible )
::ComCtl_MonthCal:init( oParent, oOwner, aPos, aSize, aPP, lVisible )
::dateTime := DateTime():new()
::systemTimeStart := StructLoad( "SYSTEMTIME" )
::systemTimeEnd := StructLoad( "SYSTEMTIME" )
RETURN self
METHOD MonthCalControl:create( oParent, oOwner, aPos, aSize, aPP, lVisible )
LOCAL nMsg, xValue, i, imax, j, jmax, bBlock
LOCAL aInitVars, cBin, nLen, cSave, nGDTR := 0
::ComCtl_MonthCal:create( oParent, oOwner, aPos, aSize, aPP, lVisible )
aInitVars := ::initVars
imax := Len( aInitVars )
FOR i:=1 TO imax
nMsg := aInitVars[i,1] // message to send to the Common Control
bBlock := aInitVars[i,2] // initialization value
IF Valtype( bBlock ) == "B"
xValue := Eval( bBlock, self )
ELSE
xValue := bBlock
ENDIF
DO CASE
CASE nMsg == MCM_SETDAYSTATE
// Array of day display states must be transformed to binary
cBin := ""
AEval( xValue, {|n| cBin += U2Bin(n) } )
::sendMessage( nMsg, Len(xValue), @cBin )
CASE nMsg == MCM_SETCOLOR
// Array of color values
jmax := Len( xValue )
FOR j:=1 TO jmax
IF Valtype( xValue[j] ) == "N"
// the color index is zero-based
::sendMessage( nMsg, j-1, xValue[j] )
ENDIF
NEXT
CASE nMsg == MCM_SETFIRSTDAYOFWEEK
// Number for first day of week to display (Xpp: Sunday = 1)
xValue -= 2 // (Monday = 0, Sunday = 6)
IF xValue < 0
xValue += 7
ENDIF
::sendMessage( nMsg, 0, xValue )
CASE nMsg == MCM_SETRANGE
// First and last date of range must be transformed to SYSTEMTIME structures
cSave := ::dateTime:toSystemTime()
IF Valtype( xValue ) == "D"
xValue := { xValue, NIL }
ENDIF
FOR j:=1 TO 2
IF Valtype( xValue[j] ) == "D"
::dateTime:date := xValue[j]
IF j==1
nGDTR += 1 // GDTR_MIN
::systemTimeStart:str := ::dateTime:str
ELSE
nGDTR += 2 // GDTR_MAX
::systemTimeEnd:str := ::dateTime:str
ENDIF
ENDIF
NEXT
cBin := ::systemTimeStart:str + ::systemTimeEnd:str
::dateTime:str := cSave
::sendMessage( nMsg, nGDTR, @cBin )
CASE nMsg == MCM_SETTODAY
// Date value for today must be transformed to SYSTEMTIME structures
cSave := ::dateTime:toSystemTime()
::dateTime:date := xValue
::sendMessage( nMsg, 0, ::dateTime:ptr )
::dateTime:str := cSave
CASE nMsg == MCM_SETMAXSELCOUNT
// maximum number of days in a range can be passed as numeric
::sendMessage( nMsg, xValue, 0 )
CASE nMsg == MCM_SETCURSEL
// currently selected date must be passed as SYSTEMTIME structure
::dateTime:toSystemTime()
::dateTime:date := xValue
::sendMessage( nMsg, 0, ::dateTime:ptr )
ENDCASE
NEXT
RETURN self
METHOD MonthCalControl:destroy()
Kill::dateTime
Kill::systemTimeStart
Kill::systemTimeEnd
::ComCtl_MonthCal:destroy()
RETURN self
// This method queries and sets the day display states
// wParam: unused
// lParam: pointer to a NMDAYSTATE structure
METHOD MonthCalControl:MCN_GetDayState( wParam, lParam )
LOCAL bCallback := ::getCallback( MCN_GETDAYSTATE )
LOCAL cSave := ::dateTime:toSystemTime()
LOCAL cDayState := ""
LOCAL aDayState, dStartDate, i, imax, nPtr
::dateTime:loadFrom( lParam + 12 ) // NMDAYSTATE:stStart structure member
imax := Ptr2UShort( lParam + 28 ) // NMDAYSTATE:cDayState structure member
nPtr := Ptr2ULong ( lParam + 32 ) // NMDAYSTATE:prgDayState structure member
aDayState := AFill( Array(imax), 0 )
dStartDate := ::dateTime:date
IF Valtype( bCallback ) == "B"
aDayState := Eval( bCallback, self, dStartDate, aDayState )
ENDIF
FOR i := 1 TO imax
cDayState += U2Bin( aDayState[i] )
NEXT
imax := MemWrite( nPtr, cDayState, Len(cDayState) )
::dateTime:str := cSave
RETURN 0
// This method transfers the selected date to the :dateTime object
// wParam: unused
// lParam: pointer to a NMSELCHANGE structure
METHOD MonthCalControl:MCN_Select( wParam, lParam )
LOCAL bCallback := ::getCallback( MCN_SELECT )
LOCAL oEvent
::dateTime:toSystemTime()
::dateTime:loadFrom( lParam + 12 ) // NMSELCHANGE:stSelStart structure member
IF Valtype( bCallback ) == "B"
Eval( bCallback, self, ::dateTime:date )
ENDIF
RETURN 1
// This method transfers the first and last date of a selected range of days
// wParam: unused
// lParam: pointer to a NMSELCHANGE structure
METHOD MonthCalControl:MCN_SelChange( wParam, lParam )
LOCAL bCallback := ::getCallback( MCN_SELCHANGE )
LOCAL cSave := ::dateTime:toSystemTime()
LOCAL dFirst, dLast, oEvent
::dateTime:loadFrom( lParam + 12 ) // NMSELCHANGE:stSelStart structure member
::systemTimeStart:str := ::dateTime:str
dFirst := ::dateTime:date
::dateTime:loadFrom( lParam + 28 ) // NMSELCHANGE:stSelEnd structure member
::systemTimeEnd:str := ::dateTime:str
dLast := ::dateTime:date
::dateTime:str := cSave
IF Valtype( bCallback ) == "B"
Eval( bCallback, self, dFirst, dLast )
ENDIF
RETURN 0
// FILE: TestCalendar.prg
// Copyright (c) Hannes Ziegler, 2008
// This file is published as Open Source for The YUKON Project (www.knowleXbase.com)
#include "MonthCalCOntrol.ch"
#include "AppEvent.ch"
#include "Font.ch"
#include "Xbp.ch"
#include "Gra.ch"
#include "Dll.ch"
PROCEDURE Main
LOCAL oDlg := GuiStdDialog( "Test for MonthCalControl" )
LOCAL oWin, oCtrl, oStatic, oSle1, oSle2
LOCAL nEvent, mp1, mp2, oXbp
LOCAL dFirstDay := Stod( "20070101" )
LOCAL dLastDay := Stod( "20091231" )
LOCAL dCurrentDay := Stod( "20080113" )
LOCAL dToday := Stod( "20080125" )
LOCAL aDayState := GetDayState( dCurrentDay )
LOCAL aColors := MC_COLOR_ARRAY
LOCAL aRange := { dFirstDay, dLastDay }
aColors[ MC_CLR_BACKGROUND ] := GetColorRef( "LightGray" )
aColors[ MC_CLR_MONTHBK ] := GetColorRef( "GhostWhite" )
aColors[ MC_CLR_TITLEBK ] := GetColorRef( "SlateGray" )
oCtrl := MonthCalControl():new( oDlg:drawingArea,, {30,30}, { 600,400 } )
// Set control styles
oCtrl:windowStyle += MCS_WEEKNUMBERS + MCS_DAYSTATE // + MCS_MULTISELECT
// Set initialization values
oCtrl:initVars := { ;
{ MCM_SETFIRSTDAYOFWEEK , 1 }, ; // start with Sunday
{ MCM_SETCURSEL , Stod( "20080113" ) }, ; // current selection
{ MCM_SETCOLOR , aColors }, ; // colors
{ MCM_SETTODAY , Date() } ; // today's date
}
// useful when the MCS_MULTISELECT style is set
// { MCM_SETRANGE , aRange }, ;
// { MCM_SETMAXSELCOUNT , 5 }, ;
// Notification callback code blocks
oCtrl:setCallback( MCN_GETDAYSTATE , {|obj,dDate,aState| GetDayState( dDate, aState ) } )
oCtrl:setCallback( MCN_SELECT , {|obj,dDate| QOut(dDate) } )
oCtrl:setCallback( MCN_SELCHANGE , {|obj,dFirst,dLast| QOut(dFirst,dLast) } )
oCtrl:create()
/*
// This adjusts the size of the MonthCalControl to the required minimum
oRect := StructLoad( "RECT" )
oCtrl:sendMessage( MCM_GETMINREQRECT, 0, oRect )
oCtrl:setSize( {oRect:right, oRect:bottom} )
oRect:destroy()
*/
DO WHILE nEvent <> xbeP_Close
nEvent := AppEventEx( @mp1, @mp2, @oXbp )
IF oXbp <> NIL
IF nEvent == xbeP_Keyboard
EXIT
ENDIF
oXbp:handleEvent( nEvent, mp1, mp2 )
ENDIF
ENDDO
RETURN
// This function is called in response to the MCN_GETDAYSTATE notification
// via the :MCN_GetDayState method of a MonthCalControl object.
// It identifies the days that should be displayed bold in the calendar control.
// This implementation sets the bits for Saturdays and Sundays
FUNCTION GetDayState( dStartDate, aDayState )
LOCAL i, imax, j, jmax, nDay, nDayState, nMonth
IF Valtype( aDayState ) <> "A"
aDayState := Array(12)
ENDIF
imax := Len( aDayState )
nMonth := Month( dStartDate )
FOR i:=1 TO imax
nDayState := 0
FOR j:=1 TO 31
// day 0 == Monday, day 6 == Sunday
nDay := DoW( dStartDate ) - 2
IF nDay < 0
nDay += 7
ENDIF
// set bits for Saturday and Sunday
IF nDay > 4
nDayState[j] := .T.
ENDIF
dStartDate ++
IF Month( dStartDate ) <> nMonth
EXIT
ENDIF
NEXT
aDayState[i] := nDayState
nMonth := Month( dStartDate )
NEXT
RETURN aDayState
FUNCTION GuiStdDialog( cTitle )
LOCAL oDlg
LOCAL aSize := { 700,500 }
LOCAL aPos := { 0, Appdesktop():currentSize()[2] - aSize[2] }
oDlg := XbpDialog():new( AppDeskTop() ,,aPos, aSize, {{XBP_PP_FGCLR, GRA_CLR_WHITE} , ;
{XBP_PP_BGCLR, GRA_CLR_WHITE} ;
}, .T. )
oDlg:icon := 1
oDlg:taskList := .T.
oDlg:title := cTitle
oDlg:ClipChildren := .T.
oDlg:drawingArea:ClipChildren := .T.
oDlg:create()
oDlg:drawingArea:setFontCompoundName( FONT_DEFPROP_MEDIUM )
RETURN oDlg