home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / clockcal.zip / CALENDAR.PRG < prev    next >
Text File  |  1991-01-11  |  12KB  |  380 lines
  1. *** CALENDAR.prg
  2. *
  3. *      (c) CTS, MRI, DG 1990
  4. *
  5. *      A perpetual Calendar program
  6. *
  7. *=-
  8. *       X,Y are the Top LEFT coordinates of calendar
  9. *             Ranges   X:[ 0 - 13 ]  Y:[ 0 - 45 ]
  10. *       xDATE is the start date for the calendar
  11. *
  12. *          If you always want the calendar at a set place and NOT
  13. *          pass a start date or coordinates then take out the '&&'
  14. *          in the PRIVATE line.
  15. *=-
  16. PRIVATE mTALK,mCENT,mESCA,mCURS,xSTDAY,zxDATE,zX,zY    &&,X,Y,xDATE
  17. *=-
  18. *    If this was called by an ON KEY LABEL Command, you must
  19. *    deactivate the ON KEY LABEL by un-remarking the following
  20. *    line and enter the calling key name at the end of the line
  21. *
  22.    ON KEY LABEL F3
  23. *=-
  24. *
  25. *=-
  26. *      Set up Working Environment
  27. *=-
  28. mTALK=SET('TALK')='ON'
  29. mCENT=SET('CENT')='OFF'
  30. mESCA=SET('ESCA')='ON'
  31. mCURS=SET('CURS')='ON'
  32. SET TALK OFF
  33. SET CENTURY ON
  34. SET CURSOR OFF
  35. SET ESCAPE OFF
  36. IF .NOT. TYPE("xDATE")='D' .OR. {}=xDATE
  37.   IF .NOT. TYPE('xDATE')='U'
  38.     zxDATE=xDATE
  39.   ENDIF
  40.   xDATE=DATE()
  41. ENDIF
  42. IF (.NOT. TYPE("X")='N') .OR. (.NOT. TYPE("Y")='N') .OR. X>13 .OR. Y>45 .or. x<2
  43.   IF .NOT. TYPE('X')='U'
  44.     zX=X
  45.   ENDIF
  46.   IF .NOT. TYPE('Y')='U'
  47.     zY=Y
  48.   ENDIF
  49.   X=12
  50.   Y=45
  51. ENDIF
  52. xSTDAY=0
  53. xCOLOR=LEFT(SET("ATTR"),AT(',',SET("ATTR"))-1)
  54. *=-
  55. *        Define window & shadow for Calendar
  56. *        There is no shadow if you are in another window
  57. *=-
  58. DEFINE WINDOW CALWIN FROM X,Y TO X+10,Y+31 COLOR W+/N,GR+/R,GR+/R
  59. IF ""=WIND()
  60.   @X+1,Y+2 FILL TO X+11,Y+33 COLOR W/N
  61.   mWIND=.T.
  62. ENDIF
  63. *=-
  64. *       Main part of program
  65. *=-
  66. ACTI WIND CALWIN
  67. DO CAL2                       && show calendar for 1st time
  68. DO WHILE .T.
  69.   *=-
  70.   *      if the current month/year display the current day
  71.   *      in a different color and flashing
  72.   *=-
  73.   IF MONTH(xDATE)=MONTH(DATE()) .AND. YEAR(xDATE)=YEAR(DATE())
  74.       @2+((((xSTDAY-1)+DAY(DATE()))-1)/7+1),2+((DOW(DATE())-1)*4) SAY;
  75.       STR(DAY(DATE()),2) COLOR GB+/N*
  76.   ENDIF
  77.   *=-
  78.   *      wait for a key press [refresh every second if no change]
  79.   *      CASE statement is used to change Month/Year
  80.   *=-
  81.   I=INKEY()
  82.   DO CASE
  83.     CASE I=27                 && Escape Key
  84.       EXIT
  85.     CASE I=19 .OR. I=52       && Left Arrow or #4
  86.       xDATE=CTOD(STR(MONTH(xDATE)-1,2)+'/01/'+STR(YEAR(xDATE),4))
  87.     CASE I=4 .OR. I=54        && Right Arrow or #6
  88.       xDATE=CTOD(STR(MONTH(xDATE)+1,2)+'/01/'+STR(YEAR(xDATE),4))
  89.     CASE I=18 .OR. I=57       && PgUp key or #9
  90.       xDATE=CTOD(STR(MONTH(xDATE),2)+'/01/'+STR(YEAR(xDATE)+1,4))
  91.     CASE I=3 .OR. I=51        && PgDn key or #3
  92.       xDATE=CTOD(STR(MONTH(xDATE),2)+'/01/'+STR(YEAR(xDATE)-1,4))
  93.     CASE I=26 .OR. I=55       && Home key or #7
  94.       *=-
  95.       *       let the user go to a specific calendar by
  96.       *       pressing the HOME key and entering a date
  97.       *=-
  98.       xDATE={}
  99.       SET CURSOR ON
  100.       @8,10 SAY "New Date " GET xDATE
  101.       READ
  102.       xDATE=IIF(.NOT. {}=xDATE,xDATE,DATE())
  103.       SET CURSOR OFF
  104.       @8,10 SAY SPAC(20)
  105.     OTHER
  106.       LOOP
  107.   ENDCASE
  108.   DO CAL2                     && refresh calendar with new month
  109. ENDDO
  110. *=-
  111. *      Remove Calendar window & shadow from memory
  112. *=-
  113. RELE WIND CALWIN
  114. IF ""=WIND()
  115.   @X+1,Y+2 FILL TO X+11,Y+33 COLOR &xCOLOR
  116. ENDIF
  117. *=-
  118. *     Restore the Environment to calling programs
  119. *=-
  120. IF .NOT. TYPE('zxDATE')='U'
  121.   xDATE=zXDATE
  122. ENDIF
  123. IF .NOT. TYPE('zX')='U'
  124.   X=zX
  125. ENDIF
  126. IF .NOT. TYPE('zY')='U'
  127.   Y=zY
  128. ENDIF
  129. IF mTALK
  130.   SET TALK ON
  131. ENDIF
  132. IF mCENT
  133.   SET CENTURY OFF
  134. ENDIF
  135. IF mESCA
  136.   SET ESCA ON
  137. ENDIF
  138. IF mCURS
  139.   SET CURS ON
  140. ENDIF
  141. *=-
  142. *    If this was called by an ON KEY LABEL Command, you must
  143. *    Reactivate the ON KEY LABEL by un-remarking the following
  144. *    line and enter the calling key name after LABEL and before
  145. *    the DO CALENDAR part of the command
  146. *
  147.    ON KEY LABEL F3  DO CALENDAR
  148. *=-
  149. *
  150. RETURN
  151. *** End of CALENDAR.prg
  152. *
  153. *=-         Procedures & Functions follow
  154. *
  155. PROC CAL2
  156. PRIVATE xEDDAY
  157. *=-
  158. *        xDATE= variable to hold month/year date to show
  159. *       xSTDAY= the Day of Week to Start the Calendar on
  160. *       xEDDAY= the number of days in the Month (last day)
  161. *
  162. *=-
  163. xSTDAY=DOW(xDATE-DAY(xDATE)+1)
  164. xEDDAY=DAY(CTOD(STR(MONTH(xDATE)+1,2)+'/01/'+STR(YEAR(xDATE),4))-1)
  165. *=-
  166. *      Put Month and Week day heading at top of window
  167. *=-
  168. @0,0 SAY SPAC(10)+LEFT(CMONTH(xDATE),3)+". "+;
  169.      STR(YEAR(xDATE),4)+SPAC(10) COLO G+/N
  170. @1,0 SAY ' Sun Mon Tue Wed Thu Fri Sat ' COLO GR+/N
  171. ?
  172. *=-
  173. *      get and display the appropriate calendar for the current
  174. *      Month and Year [based on the start day of week and the
  175. *      number of days in the month]
  176. *=-
  177. DO CASE
  178.   CASE xSTDAY=1 .AND. xEDDAY=28
  179.       *         1         2
  180.       *1234567890123456789012345678
  181.     ? '   1   2   3   4   5   6   7'
  182.     ? '   8   9  10  11  12  13  14'
  183.     ? '  15  16  17  18  19  20  21'
  184.     ? '  22  23  24  25  26  27  28'
  185.     ? '                            '
  186.     ? '                            '
  187.   CASE xSTDAY=1 .AND. xEDDAY=29
  188.     ? '   1   2   3   4   5   6   7'
  189.     ? '   8   9  10  11  12  13  14'
  190.     ? '  15  16  17  18  19  20  21'
  191.     ? '  22  23  24  25  26  27  28'
  192.     ? '  29                        '
  193.     ? '                            '
  194.   CASE xSTDAY=1 .AND. xEDDAY=30
  195.     ? '   1   2   3   4   5   6   7'
  196.     ? '   8   9  10  11  12  13  14'
  197.     ? '  15  16  17  18  19  20  21'
  198.     ? '  22  23  24  25  26  27  28'
  199.     ? '  29  30                    '
  200.     ? '                            '
  201.   CASE xSTDAY=1 .AND. xEDDAY=31
  202.     ? '   1   2   3   4   5   6   7'
  203.     ? '   8   9  10  11  12  13  14'
  204.     ? '  15  16  17  18  19  20  21'
  205.     ? '  22  23  24  25  26  27  28'
  206.     ? '  29  30  31                '
  207.     ? '                            '
  208.   CASE xSTDAY=2 .AND. xEDDAY=28
  209.     ? '       1   2   3   4   5   6'
  210.     ? '   7   8   9  10  11  12  13'
  211.     ? '  14  15  16  17  18  19  20'
  212.     ? '  21  22  23  24  25  26  27'
  213.     ? '  28                        '
  214.     ? '                            '
  215.   CASE xSTDAY=2 .AND. xEDDAY=29
  216.     ? '       1   2   3   4   5   6'
  217.     ? '   7   8   9  10  11  12  13'
  218.     ? '  14  15  16  17  18  19  20'
  219.     ? '  21  22  23  24  25  26  27'
  220.     ? '  28  29                    '
  221.     ? '                            '
  222.   CASE xSTDAY=2 .AND. xEDDAY=30
  223.     ? '       1   2   3   4   5   6'
  224.     ? '   7   8   9  10  11  12  13'
  225.     ? '  14  15  16  17  18  19  20'
  226.     ? '  21  22  23  24  25  26  27'
  227.     ? '  28  29  30                '
  228.     ? '                            '
  229.   CASE xSTDAY=2 .AND. xEDDAY=31
  230.     ? '       1   2   3   4   5   6'
  231.     ? '   7   8   9  10  11  12  13'
  232.     ? '  14  15  16  17  18  19  20'
  233.     ? '  21  22  23  24  25  26  27'
  234.     ? '  28  29  30  31            '
  235.     ? '                            '
  236.   CASE xSTDAY=3 .AND. xEDDAY=28
  237.     ? '           1   2   3   4   5'
  238.     ? '   6   7   8   9  10  11  12'
  239.     ? '  13  14  15  16  17  18  19'
  240.     ? '  20  21  22  23  24  25  26'
  241.     ? '  27  28                    '
  242.     ? '                            '
  243.   CASE xSTDAY=3 .AND. xEDDAY=29
  244.     ? '           1   2   3   4   5'
  245.     ? '   6   7   8   9  10  11  12'
  246.     ? '  13  14  15  16  17  18  19'
  247.     ? '  20  21  22  23  24  25  26'
  248.     ? '  27  28  29                '
  249.     ? '                            '
  250.   CASE xSTDAY=3 .AND. xEDDAY=30
  251.     ? '           1   2   3   4   5'
  252.     ? '   6   7   8   9  10  11  12'
  253.     ? '  13  14  15  16  17  18  19'
  254.     ? '  20  21  22  23  24  25  26'
  255.     ? '  27  28  29  30            '
  256.     ? '                            '
  257.   CASE xSTDAY=3 .AND. xEDDAY=31
  258.     ? '           1   2   3   4   5'
  259.     ? '   6   7   8   9  10  11  12'
  260.     ? '  13  14  15  16  17  18  19'
  261.     ? '  20  21  22  23  24  25  26'
  262.     ? '  27  28  29  30  31        '
  263.     ? '                            '
  264.   CASE xSTDAY=4 .AND. xEDDAY=28
  265.     ? '               1   2   3   4'
  266.     ? '   5   6   7   8   9  10  11'
  267.     ? '  12  13  14  15  16  17  18'
  268.     ? '  19  20  21  22  23  24  25'
  269.     ? '  26  27  28                '
  270.     ? '                            '
  271.   CASE xSTDAY=4 .AND. xEDDAY=29
  272.     ? '               1   2   3   4'
  273.     ? '   5   6   7   8   9  10  11'
  274.     ? '  12  13  14  15  16  17  18'
  275.     ? '  19  20  21  22  23  24  25'
  276.     ? '  26  27  28  29            '
  277.     ? '                            '
  278.   CASE xSTDAY=4 .AND. xEDDAY=30
  279.     ? '               1   2   3   4'
  280.     ? '   5   6   7   8   9  10  11'
  281.     ? '  12  13  14  15  16  17  18'
  282.     ? '  19  20  21  22  23  24  25'
  283.     ? '  26  27  28  29  30        '
  284.     ? '                            '
  285.   CASE xSTDAY=4 .AND. xEDDAY=31
  286.     ? '               1   2   3   4'
  287.     ? '   5   6   7   8   9  10  11'
  288.     ? '  12  13  14  15  16  17  18'
  289.     ? '  19  20  21  22  23  24  25'
  290.     ? '  26  27  28  29  30  31    '
  291.     ? '                            '
  292.   CASE xSTDAY=5 .AND. xEDDAY=28
  293.     ? '                   1   2   3'
  294.     ? '   4   5   6   7   8   9  10'
  295.     ? '  11  12  13  14  15  16  17'
  296.     ? '  18  19  20  21  22  23  24'
  297.     ? '  25  26  27  28            '
  298.     ? '                            '
  299.   CASE xSTDAY=5 .AND. xEDDAY=29
  300.     ? '                   1   2   3'
  301.     ? '   4   5   6   7   8   9  10'
  302.     ? '  11  12  13  14  15  16  17'
  303.     ? '  18  19  20  21  22  23  24'
  304.     ? '  25  26  27  28  29        '
  305.     ? '                            '
  306.   CASE xSTDAY=5 .AND. xEDDAY=30
  307.     ? '                   1   2   3'
  308.     ? '   4   5   6   7   8   9  10'
  309.     ? '  11  12  13  14  15  16  17'
  310.     ? '  18  19  20  21  22  23  24'
  311.     ? '  25  26  27  28  29  30    '
  312.     ? '                            '
  313.   CASE xSTDAY=5 .AND. xEDDAY=31
  314.     ? '                   1   2   3'
  315.     ? '   4   5   6   7   8   9  10'
  316.     ? '  11  12  13  14  15  16  17'
  317.     ? '  18  19  20  21  22  23  24'
  318.     ? '  25  26  27  28  29  30  31'
  319.     ? '                            '
  320.   CASE xSTDAY=6 .AND. xEDDAY=28
  321.     ? '                       1   2'
  322.     ? '   3   4   5   6   7   8   9'
  323.     ? '  10  11  12  13  14  15  16'
  324.     ? '  17  18  19  20  21  22  23'
  325.     ? '  24  25  26  27  28        '
  326.     ? '                            '
  327.   CASE xSTDAY=6 .AND. xEDDAY=29
  328.     ? '                       1   2'
  329.     ? '   3   4   5   6   7   8   9'
  330.     ? '  10  11  12  13  14  15  16'
  331.     ? '  17  18  19  20  21  22  23'
  332.     ? '  24  25  26  27  28  29    '
  333.     ? '                            '
  334.   CASE xSTDAY=6 .AND. xEDDAY=30
  335.     ? '                       1   2'
  336.     ? '   3   4   5   6   7   8   9'
  337.     ? '  10  11  12  13  14  15  16'
  338.     ? '  17  18  19  20  21  22  23'
  339.     ? '  24  25  26  27  28  29  30'
  340.     ? '                            '
  341.   CASE xSTDAY=6 .AND. xEDDAY=31
  342.     ? '                       1   2'
  343.     ? '   3   4   5   6   7   8   9'
  344.     ? '  10  11  12  13  14  15  16'
  345.     ? '  17  18  19  20  21  22  23'
  346.     ? '  24  25  26  27  28  29  30'
  347.     ? '  31                        '
  348.   CASE xSTDAY=7 .AND. xEDDAY=28
  349.     ? '                           1'
  350.     ? '   2   3   4   5   6   7   8'
  351.     ? '   9  10  11  12  13  14  15'
  352.     ? '  16  17  18  19  20  21  22'
  353.     ? '  23  24  25  26  27  28    '
  354.     ? '                            '
  355.   CASE xSTDAY=7 .AND. xEDDAY=29
  356.     ? '                           1'
  357.     ? '   2   3   4   5   6   7   8'
  358.     ? '   9  10  11  12  13  14  15'
  359.     ? '  16  17  18  19  20  21  22'
  360.     ? '  23  24  25  26  27  28  29'
  361.     ? '                            '
  362.   CASE xSTDAY=7 .AND. xEDDAY=30
  363.     ? '                           1'
  364.     ? '   2   3   4   5   6   7   8'
  365.     ? '   9  10  11  12  13  14  15'
  366.     ? '  16  17  18  19  20  21  22'
  367.     ? '  23  24  25  26  27  28  29'
  368.     ? '  30                        '
  369.   CASE xSTDAY=7 .AND. xEDDAY=31
  370.     ? '                           1'
  371.     ? '   2   3   4   5   6   7   8'
  372.     ? '   9  10  11  12  13  14  15'
  373.     ? '  16  17  18  19  20  21  22'
  374.     ? '  23  24  25  26  27  28  29'
  375.     ? '  30  31                    '
  376. ENDCASE
  377. RETURN
  378. *=- End of Procedures
  379. *
  380.