*** CALENDAR.prg
*
*      (c) CTS, MRI, DG 1990
*
*      A perpetual Calendar program
*
*=-
*       X,Y are the Top LEFT coordinates of calendar
*             Ranges   X:[ 0 - 13 ]  Y:[ 0 - 45 ]
*       xDATE is the start date for the calendar
*
*          If you always want the calendar at a set place and NOT
*          pass a start date or coordinates then take out the '&&'
*          in the PRIVATE line.
*=-
PRIVATE mTALK,mCENT,mESCA,mCURS,xSTDAY,zxDATE,zX,zY    &&,X,Y,xDATE
*=-
*    If this was called by an ON KEY LABEL Command, you must
*    deactivate the ON KEY LABEL by un-remarking the following
*    line and enter the calling key name at the end of the line
*
   ON KEY LABEL F3
*=-
*
*=-
*      Set up Working Environment
*=-
mTALK=SET('TALK')='ON'
mCENT=SET('CENT')='OFF'
mESCA=SET('ESCA')='ON'
mCURS=SET('CURS')='ON'
SET TALK OFF
SET CENTURY ON
SET CURSOR OFF
SET ESCAPE OFF
IF .NOT. TYPE("xDATE")='D' .OR. {}=xDATE
  IF .NOT. TYPE('xDATE')='U'
    zxDATE=xDATE
  ENDIF
  xDATE=DATE()
ENDIF
IF (.NOT. TYPE("X")='N') .OR. (.NOT. TYPE("Y")='N') .OR. X>13 .OR. Y>45 .or. x<2
  IF .NOT. TYPE('X')='U'
    zX=X
  ENDIF
  IF .NOT. TYPE('Y')='U'
    zY=Y
  ENDIF
  X=12
  Y=45
ENDIF
xSTDAY=0
xCOLOR=LEFT(SET("ATTR"),AT(',',SET("ATTR"))-1)
*=-
*        Define window & shadow for Calendar
*        There is no shadow if you are in another window
*=-
DEFINE WINDOW CALWIN FROM X,Y TO X+10,Y+31 COLOR W+/N,GR+/R,GR+/R
IF ""=WIND()
  @X+1,Y+2 FILL TO X+11,Y+33 COLOR W/N
  mWIND=.T.
ENDIF
*=-
*       Main part of program
*=-
ACTI WIND CALWIN
DO CAL2                       && show calendar for 1st time
DO WHILE .T.
  *=-
  *      if the current month/year display the current day
  *      in a different color and flashing
  *=-
  IF MONTH(xDATE)=MONTH(DATE()) .AND. YEAR(xDATE)=YEAR(DATE())
      @2+((((xSTDAY-1)+DAY(DATE()))-1)/7+1),2+((DOW(DATE())-1)*4) SAY;
      STR(DAY(DATE()),2) COLOR GB+/N*
  ENDIF
  *=-
  *      wait for a key press [refresh every second if no change]
  *      CASE statement is used to change Month/Year
  *=-
  I=INKEY()
  DO CASE
    CASE I=27                 && Escape Key
      EXIT
    CASE I=19 .OR. I=52       && Left Arrow or #4
      xDATE=CTOD(STR(MONTH(xDATE)-1,2)+'/01/'+STR(YEAR(xDATE),4))
    CASE I=4 .OR. I=54        && Right Arrow or #6
      xDATE=CTOD(STR(MONTH(xDATE)+1,2)+'/01/'+STR(YEAR(xDATE),4))
    CASE I=18 .OR. I=57       && PgUp key or #9
      xDATE=CTOD(STR(MONTH(xDATE),2)+'/01/'+STR(YEAR(xDATE)+1,4))
    CASE I=3 .OR. I=51        && PgDn key or #3
      xDATE=CTOD(STR(MONTH(xDATE),2)+'/01/'+STR(YEAR(xDATE)-1,4))
    CASE I=26 .OR. I=55       && Home key or #7
      *=-
      *       let the user go to a specific calendar by
      *       pressing the HOME key and entering a date
      *=-
      xDATE={}
      SET CURSOR ON
      @8,10 SAY "New Date " GET xDATE
      READ
      xDATE=IIF(.NOT. {}=xDATE,xDATE,DATE())
      SET CURSOR OFF
      @8,10 SAY SPAC(20)
    OTHER
      LOOP
  ENDCASE
  DO CAL2                     && refresh calendar with new month
ENDDO
*=-
*      Remove Calendar window & shadow from memory
*=-
RELE WIND CALWIN
IF ""=WIND()
  @X+1,Y+2 FILL TO X+11,Y+33 COLOR &xCOLOR
ENDIF
*=-
*     Restore the Environment to calling programs
*=-
IF .NOT. TYPE('zxDATE')='U'
  xDATE=zXDATE
ENDIF
IF .NOT. TYPE('zX')='U'
  X=zX
ENDIF
IF .NOT. TYPE('zY')='U'
  Y=zY
ENDIF
IF mTALK
  SET TALK ON
ENDIF
IF mCENT
  SET CENTURY OFF
ENDIF
IF mESCA
  SET ESCA ON
