How to achieve this kind of calendar control?

[hua]

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

[wmanesco]

Maybe it helps,

viewtopic.php?f=3&t=33022&p=196639&hilit=google+calendar#p196639

[Otto]

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

Code: Select all  Expand view

#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

//----------------------------------------------------------------------------//


 

[Antonio Linares]

Dear Otto,

Many thanks for this great sharing

[hua]

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

[richard-service]

Hi Otto,

Good job and thanks a lot for share code.

[Marc Venken]

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 ?

[Marc Venken]

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

Code: Select all  Expand view

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 )
 

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

[Antonio Linares]

Marc,

return ::Super:MouseMove( nRow, nCol, nKeyFlags )

[Marc Venken]

Thank you.

I had to change all Super like Antonio said. Now it works for me.

[James Bott]

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

[Marc Venken]

James,

Thanks for the explanation.

Marc

[cnavarro]

Added datas for colors lines and others

Code: Select all  Expand view

#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

//----------------------------------------------------------------------------//