home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1993 #2 / Image.iso / clipper / calend3.zip / CALENDAR.PRG < prev    next >
Text File  |  1993-06-10  |  32KB  |  796 lines
  1. /**************************************************************************
  2. **  CALENDAR.PRG                                                         **
  3. **  Version: 2.0 (06/10/93 08:07pm)                                      **
  4. **  A Monthly Calendar Function which allows a user to view the          **
  5. **  calendar for an input or current month and select a date.            **
  6. **  Page-Down skips 30 days, Page-Up skips back 30 days.                 **
  7. **  Cntr-Page-Down skips ahead 365 days, Cntr-Page-Down skips            **
  8. **  back 365 days.                                                       **
  9. **                                                                       **
  10. **  Author: Rod Cushman                                                  **
  11. **          4773 S. Breton Court SE #213                                 **
  12. **          Kentwood, MI  49508                                          **
  13. **                  phone:  (616) 554-9563  ( leave message )            **
  14. **                  Compuserve: 71212,1243                               **
  15. **                                                                       **
  16. **  calendar(dStartDate, nTRow, nLCol, cColorStr) -> dSlctDate           **
  17. **                                                                       **
  18. **  Compile: Clipper calendar /n                                         **
  19. **                                                                       **
  20. **  ==================================================================== **
  21. **                                                                       **
  22. **  Mods  : Updated functionality to shrink size of box, Allow arrow keys**
  23. **          to step for/back month; disallowed selection of blank cells; **
  24. **          and added hotkeys Alt-Y for Year Selection, Alt-M for Month  **
  25. **          Selection.  Function checks position parameters versus       **
  26. **          MaxRow(), MaxCol() and adjusts accordingly if needed.        **
  27. **          Function saves and restores prior states.                    **
  28. **                                                                       **
  29. **                                                                       **
  30. **  HotKeys:                                                             **
  31. **    KEY               DESCRIPTION                                      **
  32. **    ---               ------------------------------------------------ **
  33. **    K_CTRL_HOME       Revert to first day of the current year.         **
  34. **                                                                       **
  35. **    K_HOME            Revert to first day of the current month.        **
  36. **                                                                       **
  37. **    K_END             Go to the last day of the current month.         **
  38. **                                                                       **
  39. **    K_CTRL_END        Go to the last day of the current year.          **
  40. **                                                                       **
  41. **    K_ENTER           Accept current highlight as date to be returned  **
  42. **                      to calling routine.                              **
  43. **    K_UP              Move up row in the calendar, browse prior month  **
  44. **                      if on top row or above cell is empty.            **
  45. **    K_PGUP            Browse prior month.                              **
  46. **    K_CTRL_PGUP       Browse same month, prior year.                   **
  47. **    K_DOWN            Move down one row in the calendar, browse next   **
  48. **                      month if on bottom row or below cell is empty.   **
  49. **    K_PGDOWN          Browse next month.                               **
  50. **    K_CTRL_PGDOWN     Browse same month, next year.                    **
  51. **    K_ALT_Y           Pop-up box asking user for year.  Defualts to    **
  52. **                      current year.                                    **
  53. **    K_ALT_M           Pop-up menu asking user for month.  Menu defaults**
  54. **                      to current month.  User can select first char    **
  55. **                      of option as entry selector, or use normal menu  **
  56. **                      keys.                                            **
  57. **    K_ESC             Abort; returns default entry passed down to prog.**
  58. **                                                                       **
  59. **    SPACE             Return Blank Date (i.e. CtoD( Space(8) ) )       **
  60. **                                                                       **
  61. **                                                                       **
  62. **      Please feel free to make revisions to the source.  I would       **
  63. **      appreciate any comments or suggestions.  The code has some       **
  64. **      possibility; especially with the use of tbrowse colors for       **
  65. **      weekends, holidays, etc.                                         **
  66. **                                                                       **
  67. **                                                                       **
  68. **  Revision History:                                                    **
  69. **  04/26/92 10:21am    Rod     Uploaded to BBS's and CompuServe; orig.  **
  70. **                              version.                                 **
  71. **  05/25/93 06:35pm    Rod     Fixed anomally in the 'Alt-M' to ensure  **
  72. **                              date is proper; will revert to first day **
  73. **                              of month if not.                         **
  74. **  05/26/93 00:35am    Rod     Performed several major modifications to **
  75. **                              the logic to flow better and more        **
  76. **                              efficiently...                           **
  77. **  06/10/93 07:35pm    Rod     Fixed anomally with MoveMonth()          **
  78. **  06/10/93 08:32pm    Rod     Submitted to PD/Shareware.               **
  79. **************************************************************************/
  80.  
  81. #include "InKey.ch"
  82. #include "Box.ch"
  83.  
  84. #define MY_HSEP  '═'
  85. #define MY_CSEP  ' '
  86.  
  87. #define MY_COLOR   "N/W, N/BG"
  88.  
  89.                         // Scroll back/fwd 1 month ?
  90. Static lMonthFwd := .f.                         // Logical: Skip Month +1 ?
  91. Static lMonthBck := .f.                         // Logical: Skip Month -1 ?
  92. Static ctColor   := "B/W,N/BG"                  // Default Calendar Color
  93. Static gnYear    := 1992                        // Default Year()
  94. Static gnMonth   := 1                           // Default Month()
  95. Static gnEpoch   := 1900                        // Default Century
  96. Static gnDateDoM := 1                           // Default Target Day
  97.  
  98. Function Calendar( dStartDate, nTRow, nLCol, cColorStr)
  99.   Local cKey := 0, dOrigDate := dStartDate, cSaveWin, cOldColr, nOEpoch,  ;
  100.     lOScorBrd := .t., cODateFmt, tDate
  101.   Private nTargRow, nTargCol, aMonth
  102.                    /* Establish Calendar box coordinates */
  103.   nTRow      := If(nTRow==NIL, 0,If(nTRow>MaxRow()- 7, MaxRow()- 7, nTRow))
  104.   nLCol      := If(nLCol==NIL, 0,If(nLCol>MaxCol()-23, MaxCol()-23, nLCol))
  105.   nBRow      := nTRow +  7
  106.   nRCol      := nLCol + 21
  107.   dStartDate := If(dStartDate == NIL, Date(), dStartDate)
  108.   dStartDate := If( Empty(dStartDate), Date(), dStartDate)
  109.   cColorStr  := If(cColorStr  == NIL,"B/W,N/BG",cColorStr)
  110.   ctColor    := cColorStr
  111.  
  112.   cOldColr   := SetColor()                      // Save Calling func State
  113.   lOScorBrd  := Set( _SET_SCOREBOARD, .f.)      // Disable Read Messages
  114.                         // Save old format, 
  115.                         //   force American
  116.   cODateFmt  := Set( _SET_DATEFORMAT, "mm/dd/yy")
  117.   cSaveWin   := SaveScreen( nTRow, nLCol, nBRow+2, nRCol+2 )
  118.   cOldColr   := SetColor(ctColor)
  119.   lDone      := .F.
  120.  
  121.   nOEpoch    := Set( _SET_EPOCH )
  122.  
  123.   DispWin(nTRow, nLCol, nBRow+2, nRCol+2, ctColor) // Disp Calendar Box
  124.   
  125.   Do While !lDone
  126.      lMonthBck  := .f.                          // Scroll back 1 month
  127.      lMonthFwd  := .f.                          // Scroll fore 1 month
  128.      gnDateDoM  := Day(dStartDate)              // Highlite Day of Month
  129.      m1stDay    := FirstDay(dStartDate)         // First Day of Mo. (#)
  130.      mLastDay   := LastDay(dStartDate)          // Last Date of Month
  131.      mWeeksInMo := WeeksInMo(m1stDay,mLastDay)  // No. of Weeks (rows)
  132.      gnYear     := Year(dStartDate)
  133.      gnMonth    := Month(dStartDate)
  134.                         // Build Calendar Array
  135.      aMonth     := MakCalArr(m1stDay, mLastDay, mWeeksInMo, gnDateDoM)
  136.  
  137.      DspCalHead(dStartDate,nTRow,nLCol,nRCol)   // Show Month and Year
  138.  
  139.                         // Perform Cal. Browse
  140.      dStartDate := CalBrowse( dStartDate, nTRow+1,nLCol+1, nBRow+1, nRCol+1)
  141.      cKey       := LastKey()
  142.      Do Case
  143.     Case cKey == K_RETURN
  144.          Exit
  145.  
  146.     Case Chr(cKey) == " "                   // Return Blank Date
  147.          dStartDate := CtoD( Space(8) )
  148.              Exit
  149.  
  150.         Case cKey == K_LEFT  .and. gnDateDoM = 1        // Move Back 1 month
  151.              dStartDate--
  152.  
  153.         Case cKey == K_RIGHT .and. gnDateDoM = LastDay( gnMonth )
  154.              dStartDate++
  155.  
  156.         Case cKey == K_UP
  157.              dStartDate -= 7
  158.  
  159.         Case cKey == K_DOWN
  160.              dStartDate += 7
  161.  
  162.     Case cKey == K_PGDN .or. lMonthFwd
  163.              dStartDate := MoveMonth(dStartDate,1, gnYear)  // Month Forward
  164.  
  165.     Case cKey == K_PGUP .or. lMonthBck
  166.              dStartDate := MoveMonth(dStartDate,-1, gnYear) // Month Back
  167.  
  168.     Case cKey == K_HOME                     // Goto Beginning of Month
  169.              dStartDate := Num2Date( gnMonth, 1, gnYear )
  170.  
  171.     Case cKey == K_END                      // Goto End of Month
  172.              dStartDate := Num2Date( gnMonth, LastDay( gnMonth ), gnYear )
  173.  
  174.     Case cKey == K_CTRL_PGDN               
  175.          dStartDate += 365                  // Increment Year by 1
  176.  
  177.     Case cKey == K_CTRL_PGUP
  178.          dStartDate -= 365                  // Decrement Year by 1
  179.  
  180.     Case ( cKey == K_CTRL_HOME )            // First day of Year
  181.              dStartDate := Num2Date( 1, 1, gnYear )
  182.  
  183.     Case ( cKey == K_CTRL_END )
  184.              dStartDate := Num2Date( 12, 31, gnYear )
  185.  
  186.  
  187.     Case cKey == K_ALT_M                    // Get New Month
  188.          gnMonth := GetMonth( gnMonth, nTrow+1, nRCol+3, ctColor)
  189.  
  190.              tDate   := Num2Date( gnMonth, gnDateDoM, gnYear )
  191.          If Empty( tDate )                  // Ensure Valid date
  192.                 tDate := Num2Date( gnMonth, 1, gnYear )
  193.          EndIf
  194.          dStartDate := tDate
  195.         
  196.  
  197.     Case cKey == K_ALT_Y                    // Get New Year
  198.          gnYear     := GetYear( gnYear, nTrow+1, nRCol+3, ctColor )
  199.          gnEpoch    := Set( _SET_EPOCH,gnYear - (gnYear % 100) )
  200.  
  201.              tDate   := Num2Date( gnMonth, gnDateDoM, gnYear )
  202.          If Empty( tDate )                  // Ensure Valid date
  203.                 tDate := Num2Date( gnMonth, 1, gnYear )
  204.          EndIf
  205.          dStartDate := tDate
  206.  
  207.     Case cKey == K_ESC      
  208.          dStartDate := dOrigDate            // Return Original Date
  209.          Exit
  210.      EndCase
  211.   EndDo
  212.   Set( _SET_EPOCH, nOEpoch )
  213.   Set( _SET_SCOREBOARD, lOScorBrd )
  214.   Set( _SET_DATEFORMAT, cODateFmt )
  215.   SetColor( cOldColr )
  216.   RestScreen( nTRow, nLCol, nBRow+2, nRCol+2, cSaveWin )
  217. Return dStartDate                               // Return Selected Date
  218.  
  219.  
  220. /**************************************************************************
  221. **  CalBrowse( <aMonth>, <nTop>, <nLeft>, <nBottom>, <nRight> )          **
  222. **                                                      --> nDaySelect   **
  223. **  This Function adapted from Nantucket Array.prg contains the TBrowse  **
  224. **  implementation                                                       **
  225. **************************************************************************/
  226. Function CalBrowse( dStartDate, nTop, nLft, nBot, nRit )
  227.  
  228.    LOCAL o                                      // TBrowse object
  229.    LOCAL k                                      // used in o:SkipBlock
  230.    LOCAL nKey := 0                              // keystroke holder
  231.  
  232.    Private n := 1                               // browse row index holder
  233.    Private nACol                                // browse column subscript
  234.  
  235.    SetCursor( 0 )
  236.                         // Create the TBrowse object
  237.    o               := TBrowseNew( nTop, nLft, nBot, nRit )
  238.  
  239.    o:headsep       := MY_HSEP
  240.    o:colsep        := MY_CSEP
  241.  
  242.                 /******************************************
  243.                 ** Initialize the TBrowse blocks         **
  244.                 ** Note: during browse, the current row  **
  245.                 **       subscript is maintained         **
  246.                 **       by the blocks in private n      **
  247.                 **       LEN(aMonth) returns number of   **
  248.                 **       rows in array                   **
  249.                 ******************************************/
  250.  
  251.    o:SkipBlock     := { |nSkipVal| SkipFunc( @n, nSkipVal, Len(aMonth)) }
  252.    o:GoTopBlock    := { || n := 1 }
  253.    o:GoBottomBlock := { || n := Len( aMonth ) }
  254.  
  255.                 /******************************************
  256.                 ** Create TBColumn objects, Initialize   **
  257.                 ** data retrieval blocks, and Add to     **
  258.                 ** TBrowse object                        **
  259.                 ******************************************/
  260.    FOR nACol = 1 TO LEN( aMonth[1] )
  261.        o:AddColumn( TBColumnNew(DayHead(nACol), ABlock("aMonth[n]", nACol)))
  262.    NEXT
  263.  
  264.                         // Position Cursor to start
  265.    o:ColPos := nTargCol
  266.    o:RowPos := nTargRow
  267.  
  268.                         // Start event handler loop
  269.    Do While nKey != K_ESC .and. nKey != K_RETURN
  270.       nKey := 0
  271.                         // Start stabilization loop
  272.       Do While !o:Stabilize()
  273.      nKey := InKey()
  274.          If nKey != 0
  275.         EXIT
  276.      EndIf
  277.       EndDo
  278.       dStartDate := CtoD( StrZero(gnMonth,2,0)  + '/' +  ;
  279.                           aMonth[ n, o:ColPos ] + '/' +  ;
  280.                           SubStr(Str(gnYear,4,0),3,2)    ;
  281.                         )
  282.       gnDateDoM  := Day(dStartDate)    // Highlite Date
  283.  
  284.       If nKey == 0
  285.      nKey := InKey(0)
  286.       EndIf
  287.  
  288.                         // Process directional keys
  289.       If o:Stable
  290.      DO Case
  291.  
  292.         Case ( nKey == K_UP )
  293.          If n > 1 
  294.             If !Empty(aMonth[ n-1, o:ColPos ])
  295.                o:Up()
  296.             Else
  297.                        Return dStartDate
  298.             End
  299.          Else
  300.                     Return dStartDate
  301.          End
  302.  
  303.         Case ( nKey == K_DOWN )
  304.          If n < LEN(aMonth)
  305.             If !Empty(aMonth[ n+1, o:ColPos ])
  306.                o:Down()
  307.             Else
  308.                        Return dStartDate
  309.             End
  310.          Else
  311.                     Return dStartDate
  312.          End
  313.  
  314.         Case ( nKey == K_RIGHT )
  315.          If o:colPos == 7
  316.                         // Last day of month
  317.                     If Val(aMonth[n,o:ColPos]) != LastDay( gnMonth )
  318.                o:down()
  319.                o:home()
  320.             Else
  321.                        Return dStartDate
  322.             EndIf
  323.          Else
  324.                         // Last day of month
  325.                     If Val(aMonth[n,o:ColPos]) != LastDay( gnMonth )
  326.                o:Right()
  327.             Else
  328.                        Return dStartDate
  329.             EndIf
  330.          End
  331.  
  332.         Case ( nKey == K_LEFT )
  333.          If o:colPos == 1
  334.             If n > 1                     /* NOTE: */
  335.                o:up()
  336.                o:end()
  337.             Else
  338.                        Return dStartDate
  339.             EndIf
  340.          Else
  341.             If aMonth[ n, o:ColPos] != " 1"     // 1rst of month
  342.                o:Left()
  343.             Else
  344.                        Return dStartDate
  345.             EndIf
  346.          EndIf
  347.  
  348.         Case ( nKey == K_PGDN .or. nKey == K_CTRL_PGDN)
  349.                  Return dStartDate
  350.  
  351.         Case ( nKey == K_PGUP .or. nKey == K_CTRL_PGUP)
  352.                  Return dStartDate
  353.  
  354.         Case ( nKey == K_HOME )             // Return first DOM()
  355.                  Return dStartDate
  356.  
  357.         Case ( nKey == K_END )
  358.                  Return dStartDate
  359.  
  360.         Case ( nKey == K_CTRL_HOME )        // First day of Year
  361.                  Return dStartDate
  362.  
  363.         Case ( nKey == K_CTRL_END )
  364.                  Return dStartDate
  365.  
  366.         Case ( nKey == K_ALT_Y )
  367.                  Return dStartDate
  368.  
  369.         Case ( nKey == K_ALT_M )
  370.                  Return dStartDate
  371.  
  372.         Case ( Chr(nKey) == " " )
  373.                  Return dStartDate
  374.  
  375.      EndCase
  376.       EndIf
  377.    EndDo
  378.  
  379.    SetCursor( 1 )
  380. * Return Val(aMonth[ n, o:ColPos ])
  381. Return dStartDate
  382.  
  383.  
  384. /**************************************************************************
  385. ** SkipFunc                                                              **
  386. ** I don't know about you but I had to dissect the skipblock routine     **
  387. ** in order to understand what it does.                                  **
  388. ** - JP Steffen                                                          **
  389. **************************************************************************/
  390. static Function SkipFunc( n, nSkip_Val, nMaxVal)
  391.   local nMove := 0                              // Return Value
  392.  
  393.   If nSkip_Val > 0
  394.      Do While n + nMove < nMaxVal .and. nMove < nSkip_Val
  395.        nMove++
  396.      EndDo
  397.   ElseIf nSkip_Val < 0
  398.      Do While n + nMove > 1 .and. nMove > nSkip_Val
  399.     nMove--
  400.      EndDo
  401.   EndIf
  402.   n += nMove
  403. Return nMove
  404.  
  405.  
  406. /**************************************************************************
  407. ** Function DispWin                                                      **
  408. **      clear window area and draw box for window                        **
  409. **      Parameters:                                                      **
  410. **      nTop            Top Row of Box                                   **
  411. **      nLft            Left Column of Box                               **
  412. **      nBot            Bottom Row of Box                                **
  413. **      nRit            Right Column of Box                              **
  414. **************************************************************************/
  415. Static Function DispWin( nTop, nLft, nBot, nRit, cClr)
  416.   cClr := Iif( cClr = NIL, SetColor(), cClr)
  417.   SetColor( cClr )
  418.   DispBegin()
  419.   @ nTop,nLft CLEAR TO nBot,nRit
  420.   @ nTop,nLft,nBot,nRit BOX B_DOUBLE_SINGLE  Color cClr
  421.   DispEnd()
  422. Return  NIL
  423.  
  424.  
  425. /***************************************************************************
  426. ** Function DspCalHead                                                    **
  427. ** create a centered Month and Year String                                **
  428. **      Parameters:                                                       **
  429. **      dStartD         Date to derive month and Year from                **
  430. **      nLine           Line to display Calenday header on                **
  431. **      nBeg            Beginning Column which to display header          **
  432. **      nEnd            Ending Column which to display header.            **
  433. ***************************************************************************/
  434. Function DspCalHead( dStartD, nLine, nBeg, nEnd)
  435.   nBeg++ 
  436.   nEnd--
  437.   cStr     := " " + Upper(Trim(CMonth(dStartd)) + " " +                   ;
  438.             LTrim(Str(Year(dStartD))))  + " "
  439.   nLineLen := (nEnd-1) - (nBeg+1)
  440.   nSpace   := Int((nLineLen - len(cStr)+2) / 2)+2       // Centered title
  441.   DispBegin()
  442.   @ nLine, nBeg Say Replicate(Chr(205), nEnd-nBeg+3) Color ctColor
  443.   @ nLine,nBeg+nSpace say cStr Color ctColor
  444.   DispEnd()
  445. Return NIL
  446.  
  447.  
  448. /**************************************************************************
  449. ** Function MakCalArr                                                    **
  450. **      Builds the data structure for the TBrowse in CalBrowse.  This is **
  451. **      the key to the program & can no doubt be done better ie. faster. **
  452. **      Parameters:                                                      **
  453. **      m1day                                                            **
  454. **      mLastD          Last Day of month                                **
  455. **      mWeeks          Number of weeks in the month                     **
  456. **      mTargD          Target Date                                      **
  457. **************************************************************************/
  458. Function MakCalArr( m1day, mLastd, mWeeks,  mTargd )
  459.   Local dArray[mWeeks][7]                       // Called by other funcs
  460.  
  461.   mDayOfMo   := 1
  462.  
  463.   for r := 1 to mWeeks
  464.      for c := 1 to 7
  465.                         // row & col of target day
  466.        If mDayOfMo == mTargd
  467.       nTargRow := r                         // put browse cursor here
  468.       nTargCol := c
  469.        EndIf
  470.        If c + (r-1)*7 < m1Day .or. mDayOfMo > mLastD
  471.       dArray[r][c] := "  "
  472.        Else
  473.       dArray[r][c] := PadNumber(mDayOfMo,2) // convert to str len=2
  474.       mDayOfMo = mDayOfMo + 1
  475.        End
  476.      Next c
  477.   Next r
  478. Return dArray
  479.  
  480.  
  481. /**************************************************************************
  482. **   PadNumber()                                                         **
  483. **   convert from num., trim, & apply leading Space                      **
  484. **************************************************************************/
  485. Function PadNumber( In_Num, Out_len )
  486.   Local Num_Len := Len(LTrim(Str(In_Num))) 
  487. Return Space(Out_Len - Num_Len) + LTrim(Str(In_Num))
  488.  
  489.  
  490. /**************************************************************************
  491. ** Function MoveMonth()                                                  **
  492. ** Simply adds or subtracts 30 days from date.  You may want to add more **
  493. ** sophistication to this to insure new day of month is same as current  **
  494. ** day of month.                                                         **
  495. **                      dStartD = Input Date                             **
  496. **                      nMove   = +1 or -1 (times 30 days)               **
  497. **************************************************************************/
  498. Function MoveMonth( dStartD, nMove, nYear )
  499.   Local nLastMnth, nLastDay, nLastYear,                                   ;
  500.         nCurrMnth, nCurrDay, nCurrYear,                                   ;
  501.         nNextMnth, nNextDay, nNextYear,                                   ;
  502.         dTemp    , nAbsMove
  503.  
  504.   // Grab values...
  505.   nAbsMove  := Abs( nMove )
  506.   nDay      := Day( dStartD )
  507.   nCurrMnth := Month( dStartD )
  508.   nCurrDay  := LastDay( nCurrMnth    )
  509.   nCurrYear := Year( dStartD )
  510.  
  511.   nLastMnth := ( 12 + nCurrMnth - nAbsMove ) % 12
  512.   nLastDay  := LastDay( nLastMnth )
  513.   nLastYear := nCurrYear - Int( ( nCurrMnth - nAbsMove ) / 12 )
  514.  
  515.   nNextMnth := ( nCurrMnth + nAbsMove ) % 12
  516.   nNextDay  := LastDay( nNextMnth )
  517.   nNextYear := nCurrYear - Int( ( nCurrMnth + nAbsMove ) / 12 )
  518.  
  519.   If nMove > 0
  520.      // Check if curr month longer than next
  521.      // If so, go to end of next month
  522.      If nDay <= nNextDay
  523.         dStartD += nCurrDay
  524.      Else
  525.         dTemp := Num2Date( nNextMnth, nNextDay, nNextYear )
  526.         If !Empty( dTemp )
  527.            dStartD := dTemp
  528.         EndIf
  529.      EndIf
  530.   Else
  531.      // Check if curr month longer than next
  532.      // If so, go to end of next month
  533.      If nDay <= nLastDay
  534.         dStartD -= nLastDay
  535.      Else
  536.         dTemp := Num2Date( nLastMnth, nLastDay, nLastYear )
  537.         If !Empty( dTemp )
  538.            dStartD := dTemp
  539.         EndIf
  540.      EndIf
  541.   EndIf
  542. Return dStartD
  543.  
  544.  
  545. /**************************************************************************
  546. ** Num2Date( nMonth, nDay, nYear ) => ctod('XX/XX/XX')                   **
  547. **      Function converts the given numeric fields into date format.     **
  548. **      Returns Empty(dDate) if invalid combination.                     **
  549. **************************************************************************/
  550. Function Num2Date( nMonth, nDay, nYear )
  551.   Local dDate
  552.  
  553.   If LastDay( nMonth ) < nDay                   // Invalid combination
  554.      Return CtoD( Space(8) )
  555.   EndIf
  556.  
  557.   If nYear < 100 .or. nYear > 2999              // Invalid year
  558.      Return CtoD( Space(8) )
  559.   EndIf
  560.  
  561.   dDate := CtoD( StrZero(nMonth,2,0)  + '/' +                             ;
  562.                  StrZero(nDay,2,0) + '/' +                                ;
  563.                  SubStr(Str(nYear,4,0),3,2)                               ;
  564.                )
  565. Return dDate
  566.  
  567.  
  568. /**************************************************************************
  569. ** LastDay()                                                             **
  570. **      Returns the last date of month for input date                    **
  571. **      Modified parameter so that it may either be date or month number **
  572. **      Parameters:                                                      **
  573. **      nMnth           Either Numeric Month number of Date from which   **
  574. **                      to calculate the month from.                     **
  575. **************************************************************************/
  576. Function LastDay( nMnth )
  577.   Local nMonth := If( ValType(nMnth)="D", Month(nMnth), nMnth ),        ;
  578.     nDays    := 30
  579.  
  580.   Do Case
  581.      Case nMonth =  0                   // Allow previous year, December
  582.       nDays := 31
  583.  
  584.      // January
  585.      Case nMonth =  1
  586.       nDays := 31
  587.  
  588.      // February
  589.      Case nMonth =  2                   // Is this leap year ?
  590.       If !Empty( Day(CtoD("02/29/" + SubStr(Str(gnYear,4,0),3,2))) )
  591.          nDays := 29
  592.       Else
  593.          nDays := 28
  594.       End
  595.  
  596.      // March
  597.      Case nMonth =  3
  598.       nDays := 31
  599.  
  600.      // April
  601.      Case nMonth =  4
  602.       nDays := 30
  603.  
  604.      // May
  605.      Case nMonth =  5
  606.       nDays := 31
  607.  
  608.      // June
  609.      Case nMonth =  6
  610.       nDays := 30
  611.  
  612.      // July
  613.      Case nMonth =  7
  614.       nDays := 31
  615.  
  616.      // August
  617.      Case nMonth =  8
  618.       nDays := 31
  619.  
  620.      // September
  621.      Case nMonth =  9
  622.       nDays := 30
  623.  
  624.      // October
  625.      Case nMonth = 10
  626.       nDays := 31
  627.  
  628.      // November
  629.      Case nMonth = 11
  630.       nDays := 30
  631.  
  632.      // December
  633.      Case nMonth = 12
  634.       nDays := 31
  635.   EndCase
  636. Return nDays
  637.  
  638.  
  639. /**************************************************************************
  640. ** FirstDay()                                                            **
  641. **      Returns the day of week for first day of month                   **
  642. **************************************************************************/
  643. Function FirstDay( nStartD )
  644. Return Dow(nStartD - Day(nStartD) + 1)
  645.  
  646.  
  647. /**************************************************************************
  648. ** WeeksInMo()                                                           **
  649. **      Calculates the number of rows needed for array                   **
  650. **      Parameters:                                                      **
  651. **      nBegDoW         Beginning Date Day of Week                       **
  652. **      nDays           Number of days in the month.                     **
  653. **************************************************************************/
  654. Function WeeksInMo( nBegDoW, nDays )
  655.  
  656.   Do Case
  657.      Case nDays == 31                           // 31 day month
  658.       If nBegDoW >= 6
  659.          Return 6
  660.       Else
  661.          Return 5
  662.       End
  663.  
  664.      Case nDays == 30                           // 30 day month
  665.       If nBegDoW == 7
  666.          Return 6
  667.       Else
  668.          Return 5
  669.       End
  670.  
  671.      Case nDays == 29                           // February - leap year
  672.       Return 5
  673.  
  674.      Case nDays == 28                           // February - 28 days
  675.       If nBegDoW == 1
  676.          Return 4
  677.       Else 
  678.          Return 5
  679.       End
  680.   EndCase
  681. Return 4
  682.  
  683.  
  684. /**************************************************************************
  685. **  ABlock( <cName>, <nSubx> ) -> bABlock                                **
  686. **      Given an array name and subscript, return a set-get block for    **
  687. **      the array element indicated.                                     **
  688. **************************************************************************/
  689. Function ABlock( cName, nSubx )
  690.   LOCAL caExpr, bRetVal
  691.  
  692.   caExpr := cName + "[" + LTrim(STR(nSubx)) + "]"
  693.   bRetVal := &( "{||" + caExpr + "}" )
  694. Return bRetVal
  695.  
  696.  
  697. /**************************************************************************
  698. ** DayHead                                                               **
  699. **      returns strings to TBColumnNew for column heads                  **
  700. **************************************************************************/
  701. Function DayHead( NumDay )
  702.  
  703.    Do Case
  704.       Case NumDay == 1
  705.        Return "Su"
  706.  
  707.       Case NumDay == 2
  708.        Return "Mo"
  709.  
  710.       Case NumDay == 3
  711.        Return "Tu"
  712.  
  713.       Case NumDay == 4
  714.        Return "We"
  715.  
  716.       Case NumDay == 5
  717.        Return "Th"
  718.  
  719.       Case NumDay == 6
  720.        Return "Fr"
  721.  
  722.       Case NumDay == 7
  723.        Return "Sa"
  724.  
  725.     EndCase
  726. Return "  "
  727.  
  728.  
  729. /**************************************************************************
  730. ** GetMonth( )                                                           **
  731. **      Pop - Up Menu for Month Selection.  Returns Selected Month       **
  732. **************************************************************************/
  733. Static Function GetMonth( nDefaultMnth, nTop, nLft, cColor )
  734.   Local nMonth := nDefaultMnth,                                           ;
  735.     sWin   := "",                                                     ;
  736.     tTop   := 11,                                                     ;
  737.     tLft   := 63,                                                     ;
  738.     coColr := SetColor()
  739.  
  740.                    // Establish Calendar box coordinates
  741.   tTop     := If(nTop == NIL, 0, If(nTop > MaxRow()-13, MaxRow()-13, nTop))
  742.   tLft     := If(nLft == NIL, 0, If(nLft > MaxCol()-17, MaxCol()-17, nLft))
  743.  
  744.   KeyBoard Chr(K_HOME) + Replicate(Chr(K_DOWN), nDefaultMnth-1 )
  745.   sWin   := SaveScreen(tTop, tLft, tTop+13, tLft+15)
  746.  
  747.   DispBegin()
  748.   SetColor( cColor )
  749.   DispWin( tTop, tLft, tTop+13, tLft+15, cColor )
  750.   @ tTop+ 0, tLft+1 Say    " SELECT MONTH "  Color cColor
  751.   @ tTop+ 1, tLft+1 Prompt "1)  January   "
  752.   @ tTop+ 2, tLft+1 Prompt "2)  February  "
  753.   @ tTop+ 3, tLft+1 Prompt "3)  March     "
  754.   @ tTop+ 4, tLft+1 Prompt "4)  April     "
  755.   @ tTop+ 5, tLft+1 Prompt "5)  May       "
  756.   @ tTop+ 6, tLft+1 Prompt "6)  June      "
  757.   @ tTop+ 7, tLft+1 Prompt "7)  July      "
  758.   @ tTop+ 8, tLft+1 Prompt "8)  August    "
  759.   @ tTop+ 9, tLft+1 Prompt "9)  September "
  760.   @ tTop+10, tLft+1 Prompt "A)  October   "
  761.   @ tTop+11, tLft+1 Prompt "B)  November  "
  762.   @ tTop+12, tLft+1 Prompt "C)  December  "
  763.   DispEnd()
  764.   Menu to nMonth
  765.  
  766.   SetColor( coColr )
  767.   RestScreen( tTop, tLft, tTop+13, tLft+15, sWin )
  768. Return Iif(Empty(nMonth), 1, nMonth)
  769.  
  770.  
  771. /**************************************************************************
  772. ** GetYear( nDefaultYear )                                               **
  773. **      Pop - Up Alert() for Year  selection.  Returns Selected Year.    **
  774. **************************************************************************/
  775. Static Function GetYear( nDefaultYear, nTop, nLft, cColor )
  776.   Local nYear    := nDefaultYear,                                         ;
  777.     sWin     := "",                                                   ;
  778.     tTop     := 10, tLft := 50,                                       ;
  779.     oGetList := GetList
  780.  
  781.                    // Establish Calendar box coordinates
  782.   tTop     := If(nTop == NIL, 0, If(nTop > MaxRow()- 2, MaxRow()- 2, nTop))
  783.   tLft     := If(nLft == NIL, 0, If(nLft > MaxCol()-19, MaxCol()-19, nLft))
  784.   GetList := {}                                 // Save old GetList, Reset
  785.   sWin := SaveScreen(tTop, tLft, tTop+2, tLft+18)
  786.  
  787.   DispWin( tTop, tLft, tTop+2, tLft+18, cColor )
  788.   @ tTop+ 0, tLft+3 Say     " SELECT YEAR "  Color cColor
  789.   @ tTop+ 1, tLft+1 Say "ENTER YEAR "  Get nYear Picture "9999"           ;
  790.           Valid ( 0100 <= nYear .and. nYear <= 2999 )  Color cColor
  791.   Read
  792.  
  793.   RestScreen( tTop, tLft, tTop+2, tLft+18, sWin )
  794.   GetList := oGetList                           // Restore prior GetList
  795. Return Iif(Empty(nYear), 1992, nYear)
  796.