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
//----------------------------------------------------------------------------//
