home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / CLIPPER / NFSRC.ZIP / CALENDAR.PRG < prev    next >
Encoding:
Text File  |  1991-08-16  |  7.2 KB  |  235 lines
  1. /*
  2.  * File......: CALENDAR.PRG
  3.  * Author....: Isa Asudeh
  4.  * CIS ID....: 76477,647
  5.  * Date......: $Date:   15 Aug 1991 23:05:24  $
  6.  * Revision..: $Revision:   1.1  $
  7.  * Log file..: $Logfile:   E:/nanfor/src/calendar.prv  $
  8.  * 
  9.  * This is an original work by Isa Asudeh and is placed in the
  10.  * public domain.
  11.  *
  12.  * Modification history
  13.  * --------------------
  14.  *
  15.  * $Log:   E:/nanfor/src/calendar.prv  $
  16.  * 
  17.  *    Rev 1.1   15 Aug 1991 23:05:24   GLENN
  18.  * Forest Belt proofread/edited/cleaned up doc
  19.  * 
  20.  *    Rev 1.0   31 May 1991 21:07:26   GLENN
  21.  * Initial revision.
  22.  *
  23.  */
  24.  
  25.  
  26.  
  27. /*  $DOC$
  28.  *  $FUNCNAME$
  29.  *     FT_CALENDAR()
  30.  *  $CATEGORY$
  31.  *     Date/Time
  32.  *  $ONELINER$
  33.  *     Display date/time calendar, find a date, return calendar data.
  34.  *  $SYNTAX$
  35.  *     FT_CALENDAR ( [ <nRow> ], [ <nCol> ], [ <cColor> ], [ <lShadow> ] ,
  36.  *                   [ <lShowHelp> ] ) -> aRetVal
  37.  *  $ARGUMENTS$
  38.  *
  39.  *     <nRow> is an optional screen row for calendar display,
  40.  *            default row 1.
  41.  *
  42.  *     <nCol> is an optional screen col for calendar display,
  43.  *            default col 63.
  44.  *
  45.  *     <cColor> is an optional color string for displayed messages,
  46.  *              default is bright white text over green background.
  47.  *
  48.  *     <lShadow> is an optional logical variable. If true (.T.),
  49.  *               it uses FT_SHADOW() to add a transparent shadow
  50.  *               to the display, default (.F.).
  51.  *
  52.  *     <lShowHelp> is an optional logical variable. If true, uses
  53.  *                 FT_XBOX to display  a four line help message
  54.  *                 if the F1 key is pressed, default (.F.).
  55.  *
  56.  *  $RETURNS$
  57.  *     aRetVal  is an 8 element array containing date, month, day, year,
  58.  *              month (in character format), day of the week, julian day
  59.  *              and current time.
  60.  *
  61.  *  $DESCRIPTION$
  62.  *     FT_CALENDAR() simply displays today's date, time and julian
  63.  *     day in a two line display with an optional box shadow. Cursor keys may
  64.  *     be used to page through the calendar by day, week, month or year 
  65.  *     increments. Returns an 8 element array of calendar data:
  66.  *
  67.  *     Element  Value
  68.  *     [1]      Date in current date format.
  69.  *     [2]      Numeric month number.
  70.  *     [3]      Numeric day number.
  71.  *     [4]      Numeric year number.
  72.  *     [5]      Month in character format.
  73.  *     [6]      Day of the week in character format.
  74.  *     [7]      Numeric Julian day.
  75.  *     [8]      Current time in time format.
  76.  *
  77.  *     WARNING: FT_CALENDAR uses FT_SHADOW and FT_XBOX
  78.  *              from the Nanforum Toolkit!
  79.  *
  80.  *  $EXAMPLES$
  81.  *
  82.  *   LOCAL aRetVal[8]
  83.  *   CLS
  84.  *   aRetVal := FT_CALENDAR (10,40,'W+/RB',.T.,.T.) 
  85.  *   ?aRetVal[1]      // Result: 04/20/91
  86.  *   ?aRetVal[2]      // Result:   4
  87.  *   ?aRetVal[3]      // Result:  20
  88.  *   ?aRetVal[4]      // Result:  1991
  89.  *   ?aRetVal[5]      // Result: April
  90.  *   ?aRetVal[6]      // Result: Saturday
  91.  *   ?aRetVal[7]      // Result:        110
  92.  *   ?aRetVal[8]      // Result: 12:45:20
  93.  *
  94.  *  $SEEALSO$
  95.  *     FT_DAYOFYR()
  96.  *
  97.  *  $END$
  98.  */
  99.  
  100. #ifdef FT_TEST
  101.   FUNCTION MAIN()
  102.    local aRet[8], i
  103.    setcolor ('w+/b')
  104.    cls
  105.    if ft_numlock()
  106.      ft_numlock( .f. )
  107.    endif
  108.    keyboard chr (28)
  109.    aRet := ft_calendar (10,40,'w+/rb',.t.,.t.) //display calendar, return all.
  110.    @1,0 say 'Date        :'+dtoc(aRet[1])
  111.    @2,0 say 'Month Number:'+str(aRet[2],2,0)
  112.    @3,0 say 'Day Number  :'+str(aRet[3],2,0)
  113.    @4,0 say 'Year Number :'+str(aRet[4],4,0)
  114.    @5,0 say 'Month       :'+aRet[5]
  115.    @6,0 say 'Day         :'+aRet[6]
  116.    @7,0 say 'Julian Day  :'+str(aRet[7],3,0)
  117.    @8,0 say 'Current Time:'+aRet[8]
  118.    return ( nil )
  119. #endif
  120.  
  121.  
  122. #include "INKEY.CH"
  123.  
  124. FUNCTION FT_CALENDAR (nRow, nCol, cColor, lShadow, lShowHelp)
  125.  
  126.  LOCAL  nJump :=0, nKey :=0, cSavColor, cSaveScreen, cSaveCursor
  127.  LOCAL  aRetVal[8]
  128.  LOCAL  nHelpRow, cSaveHelp, lHelpIsDisplayed :=.F.
  129.  
  130.  nRow    := IIF ( nRow <> NIL, nRow, 1 )           //check display row
  131.  nCol    := IIF ( nCol <> NIL, nCol, 63)           //check display col
  132.  cColor  := IIF ( cColor <> NIL, cColor, 'W+/G' )  //check display color
  133.  lShadow := IIF ( lShadow == NIL , .F., lShadow )  //check shadow switch
  134.  lShowHelp := IIF ( lShowHelp == NIL , .F., lShowHelp )//check help switch
  135.  
  136.  nRow := IIF ( nRow <1 .OR. nRow >21,  1, nRow )   //check row bounds
  137.  nCol := IIF ( nCol <1 .OR. nCol >63, 63, nCol )   //check col bounds
  138.  
  139.  cSavColor   := SETCOLOR(cColor)  //save current and set display color
  140.  cSaveScreen := SAVESCREEN ( nRow-1, nCol-1, nRow+3, nCol+17 ) //save screen
  141.  cSaveCursor := SETCURSOR (0)     // save current and turn off cursor
  142.  
  143.  IF lShadow 
  144.     @nRow-1,nCol-1 to nRow+2, nCol+15
  145.     FT_SHADOW( nRow-1, nCol-1, nRow+2, nCol+15 )
  146.  ENDIF
  147.  
  148.  IF lShowHelp
  149.    nHelpRow := IIF (nRow > 10 , nRow - 10 , nRow + 6 )
  150.  ENDIF
  151.  
  152.  DO WHILE nKey <> K_ESC
  153.  
  154.     DO CASE
  155.     CASE nKey == K_HOME
  156.        nJump = nJump - 1 
  157.  
  158.     CASE nKey == K_END
  159.        nJump = nJump + 1 
  160.  
  161.     CASE nKey == K_UP
  162.        nJump = nJump - 30
  163.  
  164.     CASE nKey == K_DOWN
  165.        nJump = nJump + 30
  166.  
  167.     CASE nKey == K_PGUP
  168.        nJump = nJump - 365
  169.  
  170.     CASE nKey == K_PGDN
  171.        nJump = nJump + 365
  172.  
  173.     CASE nKey == K_RIGHT
  174.        nJump = nJump - 7
  175.  
  176.     CASE nKey == K_LEFT
  177.        nJump = nJump + 7
  178.  
  179.     CASE nKey == K_INS
  180.        nJump = 0
  181.  
  182.     CASE nKey == K_F1  
  183.        IF lShowHelp .AND. .NOT. lHelpIsDisplayed
  184.           lHelpIsDisplayed := .T.
  185.           cSaveHelp := SAVESCREEN ( nHelpRow-1, 1, nHelpRow+7, 80)
  186.           FT_XBOX('L',,,cColor,cColor,nHelpRow,1,;
  187.  "Home, Up_Arrow or PgUp keys page by day, month or year to a past date.",;
  188.  "End, Dn_Arrow or PgDn keys page by day, month or year to a future date.",;
  189.  "Left_Arrow or Right_Arrow keys page by week to a past or future date.",;
  190.  "Hit Ins to reset to today's date, F1 to get this help, ESC to quit.")
  191.        ENDIF
  192.  
  193.     OTHERWISE
  194.     ENDCASE
  195.  
  196.  aRetVal[1] :=         DATE() + nJump  
  197.  aRetVal[2] :=  MONTH( DATE() + nJump )
  198.  aRetVal[3] :=    DAY( DATE() + nJump )
  199.  aRetVal[4] :=   YEAR( DATE() + nJump )
  200.  aRetVal[5] := CMONTH( DATE() + nJump )
  201.  aRetVal[6] :=   CDOW( DATE() + nJump )
  202.  aRetVal[7] :=   JDOY( aRetVal[4], aRetVal[2], aRetVal[3] )
  203.  
  204.  @nRow, nCol SAY SUBSTR(aRetval[6],1,3)+' '+;
  205.                     STR(aRetVal[3],2,0)+' '+;
  206.                  SUBSTR(aRetVal[5],1,3)+' '+;
  207.                     STR(aRetVal[4],4,0)
  208.  @nRow+1,nCol SAY   STR(aRetVal[7],3,0)
  209.  
  210.  nKey := 0
  211.  DO WHILE nKey == 0
  212.     @nRow+1,nCol+3 SAY '    '+TIME()
  213.     nKey := INKEY(1)
  214.  ENDDO
  215.  aRetVal[8] :=   TIME()
  216.  ENDDO
  217.  
  218.  SETCOLOR ( cSavColor )                 //restore colors.
  219.  SETCURSOR ( cSaveCursor )              //restore cursor.
  220.  RESTSCREEN ( nRow-1, nCol-1, nRow+3, nCol+17, cSaveScreen ) //restore screen.
  221.  IF lHelpIsDisplayed
  222.     RESTSCREEN (nHelpRow-1, 1, nHelpRow+7, 80, cSaveHelp)
  223.  ENDIF
  224.  RETURN aRetVal
  225.  
  226.  STATIC FUNCTION JDOY (nYear, nMonth, nDay)
  227.   LOCAL cString :='000031059090120151181212243273304334'
  228.   RETURN ( VALS(cString,(nMonth-1)*3+1,3) + nDay +;
  229.                IIF( nYear%4==0.AND.nMonth>2, 1, 0) )
  230.  
  231.  STATIC FUNCTION VALS (cString, nOffset, nChar)
  232.  RETURN ( VAL(SUBSTR(cString,nOffset,nChar)) )
  233.  
  234. * end of calendar.prg
  235.