Any suggestion on how to start to achieve this?
It is meant to allow user to visually select a date range, right click on the selection and select the shift number the staff is assigned to.
TIA
How to achieve this kind of calendar control?
How to achieve this kind of calendar control?
Hi guys,
Any suggestion on how to start to achieve this?
It is meant to allow user to visually select a date range, right click on the selection and select the shift number the staff is assigned to.
TIA
Any suggestion on how to start to achieve this?
It is meant to allow user to visually select a date range, right click on the selection and select the shift number the staff is assigned to.
TIA
FWH 11.08/FWH 19.03
xHarbour 1.2.1 (Rev 6406) + BCC
Harbour 3.1 (Rev 17062) + BCC
Harbour 3.2.0dev (r1904111533) + BCC
xHarbour 1.2.1 (Rev 6406) + BCC
Harbour 3.1 (Rev 17062) + BCC
Harbour 3.2.0dev (r1904111533) + BCC
Re: How to achieve this kind of calendar control?
Hello Hua,
when I saw your calendar a class we made years ago came into my mind.
This is not what you are looking for but maybe someone is interested in.
Source code is attached.
Best regards,
Otto
when I saw your calendar a class we made years ago came into my mind.
This is not what you are looking for but maybe someone is interested in.
Source code is attached.
Best regards,
Otto
Code: Select all
#include "FiveWin.ch"
#include "xbrowse.ch"
#define REVD
REQUEST DBFCDX
FIELD SEASONID
//----------------------------------------------------------------------------//
static cSeasonsMaster := "SEASONS.DBF"
static cSeasonMarkDBF := "SEASNMRK.DBF"
//----------------------------------------------------------------------------//
function Main()
local oWnd, oPickDate, cFilt
if ! File( cSeasonsMaster )
CreateSeasonsMaster( cSeasonsMaster )
endif
if ! File( cSeasonMarkDBF )
CreateSeasonMarkDBF()
endif
USE (cSeasonsMaster) NEW ALIAS "SEASONS" EXCLUSIVE
SET ORDER TO TAG SEASONID
GO TOP
USE (cSeasonMarkDBF) NEW ALIAS "MARK" EXCLUSIV
DEFINE WINDOW oWnd TITLE "Calendar"
oPickDate := TPickDate():New( 10, 10,,, oWnd )
/*
WITH OBJECT oPickDate
:nHeaderHeight := 40
:aGrad := nil
:nClrHeader := CLR_HGREEN
:nClrSelect := CLR_BLUE
END
*/
SEASONS->( FillSeasonColors( oPickDate ) )
MARK-> ( MarkSeasonsFromDBF( oPickdate ) )
oPickDate:bSelect := { | dStart, dEnd | SeasonDialog( oPickDate, dStart, dEnd ) }
oPickDate:bClickOnSeason := { | o, dDate, nID | MARK->( OnClickSeason( o, dDate, nID ) ) }
oWnd:oClient = oPickDate
ACTIVATE WINDOW oWnd MAXIMIZED
return nil
//----------------------------------------------------------------------------//
init procedure PrgInit
SET DATE FRENCH
SET CENTURY ON
SET TIME FORMAT TO "HH:MM:SS"
SET EPOCH TO YEAR(DATE())-50
SET DELETED ON
SET EXCLUSIVE OFF
RDDSETDEFAULT( "DBFCDX" )
XbrNumFormat( 'A', .t. )
SetKinetic( .f. )
SetGetColorFocus()
return
//----------------------------------------------------------------------------//
static function OnRightClick( oPick, r, c )
local dDate, nDay, nSeasonID, n, dFrom, dUpto
dDate := oPick:Pixel2Date( r, c )
nDay := oPick:DateSerial( dDate )
nSeasonID := oPick:aDays[ nDay ]
if nSeasonID == 0
MsgInfo( DToC( dDate ) + " Available" )
else
if MsgNoYes( "Season " + LTrim( Str( nSeasonID ) ) + CRLF + ;
"Unmark Season ? (Y/N)" )
endif
endif
return nil
//----------------------------------------------------------------------------//
static function FillSeasonColors( oPick )
GO TOP
DBEVAL( { || oPick:SeasonColor( FIELD->SEASONID, FIELD->SNCOLOR ) } )
GO TOP
return nil
//----------------------------------------------------------------------------//
static function MarkSeason( oPick, nID, dFrom, dUpto )
oPick:MarkSeason( nID, dFrom, dUpto )
CursorWait()
MARK->( DBAPPEND() )
MARK->SEASONID := nID
MARK->FROMDATE := dFrom
MARK->TILLDATE := dUpto
DBCOMMIT()
CursorArrow()
return nil
//----------------------------------------------------------------------------//
static function OnClickSeason( oPick, dDate, nSeasonID )
FIELD SEASONID, FROMDATE, TILLDATE
local cMsg, cCond
SEASONS->( DBSEEK( nSeasonID ) )
cMsg := "Clear " + TRIM( SEASONS->SNNAME ) + "? (Y/N)"
if MsgNoYes( cMsg )
oPick:ClearSeason( dDate )
CursorWait()
DBGOTOP()
LOCATE FOR SEASONID = nSeasonID .AND. dDate >= FROMDATE .and. dDate <= TILLDATE
if FOUND()
DBDELETE()
endif
DBGOTOP()
CursorArrow()
endif
return nil
//----------------------------------------------------------------------------//
static function MarkSeasonsFromDBF( oPick )
MARK->( DBGOTOP() )
DO WHILE ! MARK->( eof() )
oPick:MarkSeason( MARK->SEASONID, MARK->FROMDATE, MARK->TILLDATE )
MARK->( DBSKIP( 1 ) )
ENDDO
MARK->( DBGOTOP() )
return nil
//----------------------------------------------------------------------------//
static function SeasonDialog( oPick, dFrom, dUpto )
local oDlg, oBrw, oFont, nRow, nClr, nID
local nSelect := 0
SEASONS->( DBGOTOP() )
DEFINE FONT oFont NAME "Segoe UI" SIZE 0,-16
DEFINE DIALOG oDlg SIZE 300,400 PIXEL FONT oFont ;
TITLE "Select Season to Mark"
@ 10,10 XBROWSE oBrw SIZE -10,-60 PIXEL OF oDlg ;
COLUMNS "SNCOLOR", "SNNAME" ;
HEADERS "Clr", "Season" ;
ALIAS "SEASONS" CELL LINES NOBORDER
WITH OBJECT oBrw:Clr
:bEditValue := { || "" }
:bClrStd := { || { SEASONS->SNCOLOR, SEASONS->SNCOLOR } }
:bClrSelFocus := :bClrSel := :bClrStd
:bLDClickData := { || SEASONS->SNCOLOR := ChooseColor( SEASONS->SNCOLOR ), ;
oPick:SeasonColor( SEASONS->SEASONID, SEASONS->SNCOLOR ) }
END
WITH OBJECT oBrw
WITH OBJECT :Season
:nEditType := EDIT_GET
:bClrSel := ;
:bClrSelFocus := { || { CLR_WHITE, CLR_GREEN } }
END
:nStretchCol := 2
:lColDividerComplete := .f.
:lHeader := .f.
// :nColorPen := CLR_YELLOW
:nMarqueeStyle := MARQSTYLE_HIGHLROW
:lVScroll := .f.
:lHScroll := .f.
:lRecordSelector := .f.
END
oBrw:CreateFromCode()
nRow := 148 //+ 16
@ nRow, 10 BUTTON "Add New Season" SIZE 130, 14 PIXEL OF oDlg ;
ACTION ( nClr := ChooseColor( CLR_WHITE ), ;
If( nClr != CLR_WHITE, SEASONS->( ;
DBGOBOTTOM(), nID := FIELD->SEASONID - RECNO(), ;
SEASONS->(DBAPPEND()), ;
SEASONS->SEASONID := RECNO() + nID, ;
SEASONS->SNCOLOR := nClr, ;
SEASONS->SNNAME := "Season-" + LTrim( Str(SEASONS->SEASONID) ), ;
If( oPick == nil, nil, oPick:SeasonColor( SEASONS->SEASONID, nClr ) ), ;
oBrw:Refresh(), oBrw:SetFocus() ;
), nil ) )
// @ nRow, 77 BUTTON "Delete Season" SIZE 63, 14 PIXEL OF oDlg
nRow += ATail( oDlg:aControls ):nHeight + 2
@ nRow, 10 BUTTON "Mark Season" SIZE 130, 14 PIXEL OF oDlg ;
ACTION ( nSelect := SEASONS->SEASONID, oDlg:End() )
nRow += ATail( oDlg:aControls ):nHeight + 2
@ nRow, 10 BUTTON "Cancel" SIZE 130, 14 PIXEL OF oDlg ACTION oDlg:End()
ACTIVATE DIALOG oDlg CENTERED ;
ON PAINT oDlg:Box( oBrw:nTop - 1, oBrw:nLeft - 1, oBrw:nBottom, oBrw:nRight )
RELEASE FONT oFont
if nSelect > 0
MarkSeason( oPick, nSelect, dFrom, dUpto )
endif
return nil
//----------------------------------------------------------------------------//
static function CreateSeasonsMaster()
local aColors := { CLR_CYAN, CLR_YELLOW, CLR_HRED, CLR_HGREEN }
local n
local aCols := { ;
{ "SEASONID", 'N', 2, 0 }, ;
{ "SNCOLOR", 'N', 8, 0 }, ;
{ "SNNAME", 'C', 20, 0 } }
DBCREATE( cSeasonsMaster, aCols )
USE (cSeasonsMaster) NEW ALIAS "SEASONS" EXCLUSIVE
for n := 1 to Len( aColors )
APPEND BLANK
FIELD->SEASONID := n
FIELD->SNCOLOR := aColors[ n ]
FIELD->SNNAME := "Season-" + Str( n, 1 )
next n
INDEX ON SEASONID TAG SEASONID
USE
return nil
//----------------------------------------------------------------------------//
static function CreateSeasonMarkDBF()
local aCols := { ;
{ "SEASONID", 'N', 2, 0 }, ;
{ "FROMDATE", 'D', 8, 0 }, ;
{ "TILLDATE", 'D', 8, 0 } }
DBCREATE( cSeasonMarkDBF, aCols )
return nil
//----------------------------------------------------------------------------//
//
// CLASS DEFINITIONS BEGIN
//
//----------------------------------------------------------------------------//
#define DT_TOP 0x00000000
#define DT_LEFT 0x00000000
#define DT_CENTER 0x00000001
#define DT_RIGHT 0x00000002
#define DT_VCENTER 0x00000004
#define DT_BOTTOM 0x00000008
#define DT_WORDBREAK 0x00000010
#define DT_SINGLELINE 0x00000020
#define SM_CYVSCROLL 20
#define SM_CYHSCROLL 3
#define MK_MBUTTON 0x0010
//----------------------------------------------------------------------------//
CLASS TPickDate FROM TControl
CLASSDATA lRegistered AS LOGICAL
DATA dStart, dEnd, dTemp
DATA lSelecting INIT .f.
DATA lPressed INIT .f.
DATA nYear INIT Year( Date() )
DATA dFirst, dLast
DATA nFirstMth INIT 1 //Month( Date() )
DATA aDays
DATA aCal
DATA aSeasonClrs INIT Array( 0 )
DATA nTopMonth INIT 1
DATA nFirstCol INIT 1
DATA nClrSunday INIT RGB( 183, 249, 185 ) // Greenish
DATA nClrSelect INIT RGB( 240, 232, 188 )
DATA oFontHeader, oFontYear
DATA nMonthWidth INIT 150
DATA nHeaderHeight INIT 60
DATA bSelect
DATA bClickOnSeason
DATA aGrad INIT { { 1, nRGB( 128, 217, 255 ), nRGB( 54, 147, 255 ) } }
DATA nClrHeader INIT { { 1, nRGB( 128, 217, 255 ), nRGB( 54, 147, 255 ) } }
DATA nRowHeight
DATA nCellWidth
DATA nVisiRows, nVisiCols
DATA oVScroll, oHScroll
METHOD New( nTop, nLeft, nWidth, nHeight, oWnd, nYear, nClrFore, nClrBack )
METHOD Redefine( nId, oWnd )
METHOD CalcSizes()
METHOD SetStartMonth()
METHOD Paint()
METHOD PaintHeader()
METHOD PaintYear( nYear, nTop, nBottom )
METHOD PaintDays()
METHOD Display() INLINE ::BeginPaint(), ::Paint(), ::EndPaint(), 0
METHOD EraseBkGnd( hDC ) INLINE 0
METHOD Destroy()
//
METHOD LButtonDown( nRow, nCol, nKeyFlags )
METHOD LButtonUp( nRow, nCol, nKeyFlags )
METHOD MouseMove( nRow, nCol, nKeyFlags )
METHOD StartSelect()
METHOD EndSelect()
METHOD CancelSelect()
//
METHOD Pixel2Date( nRow, nCol )
METHOD Available( dFrom, dUpto )
METHOD DateSerial( dDate ) INLINE If( Empty( dDate ), 0, dDate - ::dFirst + 1 )
METHOD Serial2Date( nSerial ) INLINE ( ::dFirst + nSerial - 1 )
METHOD DateStatus( dDate ) INLINE If( Empty( dDate ), 0, ::aDays[ ::DateSerial( dDate ) ] )
METHOD SeasonColor( nSeasonID, nColor )
METHOD MarkSeason( nSeasonID, dFrom, dUpto, nColor )
METHOD ClearSeason( dDate )
//
METHOD GoTop() INLINE ( If( ::nTopMonth > 1, ( ::nTopMonth := 1, ::Refresh() ), nil ), ::VSetPos() )
METHOD GoBottom() INLINE If( ::nVisiRows < 24, ( ::nTopMonth := 25 - ::nVisiRows, ::Refresh(), ::VSetPos() ), nil )
METHOD GoUp() INLINE If( ::nTopMonth > 1, ( ::nTopMonth--, ::Refresh(), ::vSetPos() ), nil )
METHOD GoDown() INLINE If( ::nTopMonth < 25 - ::nVisiRows, ( ::nTopMonth++, ::Refresh(), ::VSetPos() ), nil )
METHOD GoToPos( n ) INLINE ( ::nTopMonth := Max( 1, Min( n, 25 - ::nVisiRows ) ), ::Refresh(), ::vSetPos() )
METHOD VSetPos() INLINE ( ::oVScroll:SetPos( ::nTopMonth ) )
METHOD VScroll( nWParam, nLParam )
//
METHOD GoLeftMost() INLINE If( ::nFirstCol > 1, ( ::nFirstCol := 1, ::Refresh(), nil ), ::HSetPos() )
METHOD GoRightMost() INLINE If( ::nVisiCols < 38, ( ::nFirstCol := 39 - ::nVisiCols, ::Refresh(), ::HSetPos() ), nil )
METHOD GoLeft() INLINE If( ::nFirstCol > 1, ( ::nFirstCol--, ::Refresh(), ::HSetPos() ), nil )
METHOD GoRight() INLINE If( ::nFirstCol < 39 - ::nVisiCols, ( ::nFirstCol++, ::Refresh(), ::HSetPos() ), nil )
METHOD GoToCol(n) INLINE ( ::nFirstCol := Max( 1, Min( n, 39 - ::nVisiCols ) ), ::Refresh(), ::HSetPos() )
METHOD HSetPos() INLINE ( ::oHScroll:SetPos( ::nFirstCol ) )
METHOD HScroll( nWParam, nLParam )
//
METHOD MouseWheel( nKeys, nDelta, nXPos, nYPos )
//
ENDCLASS
//----------------------------------------------------------------------------//
METHOD New( nTop, nLeft, nWidth, nHeight, oWnd, nYear, nClrFore, nClrBack ) CLASS TPickDate
DEFAULT nWidth := 800,;
nHeight := 300,;
nLeft := 0,;
nTop := 0,;
nYear := Year( Date() ),;
oWnd := GetWndDefault()
::lSelecting = .F.
::nTop = nTop
::nLeft = nLeft
::nBottom = nTop + nHeight - 1
::nRight = nLeft + nWidth - 1
::nYear = Year( Date() )
::oWnd = oWnd
::SetStartMonth( Date() )
::dStart := ::dEnd := ::dTemp := Date()
::nClrText = nClrFore
::nClrPane = nClrBack
::nStyle = nOr( WS_CHILD, WS_VISIBLE, WS_TABSTOP, WS_BORDER, WS_VSCROLL, WS_HSCROLL )
DEFINE FONT ::oFont NAME "Tahoma" SIZE 0, -12 BOLD
DEFINE FONT ::oFontHeader NAME "Tahoma" SIZE 0, -12
DEFINE FONT ::oFontYear NAME "TAHOMA" SIZE 0, -16 BOLD NESCAPEMENT 900
DEFINE SCROLLBAR ::oVScroll VERTICAL OF Self
DEFINE SCROLLBAR ::oHScroll HORIZONTAL OF Self
::bLostFocus := { || If( ::lSelecting, ::CancelSelect(), nil ) }
#ifdef __XPP__
DEFAULT ::lRegistered := .F.
#endif
::Register()
if ! Empty( oWnd:hWnd )
::Create()
oWnd:AddControl( Self )
else
oWnd:DefControl( Self )
endif
return self
//----------------------------------------------------------------------------//
METHOD Redefine( nId, oWnd ) CLASS TPickDate
DEFAULT oWnd := GetWndDefault()
::nId = nId
::oWnd = oWnd
::lSelecting = .F.
::dStart := ::dEnd := ::dTemp := Date()
::nYear = Year( Date() )
DEFINE FONT ::oFont NAME "Tahoma" SIZE 0, -12 BOLD
DEFINE FONT ::oFontHeader NAME "Tahoma" SIZE 0, -12
DEFINE FONT ::oFontYear NAME "TAHOMA" SIZE 0, -16 BOLD NESCAPEMENT 900
::SetColor( 0, 0 )
::Register()
oWnd:DefControl( Self )
return Self
//----------------------------------------------------------------------------//
METHOD SetStartMonth( dDate ) CLASS TPickDate
local nMonth, nCol
local dNull := CTOD( '' )
local dEOM, dStart
DEFAULT dDate := Date()
dStart := ;
dDate := BOM( dDate )
::aCal := Array( 24, 39 )
for nMonth := 1 to 24
AFill( ::aCal[ nMonth ], dNull )
::aCal[ nMonth ][ 1 ] := dDate
dEOM := EOM( dDate )
nCol := DOW( dDate ) + 1
for dDate := dDate to dEOM
::aCal[ nMonth ][ nCol ] := dDate
nCol++
next dDate
next nMonth
::aDays := Array( dDate - dStart )
::dFirst := dStart
::dLast := dDate - 1
AFill( ::aDays, 0 )
return Self
//----------------------------------------------------------------------------//
METHOD CalcSizes() CLASS TPickDate
local oRect := ::GetCliRect()
local nRows, nCols, nHeight, nWidth
nHeight := oRect:nHeight - ::nHeaderHeight
nWidth := oRect:nWidth - ::nMonthWidth
::nRowHeight := Max( 20, Int( nHeight / 24 ) )
::nCellWidth := Max( 20, Int( nWidth / 38 ) )
nRows := Int( nHeight / ::nRowHeight )
nCols := Int( nWidth / ::nCellwidth )
if nRows != ::nVisiRows
::nVisiRows := nRows
nRows := Max( 1, 25 - ::nVisiRows )
::oVScroll:SetRange( 1, nRows )
if ::nTopMonth > nRows
::nTopMonth := nRows
endif
::oVScroll:SetPos( ::nTopMonth )
endif
if nCols != ::nVisiCols
::nVisiCols := nCols
nCols := Max( 1, 39 - ::nVisiCols )
::oHScroll:SetRange( 1, nCols )
if ::nFirstCol > nCols
::nFirstCol := nCols
endif
::oHScroll:SetPos( ::nFirstCol )
endif
return Self
//----------------------------------------------------------------------------//
METHOD Paint() CLASS TPickDate
local aInfo := ::DispBegin()
local hDC := ::hDC
local oRect := ::GetCliRect()
local cDay, nDay, n, dDate, nCellWidth, nRowHeight
local nMonth := 0, nLeftCol := 0
local nColX, nRowY, cSay, aRect, nTopY
local hBrush
::CalcSizes()
if Empty( ::aGrad )
FillRect( hDC, oRect:aRect, ::oBrush:hBrush )
else
GradientFill( hDC, 0, 0, oRect:nHeight, oRect:nWidth, ::aGrad )
endif
::PaintHeader()
// Paint Sunday background color
hBrush := CreateSolidBrush( ::nClrSunday )
nColX := ::nMonthWidth
for n := ::nFirstCol to 36
if n % 7 == 1
FillRect( hDC, { oRect:nTop, nColX, oRect:nBottom, nColX + ::nCellWidth }, hBrush )
endif
nColX += ::nCellWidth
if nColX >= oRect:nRight
exit
endif
next
DeleteObject( hBrush )
// Paint Header Text
//
::oFontHeader:Activate( hDC )
SetTextColor( hDC, CLR_BLACK )
SetBkMode( hDC, 1 )
nColX := oRect:nLeft
DrawTextEx( hDC, "Year", { oRect:nTop, nColX, oRect:nTop + ::nHeaderHeight, nColX + 50 }, DT_CENTER+DT_VCENTER+DT_SINGLELINE )
nColX += 50
::Line( oRect:nTop, nColX, oRect:nBottom, nColX )
DrawTextEx( hDC, "Month", { oRect:nTop, nColX, oRect:nTop + ::nHeaderHeight, oRect:nLeft + ::nMonthWidth }, DT_CENTER+DT_VCENTER+DT_SINGLELINE )
nColX := ::nMonthWidth
::Line( oRect:nTop, nColX, oRect:nBottom, nColX )
for n := ::nFirstCol - 1 to 36
cDay := Left( NToCDow( ( n % 7 ) + 1 ), 2 )
SetTextColor( hDC, If( n % 7 == 0, CLR_HRED, CLR_BLACK ) )
DrawTextEx( hDC, cDay, { oRect:nTop, nColX, oRect:nTop + ::nHeaderHeight, nColX + ::nCellWidth }, DT_CENTER+DT_VCENTER+DT_SINGLELINE )
nColX += ::nCellWidth
::Line( oRect:nTop, nColX, oRect:nBottom, nColX )
if nColX >= oRect:nRight
exit
endif
next n
DrawTextEx( hDC, "%", { oRect:nTop, nColX, oRect:nTop + ::nHeaderHeight, nColX + ::nCellWidth }, DT_CENTER+DT_VCENTER+DT_SINGLELINE )
// Paint Month Names Vertically
nRowY := oRect:nTop + ::nHeaderHeight
nTopY := nRowY
nColX := 50
nMonth := ::nFirstMth + ( ::nTopMonth - 1 )
for n := nMonth to 24
dDate := ::aCal[ n, 1 ]
cSay := CMonth( dDate )
DrawTextEx( hDC, cSay, { nRowY, nColX + 8, nRowY + ::nRowHeight, nColX + 100 }, DT_LEFT+DT_VCENTER+DT_SINGLELINE )
nRowY += ::nRowHeight
if Month( ::aCal[ n, 1 ] ) == 12
::Line( nRowY, oRect:nLeft, nRowY, oRect:nRight )
::PaintYear( Year( dDate ), nTopY, nRowY )
nTopY := nRowY
else
::Line( nRowY, oRect:nLeft + 50, nRowY, oRect:nRight )
endif
if nRowY >= oRect:nBottom
exit
endif
next n
if nRowY > nTopY
::PaintYear( Year( dDate ), nTopY, Min( nRowY, oRect:nBottom ) )
endif
::oFontHeader:DeActivate( hDC )
::PaintDays()
if ValType( ::bPainted ) == "B"
Eval( ::bPainted, hDC, Min( ::dStart, ::dEnd ), Max( ::dStart, ::dEnd ), Self )
endif
::DispEnd( aInfo )
return 0
//----------------------------------------------------------------------------//
METHOD PaintHeader() CLASS TPickDate
local hBrush
local aRect := GetClientRect( ::hWnd )
aRect[ 3 ] := ::nHeaderHeight
if ValType( ::nClrHeader ) == 'N'
hBrush := CreateSolidBrush( ::nClrHeader )
FillRect( ::hDC, aRect, hBrush )
DeleteObject( hBrush )
elseif ValType( ::nClrHeader ) == 'A'
GradientFill( ::hDC, 0, 0, ::nHeaderHeight , aRect[ 4 ], ::nClrHeader )
endif
return nil
//----------------------------------------------------------------------------//
METHOD PaintYear( nYear, nTop, nBottom ) CLASS TPickDate
if nBottom - nTop > 90
::oFontHeader:DeActivate( ::hDC )
::oFontYear:Activate( ::hDC )
DrawTextEx( ::hDC, Str( nYear, 4 ), { nBottom, 0, nTop, 49 }, ;
DT_CENTER + DT_VCENTER + DT_SINGLELINE )
::oFontYear:DeActivate( ::hDC )
::oFontHeader:Activate( ::hDC )
else
DrawTextEx( ::hDC, Str( nYear, 4 ), { nTop, 0, nBottom, 49 }, ;
DT_CENTER + DT_VCENTER + DT_SINGLELINE )
endif
return nil
//----------------------------------------------------------------------------//
METHOD PaintDays() CLASS TPickDate
local oRect := ::GetCliRect()
local nMonth, nCol, nColX, nRowY, dDate, nDateSerial, cSay
local aRect, hBrushSelect, hBrushSeason, nOccu
local nBrushClr, nSeasonClr
oRect:nLeft := ::nMonthWidth
oRect:nTop := ::nHeaderHeight
hBrushSelect := CreateSolidBrush( ::nClrSelect )
// Draw Days
::oFont:Activate( ::hDC )
nRowY := oRect:nTop + 1
for nMonth := ::nTopMonth to 24
nColX := oRect:nLeft + 1
nOccu := 0
for nCol := ::nFirstCol + 1 to 38
dDate := ::aCal[ nMonth ][ nCol ]
if ! Empty( dDate )
nDateSerial := dDate - ::dFirst + 1
SetTextColor( ::hDC, If( Dow( dDate ) == 1, CLR_HRED, CLR_BLACK ) )
aRect := { nRowY, nColX, nRowY + ::nRowHeight - 1, nColX + ::nCellWidth - 1 }
if ::aDays[ nDateSerial ] > 0
nSeasonClr := ::SeasonColor( ::aDays[ nDateSerial ] )
if nSeasonClr != nBrushClr
if hBrushSeason != nil
DeleteObject( hBrushSeason )
endif
hBrushSeason := CreateSolidBrush( nSeasonClr )
nBrushClr := nSeasonClr
endif
FillRect( ::hDC, aRect, hBrushSeason )
nOccu++
elseif ::lSelecting .and. ! Empty( ::dStart ) .and. ! Empty( ::dEnd )
if IsBetween( dDate, ::dStart, ::dEnd )
FillRect( ::hDC, aRect, hBrushSelect )
endif
endif
cSay := Str( Day( dDate ), 2 )
DrawTextEx( ::hDC, cSay, aRect, DT_RIGHT + DT_TOP + DT_SINGLELINE )
endif
nColX += ::nCellWidth
if nColX >= oRect:nRight
exit
endif
next nCol
if nCol == 39 .and. nOccu > 0
cSay := Str( 100 * nOccu / Day( EOM( ::aCal[ nMonth, 1 ] ) ), 5, 1 ) + '%'
aRect := { nRowY, nColX, nRowY + ::nRowHeight - 1, oRect:nRight - 1 }
DrawTextEx( ::hDC, cSay, aRect, DT_RIGHT + DT_VCENTER + DT_SINGLELINE )
endif
nRowY += ::nRowHeight
if nRowY >= oRect:nBottom
exit
endif
next nMonth
::oFont:DeActivate( ::hDC )
if hBrushSeason != nil
DeleteObject( hBrushSeason )
endif
DeleteObject( hBrushSelect )
return nil
//----------------------------------------------------------------------------//
METHOD Destroy() CLASS TPickDate
::oFontHeader:End()
::oFontYear:End()
return Super:Destroy()
//----------------------------------------------------------------------------//
#ifdef REVD
METHOD StartSelect( dDate ) CLASS TPickDate
::dStart := ::dEnd := ::dTemp := dDate
::lSelecting := .t.
::Refresh( .f. )
return nil
//----------------------------------------------------------------------------//
METHOD EndSelect() CLASS TPickDate
if ValType( ::bSelect ) == "B"
Eval( ::bSelect, Min( ::dStart, ::dEnd ), Max( ::dStart, ::dEnd ), Self )
endif
::CancelSelect()
return nil
//----------------------------------------------------------------------------//
METHOD CancelSelect() CLASS TPickDate
::dStart := Date()
::dEnd := ::dTemp := nil
::lSelecting := .f.
::lPressed := .f.
::Refresh( .f. )
return nil
//----------------------------------------------------------------------------//
METHOD LButtonDown( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate := ::Pixel2Date( nRow, nCol )
if ::bLClicked == nil .and. ! Empty( dDate ) .and. ::aDays[ ::DateSerial( dDate ) ] < 1
::lPressed := .t.
endif
return Super:LButtonDown( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
METHOD LButtonUp( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate, nSeason
if ::lSelecting
::EndSelect()
else
if nRow == ::nLastRow .and. nCol == ::nLastCol
dDate := ::Pixel2Date( nRow, nCol )
nSeason := ::DateStatus( dDate )
if nSeason > 0 .and. ! Empty( ::bClickOnSeason )
Eval( ::bClickOnSeason, Self, dDate, nSeason )
endif
endif
endif
return Super:LButtonUp( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
METHOD MouseMove( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate := ::Pixel2Date( nRow, nCol )
if lAnd( nKeyFlags, 1 )
// Left button down
if ::lPressed .and. ! ::lSelecting .and. ::Available( dDate )
::StartSelect( dDate )
::lPressed := .f.
endif
if ::lSelecting
if ! Empty( dDate ) .and. ! Empty( ::dTemp ) .and. dDate != ::dTemp // for reducing continuous refreshes
if ::Available( ::dTemp, dDate )
::dTemp := ::dEnd := dDate
::Refresh( .f. )
else
::CancelSelect()
endif
endif
endif
else
// Left button up
if ::lSelecting
::CancelSelect()
endif
endif
return Super:MouseMove( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
#else
//----------------------------------------------------------------------------//
METHOD LButtonDown( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate := ::Pixel2Date( nRow, nCol )
if ::bLClicked == nil .and. ! Empty( dDate ) .and. ::aDays[ ::DateSerial( dDate ) ] < 1
::dStart := dDate
::dEnd := dDate
::dTemp := dDate
::lSelecting := .t.
::Refresh( .f. )
endif
return Super:LButtonDown( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
METHOD LButtonUp( nRow, nCol, nKeyFlags ) CLASS TPickDate
if ::lSelecting
if ValType( ::bSelect ) == "B"
Eval( ::bSelect, Min( ::dStart, ::dEnd ), Max( ::dStart, ::dEnd ), Self )
endif
::lSelecting := .f.
::dStart := Date()
::dEnd := ::dTemp := nil
::Refresh( .f. )
endif
return Super:LButtonUp( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
METHOD MouseMove( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate := ::Pixel2Date( nRow, nCol )
if ::lSelecting
if ! Empty( dDate ) .and. ! Empty( ::dTemp ) .and. dDate != ::dTemp // for reducing continuous refreshes
if lAnd( nKeyFlags, 1 ) .and. ::Available( ::dTemp, dDate )
::dTemp := ::dEnd := dDate
::Refresh( .f. )
else
::dStart := Date()
::dEnd := ::dTemp := nil
::lSelecting := .f.
::Refresh( .f. )
endif
endif
endif
return Super:MouseMove( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
#endif
//----------------------------------------------------------------------------//
METHOD Pixel2Date( y, x ) CLASS TPickDate
local nMonth, nCol, nDay, dDate
if y > ::nHeaderHeight .and. x > ::nMonthWidth
nMonth := Int( ( y - ::nHeaderHeight ) / ::nRowHeight ) + ::nTopMonth
if nMonth <= 24
nCol := Int( ( x - ::nMonthWidth ) / ::nCellWidth ) + ::nFirstCol
if nCol < Len( ::aCal[ nMonth ] )
dDate := ::aCal[ nMonth, nCol + 1 ]
if Empty( dDate )
dDate := nil
endif
endif
endif
endif
return dDate
//----------------------------------------------------------------------------//
METHOD Available( dFrom, dUpto ) CLASS TPickDate
local lAvailable := .t.
local n, n1, n2
if Empty( dFrom )
lAvailable := .f.
else
DEFAULT dUpto := dFrom
n1 := ::DateSerial( dFrom )
n2 := ::DateSerial( dUpto )
SwapLoHi( @n1, @n2 )
for n := n1 to n2
if ::aDays[ n ] > 0
lAvailable := .f.
exit
endif
next
endif
return lAvailable
//----------------------------------------------------------------------------//
METHOD ClearSeason( dDate ) CLASS TPickDate
local nDay := ::DateSerial( dDate )
local nSeason, n, nDays := Len( ::aDays )
if nDay > 0
nSeason := ::aDays[ nDay ]
if nSeason > 0
n := nDay
do while n > 0 .and. ::aDays[ n ] == nSeason
::aDays[ n ] := 0
n--
enddo
n := nDay + 1
do while n <= nDays .and. ::aDays[ n ] == nSeason
::aDays[ n ] := 0
n++
enddo
::Refresh()
endif
endif
return nil
//----------------------------------------------------------------------------//
METHOD SeasonColor( nSeasonID, nColor ) CLASS TPickDate
local nLen, nFill
if nSeasonID > ( nLen := Len( ::aSeasonClrs ) )
ASize( ::aSeasonClrs, nSeasonID )
nFill := IfNil( nColor, If( nLen == 0, CLR_YELLOW, ATail( ::aSeasonClrs ) ) )
AFill( ::aSeasonClrs, nFill, nLen + 1, nSeasonID - nLen )
endif
if nColor == nil
nColor := ::aSeasonClrs[ nSeasonID ]
else
if ::aSeasonClrs[ nSeasonID ] != nColor
::aSeasonClrs[ nSeasonID ] := nColor
::Refresh()
endif
endif
return nColor
//----------------------------------------------------------------------------//
METHOD MarkSeason( nSeasonID, dFrom, dUpto, nColor ) CLASS TPickDate
local lRefresh := .f.
local n1, n2, n
nColor := ::SeasonColor( nSeasonID, nColor )
n1 := ::DateSerial( dFrom )
n2 := ::DateSerial( dUpto )
SwapLoHi( @n1, @n2 )
if n1 <= Len( ::aDays ) .and. n2 > 0
n1 := Max( 1, n1 )
n2 := Min( Len( ::aDays ), n2 )
for n := n1 to n2
::aDays[ n ] := nSeasonID
next n
lRefresh := .t.
endif
if lRefresh
::Refresh()
endif
return lRefresh
//----------------------------------------------------------------------------//
METHOD VScroll( nWParam, nLParam ) CLASS TPickDate
local nScrHandle := nLParam
local nScrollCode := nLoWord( nWParam )
local nPos := nHiWord( nWParam )
local nRow, nBook
if GetFocus() != ::hWnd
SetFocus( ::hWnd )
endif
if ::nVisiRows >= 24
return 0
endif
if nScrHandle == 0 .and. ::oVScroll != nil
do case
case nScrollCode == SB_LINEUP
::GoUp()
case nScrollCode == SB_LINEDOWN
::GoDown()
case nScrollCode == SB_PAGEUP
::GoUp() //::PageUp()
case nScrollCode == SB_PAGEDOWN
::GoDown() //::PageDown()
case nScrollCode == SB_TOP
::GoTop()
case nScrollCode == SB_BOTTOM
::GoBottom()
case nScrollCode == SB_THUMBPOSITION .or. ;
nScrollCode == SB_THUMBTRACK
do case
case nPos == 1
::GoTop()
case nPos == ::oVScroll:GetRange()[ 2 ]
::GoBottom()
otherwise
::GoToPos( nPos )
endcase
otherwise
return nil
endcase
endif
return 0
//----------------------------------------------------------------------------//
METHOD HScroll( nWParam, nLParam ) CLASS TPickDate
local nScrHandle := nLParam
local nScrollCode := nLoWord( nWParam )
local nPos := nHiWord( nWParam )
local nRow, nBook
if GetFocus() != ::hWnd
SetFocus( ::hWnd )
endif
if ::nVisiCols >= 38
return 0
endif
if nScrHandle == 0 .and. ::oHScroll != nil
do case
case nScrollCode == SB_LINEUP
::GoLeft()
case nScrollCode == SB_LINEDOWN
::GoRight()
case nScrollCode == SB_PAGEUP
::GoLeft() //::PageUp()
case nScrollCode == SB_PAGEDOWN
::GoRight() //::PageDown()
case nScrollCode == SB_TOP
::GoLeftMost()
case nScrollCode == SB_BOTTOM
::GoRightMost()
case nScrollCode == SB_THUMBPOSITION .or. ;
nScrollCode == SB_THUMBTRACK
do case
case nPos == 1
::GoLeftMost()
case nPos == ::oVScroll:GetRange()[ 2 ]
::GoRightMost()
otherwise
::GoToCol( nPos )
endcase
otherwise
return nil
endcase
endif
return 0
//----------------------------------------------------------------------------//
METHOD MouseWheel( nKeys, nDelta, nXPos, nYPos ) CLASS TPickDate
local aPoint := { nYPos, nXPos }
ScreenToClient( ::hWnd, aPoint )
if IsOverWnd( ::hWnd, aPoint[ 1 ], aPoint[ 2 ] )
if lAnd( nKeys, MK_MBUTTON )
if nDelta > 0
::GoLeft()
else
::GoRight()
endif
else
if nDelta > 0
::GoUp()
else
::GoDown()
endif
endif
endif
Return nil
//----------------------------------------------------------------------------//
//----------------------------------------------------------------------------//
//
// SUPPORT FUNCTIONS FOR THE CLASS
//
//----------------------------------------------------------------------------//
static function ymd2Date( nYear, nMonth, nDay )
DEFAULT nMonth := 1, nDay := 1
do while nMonth > 12
nMonth -= 12
nYear++
enddo
return STOD( Str( nYear, 4 ) + StrZero( nMonth, 2 ) + StrZero( nDay, 2 ) )
//----------------------------------------------------------------------------//
static function IsBetween( u, u1, u2 )
local lBetween := .f.
if u2 >= u1
lBetween := ( u >= u1 .and. u <= u2 )
else
lBetween := ( u >= u2 .and. u <= u1 )
endif
return lBetween
//----------------------------------------------------------------------------//
static function SwapLoHi( u1, u2 )
local u, lSwapped := .f.
if u1 > u2
u := u2
u2 := u1
u1 := u
lSwapped := .t.
endif
return lSwapped
//----------------------------------------------------------------------------//
********************************************************************
mod harbour - Vamos a la conquista de la Web
modharbour.org
********************************************************************
mod harbour - Vamos a la conquista de la Web
modharbour.org
********************************************************************
-
Antonio Linares
- Site Admin
- Posts: 37481
- Joined: Thu Oct 06, 2005 5:47 pm
- Location: Spain
- Contact:
Re: How to achieve this kind of calendar control?
Dear Otto,
Many thanks for this great sharing
Many thanks for this great sharing
Re: How to achieve this kind of calendar control?
Thanks for the reply William. I'll keep a note if I need such feature in the future.
Otto, thanks for the sharing the code! Your calendar looks nice
Otto, thanks for the sharing the code! Your calendar looks nice
FWH 11.08/FWH 19.03
xHarbour 1.2.1 (Rev 6406) + BCC
Harbour 3.1 (Rev 17062) + BCC
Harbour 3.2.0dev (r1904111533) + BCC
xHarbour 1.2.1 (Rev 6406) + BCC
Harbour 3.1 (Rev 17062) + BCC
Harbour 3.2.0dev (r1904111533) + BCC
-
richard-service
- Posts: 583
- Joined: Tue Oct 16, 2007 8:57 am
- Location: New Taipei City, Taiwan
- Contact:
Re: How to achieve this kind of calendar control?
Hi Otto,
Good job and thanks a lot for share code.
Good job and thanks a lot for share code.
Regards,
Richard
Harbour 3.2.0dev (r1904111533)/xHarbour 1.2.3 Intl. (SimpLex) (Build 20180818) => Borland C++ v7.4
xHarbour 0.99.71 (SimpLex) => Borland C++ v5.5
MySQL v5.7 /ADS v12
Harbour 3.2.0dev (r1603181642) => Borland C++ v7.4 64bit
Richard
Harbour 3.2.0dev (r1904111533)/xHarbour 1.2.3 Intl. (SimpLex) (Build 20180818) => Borland C++ v7.4
xHarbour 0.99.71 (SimpLex) => Borland C++ v5.5
MySQL v5.7 /ADS v12
Harbour 3.2.0dev (r1603181642) => Borland C++ v7.4 64bit
-
Marc Venken
- Posts: 727
- Joined: Tue Jun 14, 2016 7:51 am
Re: How to achieve this kind of calendar control?
Hey Otto,
If I compile and run the exe file, It stops working (freeses)
I don't get a FW error or error.log
FW 1603
Do I have to do something more that put the prg in the sample dir and compile ?
If I compile and run the exe file, It stops working (freeses)
I don't get a FW error or error.log
FW 1603
Do I have to do something more that put the prg in the sample dir and compile ?
Marc Venken
Using: FWH 20.08 with Harbour
Using: FWH 20.08 with Harbour
-
Marc Venken
- Posts: 727
- Joined: Tue Jun 14, 2016 7:51 am
Re: How to achieve this kind of calendar control?
Some more :
Before I could get it to compile I had a error :
Application
===========
Path and name: c:\FwHarb1705\samples\kalender.exe (32 bits)
Size: 3,813,376 bytes
Compiler version: Harbour 3.2.0dev (r1506171039)
FiveWin version: FWH 17.05
C compiler version: Borland/Embarcadero C++ 7.0 (32-bit)
Windows version: 6.1, Build 7601 Service Pack 1
Time from start: 0 hours 0 mins 0 secs
Error occurred at: 04/10/2017, 13:34:38
Error description: Error BASE/1003 Variable does not exist: SUPER
Stack Calls
===========
Called from: kalender.prg => TPICKDATE:MOUSEMOVE( 847 )
Called from: => TWINDOW:HANDLEEVENT( 0 )
Called from: .\source\classes\CONTROL.PRG => TPICKDATE:HANDLEEVENT( 1731 )
Called from: .\source\classes\WINDOW.PRG => _FWH( 3325 )
Called from: => WINRUN( 0 )
Called from: .\source\classes\WINDOW.PRG => TWINDOW:ACTIVATE( 1036 )
Called from: kalender.prg => MAIN( 54 )
in the code
In the return I had to delete the Super, but than it freeses.
The issue is about the Super:xxxx code
I Vagely remember something about changing Super: into something else ?
Compiled by FWH 1705
Before I could get it to compile I had a error :
Application
===========
Path and name: c:\FwHarb1705\samples\kalender.exe (32 bits)
Size: 3,813,376 bytes
Compiler version: Harbour 3.2.0dev (r1506171039)
FiveWin version: FWH 17.05
C compiler version: Borland/Embarcadero C++ 7.0 (32-bit)
Windows version: 6.1, Build 7601 Service Pack 1
Time from start: 0 hours 0 mins 0 secs
Error occurred at: 04/10/2017, 13:34:38
Error description: Error BASE/1003 Variable does not exist: SUPER
Stack Calls
===========
Called from: kalender.prg => TPICKDATE:MOUSEMOVE( 847 )
Called from: => TWINDOW:HANDLEEVENT( 0 )
Called from: .\source\classes\CONTROL.PRG => TPICKDATE:HANDLEEVENT( 1731 )
Called from: .\source\classes\WINDOW.PRG => _FWH( 3325 )
Called from: => WINRUN( 0 )
Called from: .\source\classes\WINDOW.PRG => TWINDOW:ACTIVATE( 1036 )
Called from: kalender.prg => MAIN( 54 )
in the code
Code: Select all
METHOD MouseMove( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate := ::Pixel2Date( nRow, nCol )
if lAnd( nKeyFlags, 1 )
// Left button down
if ::lPressed .and. ! ::lSelecting .and. ::Available( dDate )
::StartSelect( dDate )
::lPressed := .f.
endif
if ::lSelecting
if ! Empty( dDate ) .and. ! Empty( ::dTemp ) .and. dDate != ::dTemp // for reducing continuous refreshes
if ::Available( ::dTemp, dDate )
::dTemp := ::dEnd := dDate
::Refresh( .f. )
else
::CancelSelect()
endif
endif
endif
else
// Left button up
if ::lSelecting
::CancelSelect()
endif
endif
return Super:MouseMove( nRow, nCol, nKeyFlags )
The issue is about the Super:xxxx code
I Vagely remember something about changing Super: into something else ?
Compiled by FWH 1705
Marc Venken
Using: FWH 20.08 with Harbour
Using: FWH 20.08 with Harbour
-
Antonio Linares
- Site Admin
- Posts: 37481
- Joined: Thu Oct 06, 2005 5:47 pm
- Location: Spain
- Contact:
Re: How to achieve this kind of calendar control?
Marc,
return ::Super:MouseMove( nRow, nCol, nKeyFlags )
return ::Super:MouseMove( nRow, nCol, nKeyFlags )
-
Marc Venken
- Posts: 727
- Joined: Tue Jun 14, 2016 7:51 am
Re: How to achieve this kind of calendar control?
Thank you.
I had to change all Super like Antonio said. Now it works for me.
I had to change all Super like Antonio said. Now it works for me.
Marc Venken
Using: FWH 20.08 with Harbour
Using: FWH 20.08 with Harbour
-
James Bott
- Posts: 4654
- Joined: Fri Nov 18, 2005 4:52 pm
- Location: San Diego, California, USA
- Contact:
Re: How to achieve this kind of calendar control?
Marc,
The term "super" works with xHarbour but not Harbour. The term "::super" works with both xHarbour and Harbour so it is the preferred syntax.
James
The term "super" works with xHarbour but not Harbour. The term "::super" works with both xHarbour and Harbour so it is the preferred syntax.
James
FWH 18.05/xHarbour 1.2.3/BCC7/Windows 10
-
Marc Venken
- Posts: 727
- Joined: Tue Jun 14, 2016 7:51 am
Re: How to achieve this kind of calendar control?
James,
Thanks for the explanation.
Marc
Thanks for the explanation.
Marc
Marc Venken
Using: FWH 20.08 with Harbour
Using: FWH 20.08 with Harbour
Re: How to achieve this kind of calendar control?
Added datas for colors lines and others
Code: Select all
#include "FiveWin.ch"
#include "xbrowse.ch"
#define REVD
REQUEST DBFCDX
FIELD SEASONID
//----------------------------------------------------------------------------//
static cSeasonsMaster := "SEASONS.DBF"
static cSeasonMarkDBF := "SEASNMRK.DBF"
//----------------------------------------------------------------------------//
function Main()
local oWnd, oPickDate, cFilt
if ! File( cSeasonsMaster )
CreateSeasonsMaster( cSeasonsMaster )
endif
if ! File( cSeasonMarkDBF )
CreateSeasonMarkDBF()
endif
USE (cSeasonsMaster) NEW ALIAS "SEASONS" EXCLUSIVE
SET ORDER TO TAG SEASONID
GO TOP
USE (cSeasonMarkDBF) NEW ALIAS "MARK" EXCLUSIV
DEFINE WINDOW oWnd TITLE "Calendar"
oPickDate := TPickDate():New( 1, 1,,, oWnd )
WITH OBJECT oPickDate
//:nHeaderHeight := 40
:aGrad := Nil
:nClrHeader := METRO_OLIVE
:nClrLines := CLR_HGRAY
:nClrMonths := CLR_BLUE
:nClrYears := CLR_WHITE
//:nClrSelect := CLR_BLUE
END
SEASONS->( FillSeasonColors( oPickDate ) )
MARK-> ( MarkSeasonsFromDBF( oPickdate ) )
oPickDate:bSelect := { | dStart, dEnd | SeasonDialog( oPickDate, dStart, dEnd ) }
oPickDate:bClickOnSeason := { | o, dDate, nID | MARK->( OnClickSeason( o, dDate, nID ) ) }
oWnd:oClient = oPickDate
ACTIVATE WINDOW oWnd MAXIMIZED
return nil
//----------------------------------------------------------------------------//
init procedure PrgInit
SET DATE FRENCH
SET CENTURY ON
SET TIME FORMAT TO "HH:MM:SS"
SET EPOCH TO YEAR(DATE())-50
SET DELETED ON
SET EXCLUSIVE OFF
RDDSETDEFAULT( "DBFCDX" )
XbrNumFormat( 'A', .t. )
SetKinetic( .f. )
SetGetColorFocus()
return
//----------------------------------------------------------------------------//
static function OnRightClick( oPick, r, c )
local dDate, nDay, nSeasonID, n, dFrom, dUpto
dDate := oPick:Pixel2Date( r, c )
nDay := oPick:DateSerial( dDate )
nSeasonID := oPick:aDays[ nDay ]
if nSeasonID == 0
MsgInfo( DToC( dDate ) + " Available" )
else
if MsgNoYes( "Season " + LTrim( Str( nSeasonID ) ) + CRLF + ;
"Unmark Season ? (Y/N)" )
endif
endif
return nil
//----------------------------------------------------------------------------//
static function FillSeasonColors( oPick )
GO TOP
DBEVAL( { || oPick:SeasonColor( FIELD->SEASONID, FIELD->SNCOLOR ) } )
GO TOP
return nil
//----------------------------------------------------------------------------//
static function MarkSeason( oPick, nID, dFrom, dUpto )
oPick:MarkSeason( nID, dFrom, dUpto )
CursorWait()
MARK->( DBAPPEND() )
MARK->SEASONID := nID
MARK->FROMDATE := dFrom
MARK->TILLDATE := dUpto
DBCOMMIT()
CursorArrow()
return nil
//----------------------------------------------------------------------------//
static function OnClickSeason( oPick, dDate, nSeasonID )
FIELD SEASONID, FROMDATE, TILLDATE
local cMsg, cCond
SEASONS->( DBSEEK( nSeasonID ) )
cMsg := "Clear " + TRIM( SEASONS->SNNAME ) + "? (Y/N)"
if MsgNoYes( cMsg )
oPick:ClearSeason( dDate )
CursorWait()
DBGOTOP()
LOCATE FOR SEASONID = nSeasonID .AND. dDate >= FROMDATE .and. dDate <= TILLDATE
if FOUND()
DBDELETE()
endif
DBGOTOP()
CursorArrow()
endif
return nil
//----------------------------------------------------------------------------//
static function MarkSeasonsFromDBF( oPick )
MARK->( DBGOTOP() )
DO WHILE ! MARK->( eof() )
oPick:MarkSeason( MARK->SEASONID, MARK->FROMDATE, MARK->TILLDATE )
MARK->( DBSKIP( 1 ) )
ENDDO
MARK->( DBGOTOP() )
return nil
//----------------------------------------------------------------------------//
static function SeasonDialog( oPick, dFrom, dUpto )
local oDlg, oBrw, oFont, nRow, nClr, nID
local nSelect := 0
SEASONS->( DBGOTOP() )
DEFINE FONT oFont NAME "Segoe UI" SIZE 0,-16
DEFINE DIALOG oDlg SIZE 300,400 PIXEL FONT oFont ;
TITLE "Select Season to Mark"
@ 10,10 XBROWSE oBrw SIZE -10,-60 PIXEL OF oDlg ;
COLUMNS "SNCOLOR", "SNNAME" ;
HEADERS "Clr", "Season" ;
ALIAS "SEASONS" CELL LINES NOBORDER
WITH OBJECT oBrw:Clr
:bEditValue := { || "" }
:bClrStd := { || { SEASONS->SNCOLOR, SEASONS->SNCOLOR } }
:bClrSelFocus := :bClrSel := :bClrStd
:bLDClickData := { || SEASONS->SNCOLOR := ChooseColor( SEASONS->SNCOLOR ), ;
oPick:SeasonColor( SEASONS->SEASONID, SEASONS->SNCOLOR ) }
END
WITH OBJECT oBrw
WITH OBJECT :Season
:nEditType := EDIT_GET
:bClrSel := ;
:bClrSelFocus := { || { CLR_WHITE, CLR_GREEN } }
END
:nStretchCol := 2
:lColDividerComplete := .f.
:lHeader := .f.
// :nColorPen := CLR_YELLOW
:nMarqueeStyle := MARQSTYLE_HIGHLROW
:lVScroll := .f.
:lHScroll := .f.
:lRecordSelector := .f.
END
oBrw:CreateFromCode()
nRow := 148 //+ 16
@ nRow, 10 BUTTON "Add New Season" SIZE 130, 14 PIXEL OF oDlg ;
ACTION ( nClr := ChooseColor( CLR_WHITE ), ;
If( nClr != CLR_WHITE, SEASONS->( ;
DBGOBOTTOM(), nID := FIELD->SEASONID - RECNO(), ;
SEASONS->(DBAPPEND()), ;
SEASONS->SEASONID := RECNO() + nID, ;
SEASONS->SNCOLOR := nClr, ;
SEASONS->SNNAME := "Season-" + LTrim( Str(SEASONS->SEASONID) ), ;
If( oPick == nil, nil, oPick:SeasonColor( SEASONS->SEASONID, nClr ) ), ;
oBrw:Refresh(), oBrw:SetFocus() ;
), nil ) )
// @ nRow, 77 BUTTON "Delete Season" SIZE 63, 14 PIXEL OF oDlg
nRow += ATail( oDlg:aControls ):nHeight + 2
@ nRow, 10 BUTTON "Mark Season" SIZE 130, 14 PIXEL OF oDlg ;
ACTION ( nSelect := SEASONS->SEASONID, oDlg:End() )
nRow += ATail( oDlg:aControls ):nHeight + 2
@ nRow, 10 BUTTON "Cancel" SIZE 130, 14 PIXEL OF oDlg ACTION oDlg:End()
ACTIVATE DIALOG oDlg CENTERED ;
ON PAINT oDlg:Box( oBrw:nTop - 1, oBrw:nLeft - 1, oBrw:nBottom, oBrw:nRight )
RELEASE FONT oFont
if nSelect > 0
MarkSeason( oPick, nSelect, dFrom, dUpto )
endif
return nil
//----------------------------------------------------------------------------//
static function CreateSeasonsMaster()
local aColors := { CLR_CYAN, CLR_YELLOW, CLR_HRED, CLR_HGREEN }
local n
local aCols := { ;
{ "SEASONID", 'N', 2, 0 }, ;
{ "SNCOLOR", 'N', 8, 0 }, ;
{ "SNNAME", 'C', 20, 0 } }
DBCREATE( cSeasonsMaster, aCols )
USE (cSeasonsMaster) NEW ALIAS "SEASONS" EXCLUSIVE
for n := 1 to Len( aColors )
APPEND BLANK
FIELD->SEASONID := n
FIELD->SNCOLOR := aColors[ n ]
FIELD->SNNAME := "Season-" + Str( n, 1 )
next n
INDEX ON SEASONID TAG SEASONID
USE
return nil
//----------------------------------------------------------------------------//
static function CreateSeasonMarkDBF()
local aCols := { ;
{ "SEASONID", 'N', 2, 0 }, ;
{ "FROMDATE", 'D', 8, 0 }, ;
{ "TILLDATE", 'D', 8, 0 } }
DBCREATE( cSeasonMarkDBF, aCols )
return nil
//----------------------------------------------------------------------------//
//
// CLASS DEFINITIONS BEGIN
//
//----------------------------------------------------------------------------//
#define DT_TOP 0x00000000
#define DT_LEFT 0x00000000
#define DT_CENTER 0x00000001
#define DT_RIGHT 0x00000002
#define DT_VCENTER 0x00000004
#define DT_BOTTOM 0x00000008
#define DT_WORDBREAK 0x00000010
#define DT_SINGLELINE 0x00000020
#define SM_CYVSCROLL 20
#define SM_CYHSCROLL 3
#define MK_MBUTTON 0x0010
//----------------------------------------------------------------------------//
CLASS TPickDate FROM TControl
CLASSDATA lRegistered AS LOGICAL
DATA dStart, dEnd, dTemp
DATA lSelecting INIT .f.
DATA lPressed INIT .f.
DATA nYear INIT Year( Date() )
DATA dFirst, dLast
DATA nFirstMth INIT 1 //Month( Date() )
DATA aDays
DATA aCal
DATA aSeasonClrs INIT Array( 0 )
DATA nTopMonth INIT 1
DATA nFirstCol INIT 1
DATA nClrSunday INIT RGB( 183, 249, 185 ) // Greenish
DATA nClrSelect INIT RGB( 240, 232, 188 )
DATA oFontHeader, oFontYear
DATA nMonthWidth INIT 140 //150
DATA nHeaderHeight INIT 54 //60
DATA bSelect
DATA bClickOnSeason
DATA aGrad INIT { { 1, nRGB( 128, 217, 255 ), nRGB( 54, 147, 255 ) } }
DATA nClrHeader INIT { { 1, nRGB( 128, 217, 255 ), nRGB( 54, 147, 255 ) } }
DATA nRowHeight
DATA nCellWidth
DATA nVisiRows, nVisiCols
DATA oVScroll, oHScroll
DATA nClrMonths INIT CLR_BLACK
DATA nClrYears INIT CLR_BLACK
DATA nClrLines INIT CLR_BLACK
METHOD New( nTop, nLeft, nWidth, nHeight, oWnd, nYear, nClrFore, nClrBack )
METHOD Redefine( nId, oWnd )
METHOD CalcSizes()
METHOD SetStartMonth()
METHOD Paint()
METHOD PaintHeader()
METHOD PaintYear( nYear, nTop, nBottom )
METHOD PaintDays()
METHOD Display() INLINE ::BeginPaint(), ::Paint(), ::EndPaint(), 0
METHOD EraseBkGnd( hDC ) INLINE 0
METHOD Destroy()
//
METHOD LButtonDown( nRow, nCol, nKeyFlags )
METHOD LButtonUp( nRow, nCol, nKeyFlags )
METHOD MouseMove( nRow, nCol, nKeyFlags )
METHOD StartSelect()
METHOD EndSelect()
METHOD CancelSelect()
//
METHOD Pixel2Date( nRow, nCol )
METHOD Available( dFrom, dUpto )
METHOD DateSerial( dDate ) INLINE If( Empty( dDate ), 0, dDate - ::dFirst + 1 )
METHOD Serial2Date( nSerial ) INLINE ( ::dFirst + nSerial - 1 )
METHOD DateStatus( dDate ) INLINE If( Empty( dDate ), 0, ::aDays[ ::DateSerial( dDate ) ] )
METHOD SeasonColor( nSeasonID, nColor )
METHOD MarkSeason( nSeasonID, dFrom, dUpto, nColor )
METHOD ClearSeason( dDate )
//
METHOD GoTop() INLINE ( If( ::nTopMonth > 1, ( ::nTopMonth := 1, ::Refresh() ), nil ), ::VSetPos() )
METHOD GoBottom() INLINE If( ::nVisiRows < 24, ( ::nTopMonth := 25 - ::nVisiRows, ::Refresh(), ::VSetPos() ), nil )
METHOD GoUp() INLINE If( ::nTopMonth > 1, ( ::nTopMonth--, ::Refresh(), ::vSetPos() ), nil )
METHOD GoDown() INLINE If( ::nTopMonth < 25 - ::nVisiRows, ( ::nTopMonth++, ::Refresh(), ::VSetPos() ), nil )
METHOD GoToPos( n ) INLINE ( ::nTopMonth := Max( 1, Min( n, 25 - ::nVisiRows ) ), ::Refresh(), ::vSetPos() )
METHOD VSetPos() INLINE ( ::oVScroll:SetPos( ::nTopMonth ) )
METHOD VScroll( nWParam, nLParam )
//
METHOD GoLeftMost() INLINE If( ::nFirstCol > 1, ( ::nFirstCol := 1, ::Refresh(), nil ), ::HSetPos() )
METHOD GoRightMost() INLINE If( ::nVisiCols < 38, ( ::nFirstCol := 39 - ::nVisiCols, ::Refresh(), ::HSetPos() ), nil )
METHOD GoLeft() INLINE If( ::nFirstCol > 1, ( ::nFirstCol--, ::Refresh(), ::HSetPos() ), nil )
METHOD GoRight() INLINE If( ::nFirstCol < 39 - ::nVisiCols, ( ::nFirstCol++, ::Refresh(), ::HSetPos() ), nil )
METHOD GoToCol(n) INLINE ( ::nFirstCol := Max( 1, Min( n, 39 - ::nVisiCols ) ), ::Refresh(), ::HSetPos() )
METHOD HSetPos() INLINE ( ::oHScroll:SetPos( ::nFirstCol ) )
METHOD HScroll( nWParam, nLParam )
//
METHOD MouseWheel( nKeys, nDelta, nXPos, nYPos )
//
ENDCLASS
//----------------------------------------------------------------------------//
METHOD New( nTop, nLeft, nWidth, nHeight, oWnd, nYear, nClrFore, nClrBack ) CLASS TPickDate
DEFAULT nWidth := 800,;
nHeight := 300,;
nLeft := 0,;
nTop := 0,;
nYear := Year( Date() ),;
oWnd := GetWndDefault()
::lSelecting = .F.
::nTop = nTop
::nLeft = nLeft
::nBottom = nTop + nHeight - 1
::nRight = nLeft + nWidth - 1
::nYear = Year( Date() )
::oWnd = oWnd
::SetStartMonth( Date() )
::dStart := ::dEnd := ::dTemp := Date()
::nClrText = nClrFore
::nClrPane = nClrBack
::nStyle = nOr( WS_CHILD, WS_VISIBLE, WS_TABSTOP, WS_BORDER, WS_VSCROLL, WS_HSCROLL )
DEFINE FONT ::oFont NAME "Calibri" SIZE 0, -12 //BOLD //-12 BOLD
DEFINE FONT ::oFontHeader NAME "Tahoma" SIZE 0, -12 BOLD
DEFINE FONT ::oFontYear NAME "Tahoma" SIZE 0, -14 BOLD NESCAPEMENT 900 //-16
DEFINE SCROLLBAR ::oVScroll VERTICAL OF Self
DEFINE SCROLLBAR ::oHScroll HORIZONTAL OF Self
::bLostFocus := { || If( ::lSelecting, ::CancelSelect(), nil ) }
#ifdef __XPP__
DEFAULT ::lRegistered := .F.
#endif
::Register()
if ! Empty( oWnd:hWnd )
::Create()
oWnd:AddControl( Self )
else
oWnd:DefControl( Self )
endif
return self
//----------------------------------------------------------------------------//
METHOD Redefine( nId, oWnd ) CLASS TPickDate
DEFAULT oWnd := GetWndDefault()
::nId = nId
::oWnd = oWnd
::lSelecting = .F.
::dStart := ::dEnd := ::dTemp := Date()
::nYear = Year( Date() )
DEFINE FONT ::oFont NAME "Tahoma" SIZE 0, -12 BOLD
DEFINE FONT ::oFontHeader NAME "Tahoma" SIZE 0, -12
DEFINE FONT ::oFontYear NAME "TAHOMA" SIZE 0, -16 BOLD NESCAPEMENT 900
::SetColor( 0, 0 )
::Register()
oWnd:DefControl( Self )
return Self
//----------------------------------------------------------------------------//
METHOD SetStartMonth( dDate ) CLASS TPickDate
local nMonth, nCol
local dNull := CTOD( '' )
local dEOM, dStart
DEFAULT dDate := Date()
dStart := ;
dDate := BOM( dDate )
::aCal := Array( 24, 39 )
for nMonth := 1 to 24
AFill( ::aCal[ nMonth ], dNull )
::aCal[ nMonth ][ 1 ] := dDate
dEOM := EOM( dDate )
nCol := DOW( dDate ) + 1
for dDate := dDate to dEOM
::aCal[ nMonth ][ nCol ] := dDate
nCol++
next dDate
next nMonth
::aDays := Array( dDate - dStart )
::dFirst := dStart
::dLast := dDate - 1
AFill( ::aDays, 0 )
return Self
//----------------------------------------------------------------------------//
METHOD CalcSizes() CLASS TPickDate
local oRect := ::GetCliRect()
local nRows, nCols, nHeight, nWidth
nHeight := oRect:nHeight - ::nHeaderHeight
nWidth := oRect:nWidth - ::nMonthWidth
::nRowHeight := Max( 20, Int( nHeight / 24 ) )
::nCellWidth := Max( 20, Int( nWidth / 38 ) )
nRows := Int( nHeight / ::nRowHeight )
nCols := Int( nWidth / ::nCellwidth )
if nRows != ::nVisiRows
::nVisiRows := nRows
nRows := Max( 1, 25 - ::nVisiRows )
::oVScroll:SetRange( 1, nRows )
if ::nTopMonth > nRows
::nTopMonth := nRows
endif
::oVScroll:SetPos( ::nTopMonth )
endif
if nCols != ::nVisiCols
::nVisiCols := nCols
nCols := Max( 1, 39 - ::nVisiCols )
::oHScroll:SetRange( 1, nCols )
if ::nFirstCol > nCols
::nFirstCol := nCols
endif
::oHScroll:SetPos( ::nFirstCol )
endif
return Self
//----------------------------------------------------------------------------//
METHOD Paint() CLASS TPickDate
local aInfo := ::DispBegin()
local hDC := ::hDC
local oRect := ::GetCliRect()
local cDay, nDay, n, dDate, nCellWidth, nRowHeight
local nMonth := 0, nLeftCol := 0
local nColX, nRowY, cSay, aRect, nTopY
local hBrush
local hPen
local hOldPen
::CalcSizes()
if Empty( ::aGrad )
FillRect( hDC, oRect:aRect, ::oBrush:hBrush )
else
GradientFill( hDC, 0, 0, oRect:nHeight, oRect:nWidth, ::aGrad )
endif
::PaintHeader()
// Paint Sunday background color
hBrush := CreateSolidBrush( ::nClrSunday )
nColX := ::nMonthWidth
for n := ::nFirstCol to 36
if n % 7 == 1
FillRect( hDC, { oRect:nTop+1, nColX, oRect:nBottom, nColX + ::nCellWidth }, hBrush )
endif
nColX += ::nCellWidth
if nColX >= oRect:nRight
exit
endif
next
DeleteObject( hBrush )
// Paint Header Text
//
hPen := CreatePen( 0, 1, ::nClrLines )
hOldPen := SelectObject( hDC, hPen )
::Line( oRect:nTop, oRect:nLeft, oRect:nTop, oRect:nRight )
::Line( oRect:nTop + ::nHeaderHeight, oRect:nLeft, oRect:nTop + ::nHeaderHeight, oRect:nRight )
SelectObject( hDC, hOldPen )
DeleteObject( hPen )
::oFontHeader:Activate( hDC )
SetTextColor( hDC, ::nClrYears )
SetBkMode( hDC, 1 )
nColX := oRect:nLeft
DrawTextEx( hDC, "Year", { oRect:nTop, nColX, oRect:nTop + ::nHeaderHeight, nColX + 50 }, DT_CENTER+DT_VCENTER+DT_SINGLELINE )
nColX += 50
hPen := CreatePen( 0, 1, ::nClrLines )
hOldPen := SelectObject( hDC, hPen )
::Line( oRect:nTop, nColX, oRect:nBottom, nColX )
SelectObject( hDC, hOldPen )
DeleteObject( hPen )
SetTextColor( hDC, ::nClrMonths )
SetBkMode( hDC, 1 )
DrawTextEx( hDC, "Month", { oRect:nTop, nColX, oRect:nTop + ::nHeaderHeight, oRect:nLeft + ::nMonthWidth }, DT_CENTER+DT_VCENTER+DT_SINGLELINE )
nColX := ::nMonthWidth
hPen := CreatePen( 0, 1, ::nClrLines )
hOldPen := SelectObject( hDC, hPen )
::Line( oRect:nTop, nColX, oRect:nBottom, nColX )
SelectObject( hDC, hOldPen )
DeleteObject( hPen )
for n := ::nFirstCol - 1 to 36
cDay := Left( NToCDow( ( n % 7 ) + 1 ), 2 )
SetTextColor( hDC, If( n % 7 == 0, CLR_HRED, ::nClrYears ) )
DrawTextEx( hDC, cDay, { oRect:nTop, nColX, oRect:nTop + ::nHeaderHeight, nColX + ::nCellWidth }, ;
DT_CENTER + DT_VCENTER + DT_SINGLELINE )
nColX += ::nCellWidth
hPen := CreatePen( 0, 1, ::nClrLines )
hOldPen := SelectObject( hDC, hPen )
::Line( oRect:nTop, nColX, oRect:nBottom, nColX )
SelectObject( hDC, hOldPen )
DeleteObject( hPen )
if nColX >= oRect:nRight
exit
endif
next n
DrawTextEx( hDC, "%", { oRect:nTop, nColX, oRect:nTop + ::nHeaderHeight, oRect:nRight - 1 }, ; //nColX + ::nCellWidth }, ;
DT_CENTER + DT_VCENTER + DT_SINGLELINE )
// Paint Month Names Vertically
nRowY := oRect:nTop + ::nHeaderHeight
nTopY := nRowY
nColX := 50
SetTextColor( hDC, ::nClrMonths )
nMonth := ::nFirstMth + ( ::nTopMonth - 1 )
for n := nMonth to 24
dDate := ::aCal[ n, 1 ]
cSay := CMonth( dDate )
DrawTextEx( hDC, cSay, { nRowY, nColX + 8, nRowY + ::nRowHeight, nColX + 100 }, ;
DT_LEFT + DT_VCENTER + DT_SINGLELINE )
nRowY += ::nRowHeight
if Month( ::aCal[ n, 1 ] ) == 12
hPen := CreatePen( 0, 1, ::nClrLines )
hOldPen := SelectObject( hDC, hPen )
::Line( nRowY, oRect:nLeft, nRowY, oRect:nRight )
SelectObject( hDC, hOldPen )
DeleteObject( hPen )
::PaintYear( Year( dDate ), nTopY, nRowY )
nTopY := nRowY
else
hPen := CreatePen( 0, 1, ::nClrLines )
hOldPen := SelectObject( hDC, hPen )
::Line( nRowY, oRect:nLeft + 50, nRowY, oRect:nRight )
SelectObject( hDC, hOldPen )
DeleteObject( hPen )
endif
if nRowY >= oRect:nBottom
exit
endif
next n
if nRowY > nTopY
::PaintYear( Year( dDate ), nTopY, Min( nRowY, oRect:nBottom ) )
endif
::oFontHeader:DeActivate( hDC )
::PaintDays()
if ValType( ::bPainted ) == "B"
Eval( ::bPainted, hDC, Min( ::dStart, ::dEnd ), Max( ::dStart, ::dEnd ), Self )
endif
::DispEnd( aInfo )
return 0
//----------------------------------------------------------------------------//
METHOD PaintHeader() CLASS TPickDate
local hBrush
local aRect := GetClientRect( ::hWnd )
aRect[ 3 ] := ::nHeaderHeight
if ValType( ::nClrHeader ) == 'N'
hBrush := CreateSolidBrush( ::nClrHeader )
FillRect( ::hDC, aRect, hBrush )
DeleteObject( hBrush )
elseif ValType( ::nClrHeader ) == 'A'
GradientFill( ::hDC, 0, 0, ::nHeaderHeight , aRect[ 4 ], ::nClrHeader )
endif
return nil
//----------------------------------------------------------------------------//
METHOD PaintYear( nYear, nTop, nBottom ) CLASS TPickDate
if nBottom - nTop > 90
::oFontHeader:DeActivate( ::hDC )
::oFontYear:Activate( ::hDC )
DrawTextEx( ::hDC, Str( nYear, 4 ), { nBottom, 0, nTop, 49 }, ;
DT_CENTER + DT_VCENTER + DT_SINGLELINE )
::oFontYear:DeActivate( ::hDC )
::oFontHeader:Activate( ::hDC )
else
DrawTextEx( ::hDC, Str( nYear, 4 ), { nTop, 0, nBottom, 49 }, ;
DT_CENTER + DT_VCENTER + DT_SINGLELINE )
endif
return nil
//----------------------------------------------------------------------------//
METHOD PaintDays() CLASS TPickDate
local oRect := ::GetCliRect()
local nMonth, nCol, nColX, nRowY, dDate, nDateSerial, cSay
local aRect, hBrushSelect, hBrushSeason, nOccu
local nBrushClr, nSeasonClr
oRect:nLeft := ::nMonthWidth
oRect:nTop := ::nHeaderHeight
hBrushSelect := CreateSolidBrush( ::nClrSelect )
// Draw Days
::oFont:Activate( ::hDC )
nRowY := oRect:nTop + 1
for nMonth := ::nTopMonth to 24
nColX := oRect:nLeft + 1
nOccu := 0
for nCol := ::nFirstCol + 1 to 38
dDate := ::aCal[ nMonth ][ nCol ]
if ! Empty( dDate )
nDateSerial := dDate - ::dFirst + 1
SetTextColor( ::hDC, If( Dow( dDate ) == 1, CLR_HRED, CLR_BLACK ) )
aRect := { nRowY, nColX, nRowY + ::nRowHeight - 1, nColX + ::nCellWidth - 1 }
if ::aDays[ nDateSerial ] > 0
nSeasonClr := ::SeasonColor( ::aDays[ nDateSerial ] )
if nSeasonClr != nBrushClr
if hBrushSeason != nil
DeleteObject( hBrushSeason )
endif
hBrushSeason := CreateSolidBrush( nSeasonClr )
nBrushClr := nSeasonClr
endif
FillRect( ::hDC, aRect, hBrushSeason )
nOccu++
elseif ::lSelecting .and. ! Empty( ::dStart ) .and. ! Empty( ::dEnd )
if IsBetween( dDate, ::dStart, ::dEnd )
FillRect( ::hDC, aRect, hBrushSelect )
endif
endif
cSay := Str( Day( dDate ), 2 )
DrawTextEx( ::hDC, cSay, aRect, DT_RIGHT + DT_TOP + DT_SINGLELINE )
endif
nColX += ::nCellWidth
if nColX >= oRect:nRight
exit
endif
next nCol
if nCol == 39 .and. nOccu > 0
cSay := Str( 100 * nOccu / Day( EOM( ::aCal[ nMonth, 1 ] ) ), 5, 2 ) + '%'
aRect := { nRowY, nColX, nRowY + ::nRowHeight - 1, oRect:nRight - 1 }
DrawTextEx( ::hDC, cSay, aRect, DT_CENTER + DT_VCENTER + DT_SINGLELINE ) //DT_RIGHT +
endif
nRowY += ::nRowHeight
if nRowY >= oRect:nBottom
exit
endif
next nMonth
::oFont:DeActivate( ::hDC )
if hBrushSeason != nil
DeleteObject( hBrushSeason )
endif
DeleteObject( hBrushSelect )
return nil
//----------------------------------------------------------------------------//
METHOD Destroy() CLASS TPickDate
::oFontHeader:End()
::oFontYear:End()
return ::Super:Destroy()
//----------------------------------------------------------------------------//
#ifdef REVD
METHOD StartSelect( dDate ) CLASS TPickDate
::dStart := ::dEnd := ::dTemp := dDate
::lSelecting := .t.
::Refresh( .f. )
return nil
//----------------------------------------------------------------------------//
METHOD EndSelect() CLASS TPickDate
if ValType( ::bSelect ) == "B"
Eval( ::bSelect, Min( ::dStart, ::dEnd ), Max( ::dStart, ::dEnd ), Self )
endif
::CancelSelect()
return nil
//----------------------------------------------------------------------------//
METHOD CancelSelect() CLASS TPickDate
::dStart := Date()
::dEnd := ::dTemp := nil
::lSelecting := .f.
::lPressed := .f.
::Refresh( .f. )
return nil
//----------------------------------------------------------------------------//
METHOD LButtonDown( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate := ::Pixel2Date( nRow, nCol )
if ::bLClicked == nil .and. ! Empty( dDate ) .and. ::aDays[ ::DateSerial( dDate ) ] < 1
::lPressed := .t.
endif
return ::Super:LButtonDown( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
METHOD LButtonUp( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate, nSeason
if ::lSelecting
::EndSelect()
else
if nRow == ::nLastRow .and. nCol == ::nLastCol
dDate := ::Pixel2Date( nRow, nCol )
nSeason := ::DateStatus( dDate )
if nSeason > 0 .and. ! Empty( ::bClickOnSeason )
Eval( ::bClickOnSeason, Self, dDate, nSeason )
endif
endif
endif
return ::Super:LButtonUp( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
METHOD MouseMove( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate := ::Pixel2Date( nRow, nCol )
if lAnd( nKeyFlags, 1 )
// Left button down
if ::lPressed .and. ! ::lSelecting .and. ::Available( dDate )
::StartSelect( dDate )
::lPressed := .f.
endif
if ::lSelecting
if ! Empty( dDate ) .and. ! Empty( ::dTemp ) .and. dDate != ::dTemp // for reducing continuous refreshes
if ::Available( ::dTemp, dDate )
::dTemp := ::dEnd := dDate
::Refresh( .f. )
else
::CancelSelect()
endif
endif
endif
else
// Left button up
if ::lSelecting
::CancelSelect()
endif
endif
return ::Super:MouseMove( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
#else
//----------------------------------------------------------------------------//
METHOD LButtonDown( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate := ::Pixel2Date( nRow, nCol )
if ::bLClicked == nil .and. ! Empty( dDate ) .and. ::aDays[ ::DateSerial( dDate ) ] < 1
::dStart := dDate
::dEnd := dDate
::dTemp := dDate
::lSelecting := .t.
::Refresh( .f. )
endif
return ::Super:LButtonDown( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
METHOD LButtonUp( nRow, nCol, nKeyFlags ) CLASS TPickDate
if ::lSelecting
if ValType( ::bSelect ) == "B"
Eval( ::bSelect, Min( ::dStart, ::dEnd ), Max( ::dStart, ::dEnd ), Self )
endif
::lSelecting := .f.
::dStart := Date()
::dEnd := ::dTemp := nil
::Refresh( .f. )
endif
return ::Super:LButtonUp( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
METHOD MouseMove( nRow, nCol, nKeyFlags ) CLASS TPickDate
local dDate := ::Pixel2Date( nRow, nCol )
if ::lSelecting
if ! Empty( dDate ) .and. ! Empty( ::dTemp ) .and. dDate != ::dTemp // for reducing continuous refreshes
if lAnd( nKeyFlags, 1 ) .and. ::Available( ::dTemp, dDate )
::dTemp := ::dEnd := dDate
::Refresh( .f. )
else
::dStart := Date()
::dEnd := ::dTemp := nil
::lSelecting := .f.
::Refresh( .f. )
endif
endif
endif
return ::Super:MouseMove( nRow, nCol, nKeyFlags )
//-----------------------------------------------------------------//
#endif
//----------------------------------------------------------------------------//
METHOD Pixel2Date( y, x ) CLASS TPickDate
local nMonth, nCol, nDay, dDate
if y > ::nHeaderHeight .and. x > ::nMonthWidth
nMonth := Int( ( y - ::nHeaderHeight ) / ::nRowHeight ) + ::nTopMonth
if nMonth <= 24
nCol := Int( ( x - ::nMonthWidth ) / ::nCellWidth ) + ::nFirstCol
if nCol < Len( ::aCal[ nMonth ] )
dDate := ::aCal[ nMonth, nCol + 1 ]
if Empty( dDate )
dDate := nil
endif
endif
endif
endif
return dDate
//----------------------------------------------------------------------------//
METHOD Available( dFrom, dUpto ) CLASS TPickDate
local lAvailable := .t.
local n, n1, n2
if Empty( dFrom )
lAvailable := .f.
else
DEFAULT dUpto := dFrom
n1 := ::DateSerial( dFrom )
n2 := ::DateSerial( dUpto )
SwapLoHi( @n1, @n2 )
for n := n1 to n2
if ::aDays[ n ] > 0
lAvailable := .f.
exit
endif
next
endif
return lAvailable
//----------------------------------------------------------------------------//
METHOD ClearSeason( dDate ) CLASS TPickDate
local nDay := ::DateSerial( dDate )
local nSeason, n, nDays := Len( ::aDays )
if nDay > 0
nSeason := ::aDays[ nDay ]
if nSeason > 0
n := nDay
do while n > 0 .and. ::aDays[ n ] == nSeason
::aDays[ n ] := 0
n--
enddo
n := nDay + 1
do while n <= nDays .and. ::aDays[ n ] == nSeason
::aDays[ n ] := 0
n++
enddo
::Refresh()
endif
endif
return nil
//----------------------------------------------------------------------------//
METHOD SeasonColor( nSeasonID, nColor ) CLASS TPickDate
local nLen, nFill
if nSeasonID > ( nLen := Len( ::aSeasonClrs ) )
ASize( ::aSeasonClrs, nSeasonID )
nFill := IfNil( nColor, If( nLen == 0, CLR_YELLOW, ATail( ::aSeasonClrs ) ) )
AFill( ::aSeasonClrs, nFill, nLen + 1, nSeasonID - nLen )
endif
if nColor == nil
nColor := ::aSeasonClrs[ nSeasonID ]
else
if ::aSeasonClrs[ nSeasonID ] != nColor
::aSeasonClrs[ nSeasonID ] := nColor
::Refresh()
endif
endif
return nColor
//----------------------------------------------------------------------------//
METHOD MarkSeason( nSeasonID, dFrom, dUpto, nColor ) CLASS TPickDate
local lRefresh := .f.
local n1, n2, n
nColor := ::SeasonColor( nSeasonID, nColor )
n1 := ::DateSerial( dFrom )
n2 := ::DateSerial( dUpto )
SwapLoHi( @n1, @n2 )
if n1 <= Len( ::aDays ) .and. n2 > 0
n1 := Max( 1, n1 )
n2 := Min( Len( ::aDays ), n2 )
for n := n1 to n2
::aDays[ n ] := nSeasonID
next n
lRefresh := .t.
endif
if lRefresh
::Refresh()
endif
return lRefresh
//----------------------------------------------------------------------------//
METHOD VScroll( nWParam, nLParam ) CLASS TPickDate
local nScrHandle := nLParam
local nScrollCode := nLoWord( nWParam )
local nPos := nHiWord( nWParam )
local nRow, nBook
if GetFocus() != ::hWnd
SetFocus( ::hWnd )
endif
if ::nVisiRows >= 24
return 0
endif
if nScrHandle == 0 .and. ::oVScroll != nil
do case
case nScrollCode == SB_LINEUP
::GoUp()
case nScrollCode == SB_LINEDOWN
::GoDown()
case nScrollCode == SB_PAGEUP
::GoUp() //::PageUp()
case nScrollCode == SB_PAGEDOWN
::GoDown() //::PageDown()
case nScrollCode == SB_TOP
::GoTop()
case nScrollCode == SB_BOTTOM
::GoBottom()
case nScrollCode == SB_THUMBPOSITION .or. ;
nScrollCode == SB_THUMBTRACK
do case
case nPos == 1
::GoTop()
case nPos == ::oVScroll:GetRange()[ 2 ]
::GoBottom()
otherwise
::GoToPos( nPos )
endcase
otherwise
return nil
endcase
endif
return 0
//----------------------------------------------------------------------------//
METHOD HScroll( nWParam, nLParam ) CLASS TPickDate
local nScrHandle := nLParam
local nScrollCode := nLoWord( nWParam )
local nPos := nHiWord( nWParam )
local nRow, nBook
if GetFocus() != ::hWnd
SetFocus( ::hWnd )
endif
if ::nVisiCols >= 38
return 0
endif
if nScrHandle == 0 .and. ::oHScroll != nil
do case
case nScrollCode == SB_LINEUP
::GoLeft()
case nScrollCode == SB_LINEDOWN
::GoRight()
case nScrollCode == SB_PAGEUP
::GoLeft() //::PageUp()
case nScrollCode == SB_PAGEDOWN
::GoRight() //::PageDown()
case nScrollCode == SB_TOP
::GoLeftMost()
case nScrollCode == SB_BOTTOM
::GoRightMost()
case nScrollCode == SB_THUMBPOSITION .or. ;
nScrollCode == SB_THUMBTRACK
do case
case nPos == 1
::GoLeftMost()
case nPos == ::oVScroll:GetRange()[ 2 ]
::GoRightMost()
otherwise
::GoToCol( nPos )
endcase
otherwise
return nil
endcase
endif
return 0
//----------------------------------------------------------------------------//
METHOD MouseWheel( nKeys, nDelta, nXPos, nYPos ) CLASS TPickDate
local aPoint := { nYPos, nXPos }
ScreenToClient( ::hWnd, aPoint )
if IsOverWnd( ::hWnd, aPoint[ 1 ], aPoint[ 2 ] )
if lAnd( nKeys, MK_MBUTTON )
if nDelta > 0
::GoLeft()
else
::GoRight()
endif
else
if nDelta > 0
::GoUp()
else
::GoDown()
endif
endif
endif
Return nil
//----------------------------------------------------------------------------//
//----------------------------------------------------------------------------//
//
// SUPPORT FUNCTIONS FOR THE CLASS
//
//----------------------------------------------------------------------------//
static function ymd2Date( nYear, nMonth, nDay )
DEFAULT nMonth := 1, nDay := 1
do while nMonth > 12
nMonth -= 12
nYear++
enddo
return STOD( Str( nYear, 4 ) + StrZero( nMonth, 2 ) + StrZero( nDay, 2 ) )
//----------------------------------------------------------------------------//
static function IsBetween( u, u1, u2 )
local lBetween := .f.
if u2 >= u1
lBetween := ( u >= u1 .and. u <= u2 )
else
lBetween := ( u >= u2 .and. u <= u1 )
endif
return lBetween
//----------------------------------------------------------------------------//
static function SwapLoHi( u1, u2 )
local u, lSwapped := .f.
if u1 > u2
u := u2
u2 := u1
u1 := u
lSwapped := .t.
endif
return lSwapped
//----------------------------------------------------------------------------//
C. Navarro
Hay dos tipos de personas: las que te hacen perder el tiempo y las que te hacen perder la noción del tiempo
Si alguien te dice que algo no se puede hacer, recuerda que esta hablando de sus limitaciones, no de las tuyas.
Hay dos tipos de personas: las que te hacen perder el tiempo y las que te hacen perder la noción del tiempo
Si alguien te dice que algo no se puede hacer, recuerda que esta hablando de sus limitaciones, no de las tuyas.