home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
clockcal.zip
/
CALENDAR.PRG
< prev
next >
Wrap
Text File
|
1991-01-11
|
12KB
|
380 lines
*** 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
*