ENDIF
IF mCURS
  SET CURS ON
ENDIF
*=-
*    If this was called by an ON KEY LABEL Command, you must
*    Reactivate the ON KEY LABEL by un-remarking the following
*    line and enter the calling key name after LABEL and before
*    the DO CALENDAR part of the command
*
   ON KEY LABEL F3  DO CALENDAR
*=-
*
RETURN
*** End of CALENDAR.prg
*
*=-         Procedures & Functions follow
*
PROC CAL2
PRIVATE xEDDAY
*=-
*        xDATE= variable to hold month/year date to show
*       xSTDAY= the Day of Week to Start the Calendar on
*       xEDDAY= the number of days in the Month (last day)
*
*=-
xSTDAY=DOW(xDATE-DAY(xDATE)+1)
xEDDAY=DAY(CTOD(STR(MONTH(xDATE)+1,2)+'/01/'+STR(YEAR(xDATE),4))-1)
*=-
*      Put Month and Week day heading at top of window
*=-
@0,0 SAY SPAC(10)+LEFT(CMONTH(xDATE),3)+". "+;
     STR(YEAR(xDATE),4)+SPAC(10) COLO G+/N
@1,0 SAY ' Sun Mon Tue Wed Thu Fri Sat ' COLO GR+/N
?
*=-
*      get and display the appropriate calendar for the current
*      Month and Year [based on the start day of week and the
*      number of days in the month]
*=-
DO CASE
  CASE xSTDAY=1 .AND. xEDDAY=28
      *         1         2
      *1234567890123456789012345678
    ? '   1   2   3   4   5   6   7'
    ? '   8   9  10  11  12  13  14'
    ? '  15  16  17  18  19  20  21'
    ? '  22  23  24  25  26  27  28'
    ? '                            '
    ? '                            '
  CASE xSTDAY=1 .AND. xEDDAY=29
    ? '   1   2   3   4   5   6   7'
    ? '   8   9  10  11  12  13  14'
    ? '  15  16  17  18  19  20  21'
    ? '  22  23  24  25  26  27  28'
    ? '  29                        '
    ? '                            '
  CASE xSTDAY=1 .AND. xEDDAY=30
    ? '   1   2   3   4   5   6   7'
    ? '   8   9  10  11  12  13  14'
    ? '  15  16  17  18  19  20  21'
    ? '  22  23  24  25  26  27  28'
    ? '  29  30                    '
    ? '                            '
  CASE xSTDAY=1 .AND. xEDDAY=31
    ? '   1   2   3   4   5   6   7'
    ? '   8   9  10  11  12  13  14'
    ? '  15  16  17  18  19  20  21'
    ? '  22  23  24  25  26  27  28'
    ? '  29  30  31                '
    ? '                            '
  CASE xSTDAY=2 .AND. xEDDAY=28
    ? '       1   2   3   4   5   6'
    ? '   7   8   9  10  11  12  13'
    ? '  14  15  16  17  18  19  20'
    ? '  21  22  23  24  25  26  27'
    ? '  28                        '
    ? '                            '
  CASE xSTDAY=2 .AND. xEDDAY=29
    ? '       1   2   3   4   5   6'
    ? '   7   8   9  10  11  12  13'
    ? '  14  15  16  17  18  19  20'
    ? '  21  22  23  24  25  26  27'
    ? '  28  29                    '
    ? '                            '
  CASE xSTDAY=2 .AND. xEDDAY=30
    ? '       1   2   3   4   5   6'
    ? '   7   8   9  10  11  12  13'
    ? '  14  15  16  17  18  19  20'
    ? '  21  22  23  24  25  26  27'
    ? '  28  29  30                '
    ? '                            '
  CASE xSTDAY=2 .AND. xEDDAY=31
    ? '       1   2   3   4   5   6'
    ? '   7   8   9  10  11  12  13'
    ? '  14  15  16  17  18  19  20'
    ? '  21  22  23  24  25  26  27'
    ? '  28  29  30  31            '
    ? '                            '
  CASE xSTDAY=3 .AND. xEDDAY=28
    ? '           1   2   3   4   5'
    ? '   6   7   8   9  10  11  12'
    ? '  13  14  15  16  17  18  19'
    ? '  20  21  22  23  24  25  26'
    ? '  27  28                    '
    ? '                            '
  CASE xSTDAY=3 .AND. xEDDAY=29
    ? '           1   2   3   4   5'
    ? '   6   7   8   9  10  11  12'
    ? '  13  14  15  16  17  18  19'
    ? '  20  21  22  23  24  25  26'
    ? '  27  28  29                '
    ? '                            '
  CASE xSTDAY=3 .AND. xEDDAY=30
    ? '           1   2   3   4   5'
    ? '   6   7   8   9  10  11  12'
    ? '  13  14  15  16  17  18  19'
    ? '  20  21  22  23  24  25  26'
    ? '  27  28  29  30            '
    ? '                            '
  CASE xSTDAY=3 .AND. xEDDAY=31
    ? '           1   2   3   4   5'
    ? '   6   7   8   9  10  11  12'
    ? '  13  14  15  16  17  18  19'
    ? '  20  21  22  23  24  25  26'
    ? '  27  28  29  30  31        '
    ? '                            '
  CASE xSTDAY=4 .AND. xEDDAY=28
    ? '               1   2   3   4'
    ? '   5   6   7   8   9  10  11'
    ? '  12  13  14  15  16  17  18'
    ? '  19  20  21  22  23  24  25'
    ? '  26  27  28                '
    ? '                            '
  CASE xSTDAY=4 .AND. xEDDAY=29
    ? '               1   2   3   4'
    ? '   5   6   7   8   9  10  11'
    ? '  12  13  14  15  16  17  18'
    ? '  19  20  21  22  23  24  25'
    ? '  26  27  28  29            '
    ? '                            '
  CASE xSTDAY=4 .AND. xEDDAY=30
    ? '               1   2   3   4'
    ? '   5   6   7   8   9  10  11'
    ? '  12  13  14  15  16  17  18'
    ? '  19  20  21  22  23  24  25'
    ? '  26  27  28  29  30        '
    ? '                            '
  CASE xSTDAY=4 .AND. xEDDAY=31
    ? '               1   2   3   4'
    ? '   5   6   7   8   9  10  11'
    ? '  12  13  14  15  16  17  18'
    ? '  19  20  21  22  23  24  25'
    ? '  26  27  28  29  30  31    '
    ? '                            '
  CASE xSTDAY=5 .AND. xEDDAY=28
    ? '                   1   2   3'
    ? '   4   5   6   7   8   9  10'
    ? '  11  12  13  14  15  16  17'
    ? '  18  19  20  21  22  23  24'
    ? '  25  26  27  28            '
    ? '                            '
  CASE xSTDAY=5 .AND. xEDDAY=29
    ? '                   1   2   3'
    ? '   4   5   6   7   8   9  10'
    ? '  11  12  13  14  15  16  17'
    ? '  18  19  20  21  22  23  24'
    ? '  25  26  27  28  29        '
    ? '                            '
  CASE xSTDAY=5 .AND. xEDDAY=30
    ? '                   1   2   3'
    ? '   4   5   6   7   8   9  10'
    ? '  11  12  13  14  15  16  17'
    ? '  18  19  20  21  22  23  24'
    ? '  25  26  27  28  29  30    '
    ? '                            '
  CASE xSTDAY=5 .AND. xEDDAY=31
    ? '                   1   2   3'
    ? '   4   5   6   7   8   9  10'
    ? '  11  12  13  14  15  16  17'
    ? '  18  19  20  21  22  23  24'
    ? '  25  26  27  28  29  30  31'
    ? '                            '
  CASE xSTDAY=6 .AND. xEDDAY=28
    ? '                       1   2'
    ? '   3   4   5   6   7   8   9'
    ? '  10  11  12  13  14  15  16'
    ? '  17  18  19  20  21  22  23'
    ? '  24  25  26  27  28        '
    ? '                            '
  CASE xSTDAY=6 .AND. xEDDAY=29
    ? '                       1   2'
    ? '   3   4   5   6   7   8   9'
    ? '  10  11  12  13  14  15  16'
    ? '  17  18  19  20  21  22  23'
    ? '  24  25  26  27  28  29    '
    ? '                            '
  CASE xSTDAY=6 .AND. xEDDAY=30
    ? '                       1   2'
    ? '   3   4   5   6   7   8   9'
    ? '  10  11  12  13  14  15  16'
    ? '  17  18  19  20  21  22  23'
    ? '  24  25  26  27  28  29  30'
    ? '                            '
  CASE xSTDAY=6 .AND. xEDDAY=31
    ? '                       1   2'
    ? '   3   4   5   6   7   8   9'
    ? '  10  11  12  13  14  15  16'
    ? '  17  18  19  20  21  22  23'
    ? '  24  25  26  27  28  29  30'
    ? '  31                        '
  CASE xSTDAY=7 .AND. xEDDAY=28
    ? '                           1'
    ? '   2   3   4   5   6   7   8'
    ? '   9  10  11  12  13  14  15'
    ? '  16  17  18  19  20  21  22'
    ? '  23  24  25  26  27  28    '
    ? '                            '
  CASE xSTDAY=7 .AND. xEDDAY=29
    ? '                           1'
    ? '   2   3   4   5   6   7   8'
    ? '   9  10  11  12  13  14  15'
    ? '  16  17  18  19  20  21  22'
    ? '  23  24  25  26  27  28  29'
    ? '                            '
  CASE xSTDAY=7 .AND. xEDDAY=30
    ? '                           1'
    ? '   2   3   4   5   6   7   8'
    ? '   9  10  11  12  13  14  15'
    ? '  16  17  18  19  20  21  22'
    ? '  23  24  25  26  27  28  29'
    ? '  30                        '
  CASE xSTDAY=7 .AND. xEDDAY=31
    ? '                           1'
    ? '   2   3   4   5   6   7   8'
    ? '   9  10  11  12  13  14  15'
    ? '  16  17  18  19  20  21  22'
    ? '  23  24  25  26  27  28  29'
    ? '  30  31                    '
ENDCASE
RETURN
*=- End of Procedures
*