home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / clipper / cliplib / semlib.prg < prev   
Text File  |  1994-01-20  |  83KB  |  2,146 lines
  1. ******************************************************************************
  2. * Title.........: SEMLIB.PRG (Library routines)                              *
  3. * Author........: Mark J. Wallin, Ph.D.,                                     *
  4. * Description...: Various common functions for Clipper applications.         *
  5. * Copyright.....: 1993, 1994 Mark J. Wallin, SEMCOR, Inc.                    *
  6. * Version.......: 1.1                                                        *
  7. * Language......: Clipper 5.2c                                               *
  8. * Last Rev. Date: 01/20/94                                                   *
  9. * Last Rev. Time: 00:52                                                      *
  10. ******************************************************************************
  11. #include "setcurs.ch"
  12. #include "getexit.ch"
  13. #include "inkey.ch"
  14. #include "box.ch"
  15. #include "error.ch"
  16. #include "set.ch"
  17. #include "directry.ch"
  18. #include "projfile.ch"
  19. * Define Color Array Index Constants
  20. #define COLSTD    1
  21. #define COLGET    2
  22. #define COLTITL   3
  23. #define COLMEN    4
  24. #define COLSHD    5
  25. #define COLSTAT   6
  26. #define COLBKGD   7
  27. #define COLBOX    8
  28. #define COLMSG    9
  29. #define COLFLSH  10
  30. #define COLLOGO  11
  31. #define COLHELP  12
  32.  
  33. #define SHADOWON   .t.
  34. #define SHADOWOFF  .f.
  35. #define ENHANCED   .t.
  36. #define UNENHANCED .f.
  37. * SoftSEEK constants:
  38. #define EXACT      .t.
  39. #define NOT_EXACT  .f.
  40.  
  41. FUNCTION pullDown(aList,aSelect,menuColor,pop,topRow,topLeftCol,;
  42.                   cBorder,lShadow)
  43. ******************************************************************************
  44. * Title....: PULLDOWN()  (Library routine first dev. by Mark J. Wallin)      *
  45. * System...: ODC DATABASE SYSTEM                                             *
  46. * Author...: Mark J. Wallin, Ph.D.                                           *
  47. * Company..: Copyright 1993, SEMCOR, Inc.                                    *
  48. * Last Rev.: 11/30/93                                                        *
  49. * Purpose..: Displays a self-sizing pulldown menu with optional shadow.      *
  50. * Parameter: Array of menu items, color of menu, pop-up (t/f), top row,      *
  51. * .........: top left column, border string (or NIL), shadow (.t./.f.)       *
  52. * Returns..: numeric value of choice, 0 if <Esc> pressed                     *
  53. ******************************************************************************
  54. MEMVAR mhelpvar
  55. LOCAL numItems, boxWidth, boxTopRow, boxBotRow, boxLftCol, boxRgtCol, oldColor
  56. LOCAL cScreen, nChoice, nKey := LASTKEY(), nOffset := 1, menuWidth, ;
  57.       boxShadWidth, maxHeight, maxRgtCol
  58. * oldColor = SETCOLOR(menuColor)
  59. * Size the pop-up box from the maximum width of the menu items and the number
  60. * of menu items
  61.  
  62. IF VALTYPE(cBorder) <> "C"                     && If cBorder is NIL
  63.    cBorder = "┌─┐│┘─└│"                        && Default border
  64. ENDIF
  65. numItems := LEN(aList)                         && Number of elements in array
  66. maxHeight:= numItems                           && Assumes we have enough room!
  67. menuWidth := maxArray(aList)                   && Maximum width of PROMPTS
  68. boxWidth := menuWidth + 2
  69. boxShadWidth := boxWidth
  70. IF lShadow
  71.    boxShadWidth++
  72.    maxHeight++
  73. ENDIF
  74. IF topRow == NIL                             && If top row not specified:
  75.    boxTopRow := INT((25 - numItems)/2) - 1   && center the box.
  76.  ELSE                                        && Otherwise, use specified row
  77.    boxTopRow := topRow
  78. ENDIF
  79. IF topLeftCol == NIL                       && If left col. not specified:
  80.    boxLftCol := INT((80 - boxWidth)/2)     && center the box.
  81.  ELSE     && Otherwise, use spec'd. col.
  82.    boxLftCol := topLeftCol
  83. ENDIF
  84. boxBotRow := boxTopRow + numItems + 1      && Bottom row of box ( < 25)
  85. maxBotRow := boxTopRow + maxHeight + 1     && Bottom row w/shadow, if any
  86.  
  87. boxRgtCol := boxLftCol + boxWidth - 1      && Right column of box
  88. maxRgtCol := boxLftCol + boxShadWidth - 1  && (including shadow, if any)
  89. IF maxRgtCol > MAXCOL()                    && If the box is partly
  90.    maxRgtCol := MAXCOL()                   && off screen, adjust left col.
  91.    boxRgtCol := MAXCOL() - 1
  92.    boxLftCol := MAXCOL() - boxWidth   && MAXCOL() - 1 + ... - 1
  93. ENDIF
  94. IF pop                && If this is a popup menu which disappears after choice
  95.                       && Save the underlying screen area:
  96.    cScreen := SAVESCREEN(boxTopRow,boxLftCol,maxBotRow,maxRgtCol)
  97. ENDIF
  98. txtLeftCol := boxLftCol + 1
  99. txtRgtCol  := boxLftCol + menuWidth - 1
  100.  
  101. @ boxTopRow,boxLftCol,boxBotRow,boxRgtCol BOX cBorder COLOR menuColor
  102. IF lShadow
  103.    sha_shadow(boxTopRow,boxLftCol,boxBotRow,boxRgtCol)
  104. ENDIF
  105.  
  106. * Pop up the menu using ACHOICE, store selection in nChoice:
  107. *mHelpVar := "ALIST"
  108.  
  109. oldColor = SETCOLOR(menuColor)
  110. nChoice := ACHOICE(boxTopRow+1,boxLftCol+nOffset,boxBotRow-1, ;
  111.                    boxRgtCol-nOffset,aList,aSelect)    && ,"cUserFunction")
  112. SETCOLOR( oldColor )
  113. *mHelpVar := ""
  114. IF pop                && If this is a popup menu which disappears after choice
  115.                       && Restore the underlying screen & colors
  116.    RESTSCREEN(boxTopRow,boxLftCol,maxBotRow,maxRgtCol,cScreen)
  117. ENDIF
  118. *SETCOLOR(oldColor)    && Restore original screen colors
  119. RETURN nChoice
  120.  
  121.  
  122. FUNCTION moveptr( moveType, nFile, nIndOrder, cFilterExp, a1, aKeyVals )
  123. ******************************************************************************
  124. * Function......: MOVEPTR()
  125. * System........: ODC DOCUMENT DATABASE SYSTEM
  126. * Author........: Mark J. Wallin, Ph.D.
  127. * Description...: Moves record pointer for NEXT, PREVIOUS, TOP, BOTTOM with
  128. * ..............: limits set by common key.
  129. * Copyright.....: 1993, Mark J. Wallin, SEMCOR, Inc.
  130. * Version.......: 1.00
  131. * Language......: Developed to be run under CLIPPER 5.2c
  132. * Parameters....:
  133. * Returns.......: NIL
  134. * Last Rev. Date: 12/22/93
  135. * Last Rev. Time: 09:38
  136. ******************************************************************************
  137. LOCAL saveOrd, curRec, cMsgScrn
  138. *LOCAL xFilter := { ".t.", "docVer->doc_key == aKeyVals[ fDOCUM ]", ;
  139. *   "odcHits->rcv_key == aKeyVals [ fDOCVER ]" }
  140. LOCAL xFilter := { {|| .t. }, {|| docVer->doc_key == aKeyVals[ fDOCUM ] },;
  141.     {|| odcHits->rcv_key == aKeyVals[ fDOCVER ] } }
  142.  
  143. saveOrd := INDEXORD()  && Save current index order
  144. curRec := RECNO()   && Save current record position
  145.  
  146. * Sample Filters:
  147. *  DOCUM -> filter = ""                                     && No filter
  148. *  DOCVER-> filter = docVer->doc_id = aKeyVals[ fDOCUM ] && Filter: doc. id
  149. *  DOCHIT-> filter = odcHits->hit_id = aKeyVals [ fDOCVER ] && Filter: rev. id
  150.  
  151. cFilterExp := xFilter[ nFile ]  && Use internal filter instead of passed val.
  152.  
  153. IF RECCOUNT() = 0 .OR. EOF()   && If no records exist or
  154.    cMsgScrn := msg("No records exist",2)
  155.    scrnRest( cMsgScrn )
  156.    RETURN NIL     && positioned at EOF, abort move
  157. ENDIF
  158. SET ORDER TO 1
  159. *IF EMPTY(xfilter)
  160. * xfilter = "dummy"
  161. *ENDIF
  162. DO CASE
  163.    CASE moveType == "N"                          && NEXT record
  164.         IF .NOT. EOF()
  165.            SKIP
  166.            * IF EOF() .OR. .NOT. &(cFilterExp)
  167.            IF EOF() .OR. .NOT. EVAL(cFilterExp)
  168.               SKIP -1
  169.               ?? CHR(7)
  170.               IF EOF()
  171.                  ALERT("*** END OF FILE ***")
  172.                ELSE
  173.                  ALERT("*** NO MORE RECORDS ***")
  174.               ENDIF
  175.            ENDIF
  176.          ELSE
  177.            ?? CHR(7)
  178.            ALERT("*** END OF FILE ***")
  179.            *IF .NOT. BOF()
  180.            *  SKIP -1
  181.            *ENDIF
  182.         ENDIF
  183.  
  184.    CASE moveType == "P"                         && PREVIOUS record
  185.         IF .NOT. BOF()
  186.            SKIP -1
  187.            IF BOF()
  188.               ?? CHR(7)
  189.               ALERT("*** TOP OF FILE ***")
  190.             ELSE
  191.               IF .NOT. EVAL(cFilterExp)    && If out of record range
  192.                  ?? CHR(7)
  193.                  ALERT("*** NO MORE RECORDS ***")
  194.                  SKIP
  195.               ENDIF
  196.            ENDIF
  197.          ELSE
  198.            ?? CHR(7)
  199.            ALERT("*** TOP OF FILE ***")
  200.         ENDIF
  201.  
  202.    CASE moveType == "T"                         && GO TO TOP Record
  203.         IF VALTYPE( EVAL(cFilterExp) ) == "L"   && If no range specified,
  204.            GO TOP     && go to the top record:
  205.          ELSE   && Otherwise, skip backward
  206.            DO WHILE .NOT. BOF() .AND. EVAL(cFilterExp) && until key doesn't
  207.               SKIP -1    && match cFilterExp, then SKIP
  208.            ENDDO    && to last match
  209.            IF BOF() .OR. .NOT. EVAL(cFilterExp) .AND. .NOT. EOF()
  210.               SKIP
  211.            ENDIF
  212.         ENDIF
  213.  
  214.    CASE moveType == "B"                         && GO TO BOTTOM Record within
  215.         IF VALTYPE( EVAL(cFilterExp) ) == "L"   && the group matching the
  216.            GO BOTTOM                            && filter.
  217.          ELSE
  218.            DO WHILE .NOT. EOF()
  219.               SKIP
  220.               IF .NOT. EVAL(cFilterExp)
  221.                  SKIP -1
  222.                  EXIT
  223.               ENDIF
  224.            ENDDO
  225.            IF EOF()
  226.               SKIP -1
  227.            ENDIF
  228.         ENDIF
  229. ENDCASE
  230. IF curRec <> RECNO()                         && If rec # not the same
  231.    setFile( a1, aKeyVals, nFile )            && Display the new record
  232.    * Note: Although we are passing the a1 and aKeyVals arrays by value, the
  233.    *       individual elements changed in SETFILE() are reflected back
  234.    *       as if passed by reference.
  235. ENDIF
  236. SET ORDER TO saveOrd                         && Restore previous index order
  237. RETURN .t.
  238.  
  239.  
  240. FUNCTION moveToNext( aKeyVals, nFile )
  241. ******************************************************************************
  242. * Function......: MOVETONEXT()
  243. * System........: HM DOCUMENT DATABASE SYSTEM
  244. * Author........: Mark J. Wallin, Ph.D.
  245. * Copyright.....: SEMCOR, Inc., 1993
  246. * Description...: Moves record pointer to the next record with a matching
  247. * ..............: key after a DELETE.  If the key doesn't match, the pointer
  248. * ..............: is moved back to the previous matching record, if any.
  249. * Copyright.....: 1993, Mark J. Wallin, SEMCOR, Inc.
  250. * Version.......: 1.1
  251. * Language......: Developed to be run under CLIPPER 5.2c
  252. * Parameters....:
  253. * Returns.......: NIL
  254. * Last Rev. Date: 12/06/93
  255. * Last Rev. Time: 12:22
  256. ******************************************************************************
  257. LOCAL saveOrd, curRec
  258. LOCAL xFilter := { {|| .t. }, {|| docVer->doc_key == aKeyVals[ fDOCUM ] },;
  259.                  {|| odcHits->rcv_key == aKeyVals[ fDOCVER ] } }
  260. cFilterExp := xFilter[ nFile ]  && Use internal filter instead of passed val.
  261.  
  262. IF RECCOUNT() = 0
  263.    RETURN NIL
  264. ENDIF
  265. SET ORDER TO 1
  266. * Current record was deleted: move to next or previous records with matching
  267. * keys, if possible
  268. IF .NOT. EOF()
  269.    SKIP
  270.    IF EOF() .OR. .NOT. EVAL(cFilterExp)
  271.       SKIP -2                                     && Back up 2 records
  272.       IF BOF() .OR. .NOT. EVAL(cFilterExp)
  273.          ?? CHR(7)
  274.          ALERT("*** NO MORE RECORDS ***")
  275.       ENDIF
  276.    ENDIF
  277. ENDIF
  278. RETURN NIL
  279.  
  280.  
  281. FUNCTION valData( cFieldValue, cLookup, cKeyField )
  282. ******************************************************************************
  283. * Function......: VALDATA()
  284. * System........: HM/ODC DOCUMENT DATABASE SYSTEM
  285. * Author........: Mark J. Wallin, Ph.D.
  286. * Copyright.....: 1993 Mark J. Wallin, Ph.D., SEMCOR, Inc.
  287. * Description...: Validates data in a field.  If the data is not present in
  288. * ..............: a specified lookup file, the user is given the option of
  289. * ..............: adding the data or re-entering it.  The user can use the
  290. * ..............: F2 or F3 keys to add valid data to the field.
  291. * Version.......: 1.1
  292. * Language......: Clipper 5.2c
  293. * Parameters....: cFieldValue = Data entered, cLookup = alias->field in
  294. * ..............: lookup file (alias) to get new data, cKeyField = field in
  295. * ..............: lookup file which gets new key code.
  296. * Returns.......: .t./.f.
  297. * Last Rev. Date: 12/28/93
  298. * Last Rev. Time: 14:04
  299. ******************************************************************************
  300. LOCAL cFileName, cAppField, cCurFile, retVal := .t., cMsgScrn
  301. LOCAL getList := {}
  302.  
  303. IF EMPTY(cFieldValue)    && Allow a blank entry
  304.    RETURN retVal
  305. ENDIF
  306. cFileName := SUBSTR( cLookup, 1, AT(">",cLookup) - 2 )
  307. cAppField := SUBSTR( cLookup, AT(">",cLookup)+1 )
  308. cCurFile  := ALIAS()
  309. SELECT (cFileName)
  310. SET ORDER TO 2   && Order by description text
  311. SEEK cFieldValue   && Look for match
  312. IF .NOT. FOUND()
  313.    nQuery = ALERT("This entry was not found in the data lookup file;"+;
  314.                   "Do you wish to add it to the list of valid data? ",;
  315.                    {"Yes","No"})
  316.    IF nQuery == 1                       && If user wants to add the new data:
  317.       nRecCount = RECCOUNT()            && Count # of records before append
  318.       newKey := genKey( nRecCount, 4 )  && Generate new base36 key
  319.       APPEND BLANK
  320.       REPLACE &cAppField WITH cFieldValue
  321.       REPLACE &cKeyField WITH newKey
  322.    ENDIF
  323. ENDIF
  324. SELECT (cCurFile)
  325. RETURN retVal
  326.  
  327.  
  328. FUNCTION selectRec( cFileName,nIndexOrd,cTitleString,bDispString,bMatchVal,;
  329.                     bMatchBlk, cColorString )
  330. ******************************************************************************
  331. * Function......: SELECTREC()
  332. * System........: HM/ODC DOCUMENT DATABASE SYSTEM
  333. * Author........: Mark J. Wallin, Ph.D.
  334. * Description...: General purpose record selector via a 'filtered' browse.
  335. * ..............: The filter is applied via a SKIPBLOCK on matching key.
  336. * ..............: The current file and record position is saved and the
  337. * ..............: 'pick' file is opened and set to the proper index order.
  338. * ..............: Passed code blocks set the range limits for the tBrowse.
  339. * ..............: The RECNO() of the selected record is returned or set to
  340. * ..............: zero if no record is selected.  When completed, the
  341. * ..............: original file settings are restored.
  342. * Copyright.....: 1994 Mark J. Wallin, SEMCOR, Inc.
  343. * Version.......: 1.1
  344. * Language......: Clipper 5.2c
  345. * Parameters....: File name, index order, display title string, code block of
  346. * ..............: display fields, code block of match values for top/bottom
  347. * ..............: range of records, code block of criteria for skip block to
  348. * ..............: act as 'filter' for tBrowse, browse display colors.
  349. * Returns.......: NIL
  350. * Last Rev. Date: 01/04/94
  351. * Last Rev. Time: 10:03
  352. ******************************************************************************
  353. LOCAL column, browse, key, n, saveOrder, cCurColor, objBrowse, cBorder,;
  354.       saveWindow, retVal, cColors, nReturnRec, cCurFile, saveCursor,;
  355.       nSaveOrder, nOrigRec
  356. LOCAL f_blk, l_blk, while_blk
  357. LOCAL nDispWidth, nBoxLeftCol, nBoxRightCol, tRow := 9, bRow := 23
  358.  
  359. * Size the display window:
  360. nDispWidth  := LEN(EVAL(bDispString))
  361. nDispWidth  := IIF( nDispWidth > 76, 76, nDispWidth )   && Maximum width
  362. nBoxLeftCol := (80 - INT(nDispWidth))/2 - 1
  363. nBoxRightCol:= nBoxLeftCol + nDispWidth + 1
  364. cBorder = "┌─┐│┘─└│"                                    && Default border
  365.  
  366. * Save the required screen area and current colors:
  367. cCurScrn  := scrnSave( 9, nBoxLeftCol, 24,nBoxRightCol + 1 )
  368. cCurColor := SETCOLOR( cColorString )
  369.  
  370. * Make a shadowed box for the tBrowse display:
  371. @ 9, nBoxLeftCol,23,nBoxRightCol BOX cBorder COLOR "W+/RB"
  372. sha_shadow( 9, nBoxLeftCol,23,nBoxRightCol )
  373.  
  374. * Create & initialize TBrowse object at row & column coordinates:
  375. objBrowse = TBROWSEDB( tRow+1,nBoxLeftCol+1,bRow-1,nBoxRightCol-1 )
  376. objBrowse:addColumn(TBColumnNew( cTitleString, bDispString ))
  377. cColors := objBrowse:colorSpec           && Save the current colors
  378. objBrowse:colorSpec := cColorString      && Set colors for browse window
  379.  
  380. * Select the file (assume that it is open):
  381. saveCursor:= SETCURSOR(0)                && Save cursor and turn it off
  382. cCurFile  := ALIAS()                     && Save current file name
  383. nOrigRec  := RECNO()                     && Save the oritinal record position
  384. SELECT (cFileName)                       && Select the 'pick' file
  385. nSaveOrder := INDEXORD()                 && Save current order
  386. SET ORDER TO nIndexOrd
  387. nReturnRec := RECNO()                    && Initialize the RETURN record value
  388. * Code blocks for going to top & bottom of selected data within the range
  389. * of selected data in the browse window:
  390.  
  391. f_blk     := {|| gototop( EVAL(bMatchVal), EXACT )}  && First matching record
  392. l_blk     := {|| gotobott(EVAL(bMatchVal))}  && Last matching record
  393.  
  394. *  The while_blk is effectively a filter for the data and is much faster
  395. *  than using an actual filter in a large dataset. It is used in the
  396. *  SKIPBLOCK method which controls the movement of the record pointer
  397. while_blk := bMatchBlk                   && {|| cKeyExp == cMatchVal }
  398.  
  399. *  Assign the code blocks to the browse object methods.  If the bMatchVal
  400. *  code block evaluates to "", the top and bottom of the file is 'unfiltered'
  401. *  and we use the default methods.  Otherwise, substitute f_blk & l_blk
  402. IF EVAL(bMatchVal) <> NIL
  403.    objBrowse:gotopblock    := f_blk         && SEEK to 1st matching record
  404.    objBrowse:gobottomblock := l_blk         && SEEK to last record
  405. ENDIF
  406. objBrowse:skipblock     := {|n| movepointer(n, while_blk)}
  407.  
  408. * Setup an arrow indicator in the upper righthand corner of the tBrowse
  409. * which tells the user when he is at the top or bottom of the data on display:
  410. DO CASE
  411.    CASE objBrowse:rowPos == 1
  412.         @tRow,nBoxRightCol SAY ""         && Show a down arrow to the right
  413.    CASE objBrowse:rowPos == objBrowse:rowCount
  414.         @tRow,nBoxRightCol SAY ""         && Show an up arrow to the right
  415.    OTHERWISE
  416.         @tRow,nBoxRightCol SAY ""
  417. ENDCASE
  418. objBrowse:gotop()
  419. DO WHILE .t.
  420.    objBrowse:forceStable()                 && New way of stabilizing display
  421.    * DO WHILE .NOT. objBrowse:forceStable()
  422.    //  Allow user to interrupt by pressing a key.
  423.    *   IF nextkey() <> 0
  424.    *      EXIT
  425.    *   ENDIF
  426.    * ENDDO
  427.    DO CASE
  428.       CASE objBrowse:rowPos == 1
  429.            @tRow,nBoxRightCol SAY ""     && Show a down arrow to the right
  430.       CASE objBrowse:rowPos == objBrowse:rowCount
  431.            @tRow,nBoxRightCol SAY ""     && Show an up arrow to the right
  432.       OTHERWISE
  433.            @tRow,nBoxRightCol SAY ""
  434.    ENDCASE
  435.  
  436.    //  Wait for a keystroke.
  437.    key := INKEY(0)
  438.    // Move the pointer based on user's keystroke.
  439.    DO CASE
  440.    CASE key = K_ENTER // Select the highlighted record & return
  441.         nReturnRec := RECNO()
  442.         EXIT
  443.  
  444.    CASE key == K_F1  // Pop up a help message even from INKEY()
  445.         help( PROCNAME(), NIL,NIL,NIL)
  446.  
  447.    CASE key = K_UP   //  Up one row
  448.         objBrowse:up()
  449.  
  450.    CASE key = K_DOWN // Down one row
  451.         objBrowse:down()
  452.  
  453.    CASE key = K_PGUP
  454.         objBrowse:pageup()
  455.  
  456.    CASE key = K_PGDN
  457.         objBrowse:pagedown()
  458.  
  459.    CASE key = K_CTRL_PGUP
  460.         objBrowse:gotop()
  461.  
  462.    CASE key = K_CTRL_PGDN
  463.         objBrowse:gobottom()
  464.  
  465.    *CASE key = K_LEFT // Left one column
  466.    *     objBrowse:left()
  467.  
  468.    *CASE key = K_RIGHT // Right one column
  469.    *     objBrowse:right()
  470.  
  471.    CASE key = K_HOME
  472.         objBrowse:home()
  473.  
  474.    CASE key = K_END
  475.         objBrowse:end()
  476.  
  477.    CASE key = K_CTRL_LEFT
  478.         objBrowse:panleft()
  479.  
  480.    CASE key = K_CTRL_RIGHT
  481.         objBrowse:panright()
  482.  
  483.    CASE key = K_CTRL_HOME
  484.         objBrowse:panhome()
  485.  
  486.    CASE key = K_CTRL_END
  487.         objBrowse:panend()
  488.  
  489.    CASE key = K_ESC    //  Aborted browse without moving record pointer
  490.         nReturnRec := 0    && Indicate that user escaped without selection
  491.         EXIT
  492.    ENDCASE
  493. ENDDO  //  While browsing
  494. SET ORDER TO nSaveOrder                      && Restore original index order
  495. SELECT (cCurFile)                            && Switch to original file
  496. GOTO nOrigRec                                && Go back to original record
  497. SETCURSOR( saveCursor )                      && Reset cursor
  498. SETCOLOR( cCurColor )                        && Reset colors
  499. scrnRest( cCurScrn )                         && Restore screen
  500. RETURN nReturnRec                            && Return value of selected recno
  501.  
  502.  
  503. FUNCTION goToTop(searcher, lExact)
  504. ******************************************************************************
  505. * Function......: GOTOTOP()
  506. * System........: HM/ODC DATABASE SYSTEM
  507. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  508. * Copyright.....: 1993 Mark J. Wallin, Ph.D., SEMCOR, Inc.
  509. * Description...: SEEKS to user selected 'top' of a file using SOFTSEEK for
  510. * ..............: a TBROWSE function.  This code was adapted from the
  511. * ..............: Clipper's developer seminar by guru RICK SPENCE.
  512. * Version.......: 1.1
  513. * Language......: Clipper 5.2c
  514. * Parameters....: searcher = String key to SEEK on
  515. * Returns.......: NIL
  516. * Last Rev. Date: 04/27/93
  517. * Last Rev. Time: 17:50
  518. ******************************************************************************
  519. LOCAL save_soft := SET(_SET_SOFTSEEK)
  520.  
  521. IF .NOT. lExact                        && If we don't want an exact match...
  522.    SET(_SET_SOFTSEEK, .t.)
  523.  ELSE                                  && Otherwise, set for exact match.
  524.    SET(_SET_SOFTSEEK, .f.)
  525. ENDIF
  526. SEEK searcher
  527. SET(_SET_SOFTSEEK, save_soft)
  528. RETURN NIL
  529.  
  530.  
  531. FUNCTION goToBott(searcher)
  532. ******************************************************************************
  533. * Function......: GOTOBOTT()
  534. * System........: HM/ODC DATABASE SYSTEM
  535. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  536. * Copyright.....: 1993 Mark J. Wallin, Ph.D., SEMCOR, Inc.
  537. * Description...: SEEKS to user selected 'bottom' of a file using SOFTSEEK
  538. * ..............: for a TBROWSE function.  This code was adapted from the
  539. * ..............: Clipper's developer seminar by guru RICK SPENCE.           *
  540. * ..............: It works by incrementing the last character of the search  *
  541. * ..............: key and soft SEEKing past the 'end' record, then skipping  *
  542. * ..............: back.  There may be a problem if the last character in the *
  543. * ..............: search string is CHR(255)
  544. * Version.......: 1.1
  545. * Language......: Clipper 5.2c
  546. * Parameters....: aInputArray = array of strings
  547. * Returns.......: Numeric width of longest string
  548. * Last Rev. Date: 04/27/93
  549. * Last Rev. Time: 13:55
  550. ******************************************************************************
  551. LOCAL save_soft := set(_SET_SOFTSEEK, .T.)
  552.  
  553. SEEK substr(searcher,1,len(searcher)-1) + chr(asc(substr(searcher,len(searcher)))+1)
  554. SKIP-1
  555. SET(_SET_SOFTSEEK, save_soft)          && Reset the SOFT SEEK setting
  556. RETURN NIL
  557.  
  558.  
  559. FUNCTION movePointer(num_to_skip, while_blk)
  560. ******************************************************************************
  561. * Function......: TBROWSEGET()
  562. * System........: HM/ODC DATABASE SYSTEM
  563. * Version.......: 1.1
  564. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  565. * Copyright.....: 1993 Mark J. Wallin, Ph.D., SEMCOR, Inc.
  566. * Description...: Code block function controlling the SKIPBLOCK variable in
  567. * ..............: the TBROWSE routine. The function receives the NUM_TO_SKIP
  568. * ..............: value from TBROWSE methods and the WHILE_BLK parameter is
  569. * ..............: a code block which defines the limits of the pointer
  570. * ..............: movement between index key values.  The operation of the
  571. * ..............: function assumes that the record pointer is at the first
  572. * ..............: matching key in the allowed SKIP range.  This function
  573. * ..............: effectively provide a FILTER without using a filter, which
  574. * ..............: speeds up operation with large data files.
  575. * Language......: Clipper 5.2c
  576. * Parameters....: top row, left column, bottom row, right column, file name,
  577. * ..............: display fields, color string.
  578. * Returns.......: Selected GET value.
  579. * Last Rev. Date: 12/22/93
  580. * Last Rev. Time: 17:00
  581. ******************************************************************************
  582. LOCAL num_skipped := 0, curColor, oldCursor   && Counter
  583.  
  584. IF LASTREC() == 0 .OR. EOF()   && No records -- EXIT
  585.    RETURN num_skipped
  586. ENDIF
  587.  
  588. IF ( num_to_skip > 0 .AND. RECNO() <> LASTREC() + 1 )
  589.    *  Loop as many times as there were SKIPs requested.
  590.    DO WHILE (num_skipped < num_to_skip )
  591.       SKIP 1
  592.       *  If SKIP goes out of range, back up and terminate.
  593.       IF EOF() .OR. .NOT. EVAL( while_blk )
  594.          SKIP -1
  595.          EXIT
  596.       ENDIF
  597.       num_skipped++   && Increment number skipped counter
  598.    ENDDO
  599.    *  If a backward SKIP is called for...
  600.  ELSEIF ( num_to_skip < 0 )
  601.    DO WHILE ( num_skipped > num_to_skip )
  602.       SKIP -1
  603.       IF BOF()
  604.          EXIT
  605.       ENDIF
  606.       IF .NOT. EVAL( while_blk )
  607.          SKIP 1
  608.          EXIT
  609.       ENDIF
  610.       num_skipped--   && Decrement number skipped counter
  611.    ENDDO
  612. ENDIF
  613. SETCOLOR(curColor)
  614. RETURN num_skipped
  615.  
  616.  
  617. FUNCTION toggleFile( a1, aKeyVals, nFile, aF )
  618. ******************************************************************************
  619. * Function......: TOGGLEFILE()
  620. * System........: HM/ODC DOCUMENT DATABASE SYSTEM
  621. * Author........: Mark J. Wallin, Ph.D.
  622. * Description...: Toggles the file displayed between 3 files: DOCUM, DOCVER,
  623. * ..............: and ODCHITS.  Also stores fields of current record in
  624. * ..............: memvars, stores keys in aKeyVals array, and displays the
  625. * ..............: record.
  626. * Copyright.....: 1993-94, Mark J. Wallin, SEMCOR, Inc.
  627. * Version.......: 1.1
  628. * Language......: Developed to be run under CLIPPER 5.2c
  629. * Parameters....: a1 - field memvar array, aKeyVals, nFile
  630. * Returns.......: NIL
  631. * Last Rev. Date: 12/10/93
  632. * Last Rev. Time: 16:00
  633. ******************************************************************************
  634. LOCAL cCurColor, aColors := getColors()
  635. cCurColor := SETCOLOR(aColors[COLSTD]) && Make sure we are in Std. color
  636. nFile++                                && Increment the file number
  637. nFile := IIF( nFile > 3, 1, nFile)     && Wrap around to 1st file if req.
  638. SELECT ( aF[ nFile ] )                 && Select the proper data file
  639. curFile := aF[ nFile ]                 && Set current file
  640. scrDisp( nFile )                       && Display screen for file
  641. setFile( @a1, @aKeyVals, nFile )
  642. SETCOLOR( cCurColor )                  && Restore the last color
  643. RETURN NIL
  644.  
  645.  
  646. //=============================================================
  647. //====================[ SYSTEM : Automem ]=====================
  648. //=============================================================
  649.  
  650. /*
  651.  AUTHOR: Kim Taulbee  [CS: 71021,3340]
  652.  Copyright (c) 1992, Intelligent Software Solutions, All Rights Reserved.
  653.  
  654.  
  655.  AutoClear( <Array> )
  656.   Populate array with empty variables identical to field list of
  657.   currently selected work area.
  658.  
  659.  AutoStore( <Array> )
  660.   Populate array with contents of current record in current work area.
  661.  
  662.  AutoReplace( <Array> )
  663.   Replace fields in current record with contents of Array.
  664.  
  665.  AutoAppend( <Array> )
  666.   Append new record and populate with contents of Array.  AutoAppend
  667.   will try to find a blank record to use before appending a blank.
  668.  
  669.  AutoBlank()
  670.   Clear the contents of current record.
  671.  
  672.  AutoPack()
  673.   Clear the contents of each record marked for deletion in SELECTed
  674.   database. Cleared records are then RECALLed. This provides an
  675.   easy way to avoid using PACK. You can clear and re-use deleted
  676.   records instead of PACKing the database.
  677.  
  678. */
  679.  
  680.  
  681. //-------------------------------------
  682. FUNCTION AutoClear( aM )
  683.    // Create blank aMemvars from open dbf
  684.    LOCAL i
  685.    LOCAL nSaveRec := RECNO()
  686.    DBGOTO(0)
  687.    ASIZE( aM, FCOUNT() )
  688.    FOR i := 1 TO LEN( aM )
  689.        aM[i] := FIELDGET(i)
  690.    NEXT
  691.    DBGOTO( nSaveRec )
  692.    RETURN( NIL )
  693.  
  694. //-------------------------------------
  695. FUNCTION AutoStore( aM )
  696.    // Store field data to amemvars
  697.    LOCAL i
  698.    ASIZE( aM, FCOUNT() )
  699.    FOR i := 1 TO LEN( aM )
  700.        aM[i] := FIELDGET(i)
  701.    NEXT
  702.    RETURN( NIL )
  703.  
  704. //-------------------------------------
  705. FUNCTION AutoReplace( aM )
  706.    // Replace fields in current record with automemvars.
  707.    LOCAL i := 0
  708.    ASIZE( aM, FCOUNT() )
  709.    FOR i := 1 TO LEN( aM )
  710.        FIELDPUT(i, aM[i] )
  711.    NEXT
  712.    RETURN( NIL )
  713.  
  714. //-------------------------------------
  715. FUNCTION AutoAppend( aM )
  716.    // Append blank and Replace fields with automemvars
  717.    // Use empty records if they exist
  718.    LOCAL i
  719.    LOCAL lAppend := .F.
  720.    DBGOTOP()
  721.    FOR i := 1 TO FCOUNT()
  722.        IF ! EMPTY( FIELDGET(i) )
  723.           lAppend := .T.
  724.           EXIT
  725.        ENDIF
  726.    NEXT
  727.    IF lAppend .OR. EOF() .OR. BOF()
  728.       DBAPPEND()
  729.    ENDIF
  730.    AutoReplace( aM )
  731.    RETURN( NIL )
  732.  
  733. //-------------------------------------
  734. FUNCTION AutoBlank()
  735.    LOCAL aTemp := {}
  736.    AutoClear( @aTemp )
  737.    AutoReplace( aTemp )
  738.    RETURN( NIL )
  739.  
  740. //-------------------------------------
  741. FUNCTION AutoPack()
  742.    /* Pseudo-pack function. Finds records marked for deletion,
  743.    clears all fields, then recalls record. This makes records
  744.    available for reuse by AutoAppend() and avoids using PACK.
  745.    It tends to be a little slow, I'm open to suggestions. */
  746.  
  747.    LOCAL aTemp := {}
  748.    AutoClear( @aTemp )
  749.    DBGOTOP()
  750.    WHILE !EOF()
  751.          IF DELETED()
  752.             AutoReplace( aTemp )
  753.             RECALL
  754.          ENDIF
  755.          DBSKIP(1)
  756.    ENDDO
  757.    RETURN( NIL )
  758.  
  759.  
  760. *  Miscellaneous files:
  761.  
  762. FUNCTION maxArray(mArray)
  763. ******************************************************************************
  764. * Function......: MAXARRAY()
  765. * System........: ODC DATABASE SYSTEM
  766. * Author........: Mark J. Wallin, Ph.D.
  767. * Copyright.....: 1991
  768. * Description...: Returns length of longest string in an array of strings
  769. * Last Rev. Date: 12/05/91
  770. * Last Rev. Time: 16:58
  771. ******************************************************************************
  772. LOCAL n, maxLen := 0, lenString
  773. FOR n := 1 TO LEN(mArray)
  774.     lenString = LEN(mArray[n])
  775.     IF lenString > maxLen
  776.        maxLen = lenString
  777.      ENDIF
  778. NEXT
  779. RETURN maxLen
  780.  
  781.  
  782. FUNCTION prtOk()
  783. ******************************************************************************
  784. * Function......: PRTOK()
  785. * System........: ODC DATABASE SYSTEM
  786. * Author........: Mark J. Wallin, Ph.D., SEMCOR, Inc.
  787. * Description...: Checks status of printer - Stays in loop until printer is  *
  788. * ..............: ready or escape is pressed.  If printer is on, a prompt is *
  789. * ..............: displayed to "Press any key to Print or <Esc> to abort".   *
  790. * Last Rev. Date: 01/06/94
  791. * Last Rev. Time: 15:41
  792. ******************************************************************************
  793. LOCAL notDone := .t., nChoice, retVal := .t.
  794. DO WHILE notDone
  795.    IF .NOT. ISPRINTER()  && Printer NOT ready!
  796.       nChoice=ALERT("Printer not ready! Press OK to print, ;"+;
  797.                     "<Esc> or Abort to terminate.          ",{"OK","Abort"})
  798.       IF nChoice <> 1
  799.          notDone := .f.
  800.          retVal  := .f.
  801.       ENDIf
  802.     ELSE   && Printer is ready
  803.       nChoice=ALERT("Prepare paper and press any key to ;"+;
  804.                     "print or <Esc> to abort.           ",{"OK","Abort"})
  805.       notDone := .f.
  806.       IF nChoice <> 1
  807.          retVal := .f.
  808.       ENDIF
  809.    ENDIF
  810. ENDDO
  811. RETURN retVal
  812.  
  813.  
  814. FUNCTION printCodes( cCtrlCode )
  815. ******************************************************************************
  816. * Function......: PRINTCODES()
  817. * System........: ODC DATABASE SYSTEM
  818. * Author........: Mark J. Wallin, Ph.D., SEMCOR, Inc.
  819. * Description...: Sends a print code without affecting PROW() and PCOL()
  820. * Copyright.....: 1993, Mark J. Wallin, SEMCOR, Inc.
  821. * Version.......: 1.00
  822. * Language......: Clipper 5.2c
  823. * Parameters....: cCtrlCode = control code strings
  824. * Returns.......: NIL string
  825. * Last Rev. Date: 12/16/93
  826. * Last Rev. Time: 18:06
  827. ******************************************************************************
  828. LOCAL nRow, nCol, lPrinter
  829. lPrinter := SET(_SET_PRINTER, .t.)
  830. SET CONSOLE OFF
  831. nRow := PROW()
  832. nCol := PCOL()
  833. ?? cCtrlCode
  834. SETPRC(_SET_PRINTER, lPrinter)
  835. SET CONSOLE ON
  836. RETURN ""
  837.  
  838.  
  839. FUNCTION msg(msgText, nTimeDelay)
  840. ******************************************************************************
  841. * Function......: MSG()  (LIBRARY FUNCTION)
  842. * System........: ODC DATABASE SYSTEM
  843. * Author........: Mark J. Wallin, Ph.D.
  844. * Description...: Prints a message is a self-sizing box and passes back the
  845. * ..............: screen area saved in the routine.  The message will locate
  846. * ..............: itself in a (shadow) box at the bottom of the screen.
  847. * ..............: The message box display will persist for nTimeDelay
  848. * ..............: or if the value is 0, there will be no delay. The message
  849. * ..............: area is cleared manually by retoring the passed screen area
  850. * Last Rev. Date: 12/21/93
  851. * Last Rev. Time: 12:37
  852. ******************************************************************************
  853. LOCAL nMsgLen:=LEN(msgText), tTextRow, lTextCol := 4, bTextRow := 22, ;
  854.    rTextCol:=76, aColors := getColors()
  855. LOCAL tBoxRow, lBoxCol, bBoxRow, rBoxCol, nLineCount := 1, cCurColor, ;
  856.    cCurScrn
  857.  
  858. cCursor := SETCURSOR(0)     && Turn cursor off
  859. cCurColor := SETCOLOR( aColors[COLMSG] )
  860. IF nMsgLen > 70
  861.    nMsgLen := 70
  862.    nLineCount := MLCOUNT( msgText, 70,,.t.)   && Count # of lines, width = 70
  863. ENDIF
  864.  
  865. tTextRow := bTextRow - nLineCount + 1
  866. IF nLineCount == 1
  867.    lTextCol := INT((80 - nMsgLen)/2)
  868.    rTextCol := lTextCol + nMsgLen - 1
  869. ENDIF
  870. lBoxCol := lTextCol - 2
  871. rBoxCol := rTextCol + 2
  872. tBoxRow := tTextRow - 1
  873. bBoxRow := bTextRow + 1
  874.  
  875. cCurScrn := scrnsave( tBoxRow, lBoxCol, bBoxRow + 1, rBoxCol + 1)
  876. @ tBoxRow, lBoxCol, bBoxRow, rBoxCol BOX B_SINGLE+" "
  877. sha_shadow( tBoxRow, lBoxCol, bBoxRow, rBoxCol)
  878. FOR i = 1 TO nLineCount
  879.     @tTextRow + (i-1), lTextCol SAY MEMOLINE( msgText, nMsgLen, i, .t.)
  880. NEXT
  881. SETCOLOR(cCurColor)     && Restore the colors
  882. IF nTimeDelay > 0       && If displaying for a specified period, clear the
  883.    INKEY( nTimeDelay )  && screen when finished, otherwise, the screen must
  884.    scrnRest( cCurScrn ) && be restored by program action.
  885. ENDIF
  886. SETCURSOR( cCursor )
  887. RETURN (cCurScrn)       && Return underlying screen area
  888.  
  889.  
  890. FUNCTION scrnRest(scrname)
  891. ******************************************************************************
  892. * Function......: SCRNREST() (LIBRARY FUNCTION)
  893. * System........: ODC DATABASE SYSTEM
  894. * Author........: James Occhigrosso - Copyright(c) 1991
  895. * Description...: Loads screen from character variable created by SCRNSAVE
  896. * Last Rev. Date: 11/29/93
  897. * Last Rev. Time: 11:09
  898. ******************************************************************************
  899. * Restore screen to original coordinates
  900. RESTSCREEN(ASC(SUBSTR(scrname,1,1)), ASC(SUBSTR(scrname,2,1)), ;
  901.   ASC(SUBSTR(scrname,3,1)), ASC(SUBSTR(scrname,4,1)), ;
  902.   SUBSTR(scrname,5) )
  903.  
  904. RETURN NIL
  905.  
  906.  
  907. FUNCTION scrnSave(top, left, bottom, right)
  908. ******************************************************************************
  909. * Function......: SCRNSAVE() (LIBRARY FUNCTION)
  910. * System........: ODC DATABASE SYSTEM
  911. * Author........: James Occhigrosso - Copyright(c) 1991
  912. * Description...: Save partial screen and its coordinates in char. variable
  913. * Last Rev. Date: 11/29/93
  914. * Last Rev. Time: 11:09
  915. ******************************************************************************
  916. * Convert coordinates to a 4 character string and place it
  917. * at the beginning of the screen variable
  918. RETURN(CHR(top) + CHR(left) + CHR(bottom) + CHR(right) + ;
  919.        SAVESCREEN(top, left, bottom, right) )
  920.  
  921.  
  922. FUNCTION getColors()
  923. ******************************************************************************
  924. * Function......: GETCOLORS()  (LIBRARY FUNCTION)
  925. * System........: HM DATABASE SYSTEM
  926. * Author........: Mark J. Wallin, Ph.D.
  927. * Description...: Assigns a colors strings to global memvars.  The program
  928. * ..............: checks for the presence of a color or monochrome monitor
  929. * ..............: and sets the colors accordingly.
  930. * Last Rev. Date: 01/11/94
  931. * Last Rev. Time: 10:40
  932. ******************************************************************************
  933. LOCAL aColors[13]
  934. IF ISCOLOR()
  935.    aColors[1] := "B/BG,R/W"      && Standard colors
  936.    aColors[2] := "W/B, W+/R"     && 'GET' colors
  937.    aColors[3] := "B/W"           && Title line colors
  938.    aColors[4] := "W+/B"          && Menu colors
  939.    aColors[5] := "N/N"           && Shadow colors
  940.    aColors[6] := "GR+/B"         && Status line colors
  941.    aColors[7] := "W/N"           && Background screen colors
  942.    aColors[8] := "W+/BG"         && Box colors
  943.    aColors[9] := "W+/RB"         && Message colors
  944.    aColors[10]:= "W+*/B"         && Flashing letters
  945.    aColors[11]:= "R/BG"          && Logo colors
  946.    aColors[12]:= "W+/R"          && Help screen colors
  947.    * Set new palette colors:
  948.    *palette(1,24)       && Set BLUE to GRAYISH-BLUE
  949.    *palette(4,12)       && Set RED to DEEP ROSE
  950.    palette(5,28)       && Set MAGENTA to PALE WINE
  951.    palette(2,48)       && Set GREEN to OLIVE GREEN
  952.    *palette(3,49)       && Set CYAN to PALE CYAN
  953.  ELSE
  954.    aColors[1] := "W/N,N/W"       && Standard colors
  955.    aColors[2] := "W/N,W+/W"      && 'GET' colors
  956.    aColors[3] := "N/W"           && Title line colors
  957.    aColors[4] := "N/W"           && Menu colors
  958.    aColors[5] := "W/N"           && Shadow colors
  959.    aColors[6] := "N/W"           && Status line colors
  960.    aColors[8] := "W/N"           && Background screen colors
  961.    aColors[9] := "W+/N"          && Box colors
  962.    aColors[10]:= "N/W"           && Message colors
  963.    aColors[11]:= "W+*/N"         && Flashing letters
  964.    aColors[12]:= "W+/N"          && Logo colors
  965.    aColors[13]:= "N/W"           && Help screen colors
  966. ENDIF
  967. RETURN aColors
  968.  
  969.  
  970. FUNCTION dispTitle( titleStr )
  971. ******************************************************************************
  972. * Function......: DISPTITLE()
  973. * System........: HM DATABASE SYSTEM
  974. * Author........: Mark J. Wallin, Ph.D.
  975. * Description...: Function to display a title line
  976. * Copyright.....: 1993,  Mark J. Wallin, SEMCOR, Inc.
  977. * Version.......: 1.1
  978. * Language......: Developed to be run under CLIPPER 5.2c
  979. * Last Rev. Date: 11/24/93
  980. * Last Rev. Time: 11:46
  981. ******************************************************************************
  982. LOCAL curColor, aColors := getColors()
  983.  
  984. curColor := SETCOLOR( aColors[COLTITL] )   && Save cur. color, set title color
  985. @ 0, 8 CLEAR TO 0,79              && Clear top line, start at col. 8 in order
  986. center( titleStr, 80, 0)          && to avoid affecting the CLOCK display
  987. RETURN NIL
  988.  
  989.  
  990. FUNCTION center(text,width,row)
  991. ******************************************************************************
  992. * Function......: CENTER
  993. * System........: HM DATABASE SYSTEM
  994. * Author........: Mark J. Wallin, Ph.D.
  995. * Description...: This routine centers text on a ROW that is WIDTH wide
  996. * Last Rev. Date: 03/18/92
  997. * Last Rev. Time: 12:46
  998. ******************************************************************************
  999. LOCAL strLen, startCol
  1000. IF width == NIL
  1001.    width := 80
  1002. ENDIF
  1003. IF row == NIL
  1004.    row := 0
  1005. ENDIF
  1006. text := ALLTRIM(text)
  1007. strLen := LEN(text)
  1008. IF width < strlen
  1009.    RETURN .f.
  1010. ENDIF
  1011. startCol := INT((width - strLen)/2)
  1012. @ row, startCol SAY text
  1013. RETURN .t.
  1014.  
  1015.  
  1016. FUNCTION genKey(last_Key, numDigit)
  1017. ******************************************************************************
  1018. * Function......: GENKEY.PRG  (LIBRARY FUNCTION)
  1019. * System........: ODC DATABASE SYSTEM
  1020. * Author........: Mark J. Wallin, Ph.D.
  1021. * Description...: Assigns a unique id key (base 36) from for an N character
  1022. * ..............: string (e.g. '000000' to 'ZZZZZZ' for a 6 digit string).
  1023. * ..............: The last key is stored as an integer number in a control
  1024. * ..............: file.  If the last key used was 36^N (maximum key), the
  1025. * ..............: the routine looks for the first open id in the file.
  1026. * Parameters....: Last key used (obtain from control file), number of digits
  1027. * ..............: in id key.
  1028. * Returns.......: New base 36 key.
  1029. * Last Rev. Date: 12/06/93
  1030. * Last Rev. Time: 17:46
  1031. ******************************************************************************
  1032. LOCAL intKey, newKey := REPLICATE("0",numDigit), maxKey := 36^numDigit
  1033. LOCAL saveRec
  1034. * Maximum number of keys for 6 digit base 36 is 2,176,782,336 - more than
  1035. * the maximum number of records that Clipper or .DBF files can hold.
  1036. * If the file has no records, the value of NEWKEY returned will be a string
  1037. * of zeroes of length numDigit.
  1038. saveRec := RECNO()
  1039. GO TOP
  1040. intKey = last_Key + 1                   && Integer val. of last case key + 1
  1041. DO WHILE .NOT. EOF()
  1042.    IF intKey > maxKey                   && If key is greater than maximum,
  1043.       intKey := 0    && start over from 0
  1044.    ENDIF
  1045.    newKey := numTo36(intKey, numDigit)  && Convert to base36 key
  1046.    SEEK newKey                          && See if key not already used
  1047.    intKey++                             && Increment the integer value
  1048. ENDDO                                   && If not previously used, EXIT LOOP
  1049. IF saveRec > 0
  1050.    GOTO saveRec
  1051. ENDIF
  1052. RETURN newKey
  1053.  
  1054.  
  1055. FUNCTION numTo36( num, numDigit )
  1056. ******************************************************************************
  1057. * Function......: NUMTO36
  1058. * System........: ODC DATABASE SYSTEM
  1059. * Author........: Mark J. Wallin, Ph.D.
  1060. * Description...: This routine converts any (base 10) integer to a base 36
  1061. * ..............: number (numbers using the digits 0-9 and A-Z).  This
  1062. * ..............: function was developed to be used in with the GENKEY()
  1063. * ..............: function which generates unique keys.
  1064. * Last Rev. Date: 11/27/93
  1065. * Last Rev. Time: 17:37
  1066. ******************************************************************************
  1067. LOCAL num36 := "", div := 36^(numDigit - 1), n := 1, rem
  1068. FOR n := 1 TO numDigit
  1069.     rem := INT(num/div)                    && Divide by decreasing powers
  1070.     num := MOD(num,div)                    && of 36.  The remainder becomes
  1071.     div := div/36                          && the new dividend.
  1072.     IF rem <= 9                            && If the remainder is 9 or less
  1073.        num36 := num36 + CHR(48 + rem)      && use numeric characters.
  1074.      ELSE
  1075.        num36 := num36 + CHR(55 + rem)      && If the remainder is > 9, use
  1076.     ENDIF                                  && alphabetical characters A-Z.
  1077. NEXT n                                     && Concatenate digits along the way
  1078. RETURN num36
  1079.  
  1080.  
  1081. FUNCTION b36ToNum( sNum36, numDigit )
  1082. ******************************************************************************
  1083. * Function......: B36TONUM
  1084. * System........: ODC DATABASE SYSTEM
  1085. * Author........: Mark J. Wallin, Ph.D.
  1086. * Description...: This routine converts an N digit base 36 number to an
  1087. * ..............: integer. This function is the reverse to numTo36() and
  1088. * ..............: was developed to be used in the function which generates
  1089. * ..............: unique keys. The function accepts an N character string
  1090. * ..............: and returns the equivalent integer.
  1091. * Last Rev. Date: 11/27/93
  1092. * Last Rev. Time: 17:35
  1093. ******************************************************************************
  1094. LOCAL num10 := 0, digit
  1095. FOR n := 1 TO numDigit
  1096.  digit := SUBSTR(sNum36,n,1)
  1097.  IF .NOT. ISALPHA(digit)
  1098.  num10 := num10 + VAL(digit) * 36^(numDigit - n)
  1099.   ELSE
  1100.  num10 := num10 + (ASC(digit) - 55) * 36^(numDigit - n)
  1101.  ENDIF
  1102. NEXT
  1103. RETURN num10
  1104.  
  1105.  
  1106. FUNCTION pickList( oObj, cDispField, cStuffField, nTop, nLeft, cClr, cBorder,;
  1107.                    lShadow)
  1108. ******************************************************************************
  1109. * Function......: PICKLIST()
  1110. * System........:
  1111. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  1112. * Description...: PICK LIST with GET - Pops up a pick list of choices from
  1113. * ..............: a specified file.  Upon selection, a code is stuffed into
  1114. * ..............: the GET object, rather than the actual item displayed.
  1115. * ..............: The pickbox is self-sizing, based on the width of the
  1116. * ..............: displayed field and the number of records in the lookup
  1117. * ..............: file.  If there are more records in the file than can be
  1118. * ..............: displayed, the box is sized to go to the bottom of the
  1119. * ..............: screen.
  1120. * Version.......: 1.00
  1121. * Language......: Clipper 5.2c
  1122. * Parameters....: oGet - GET object: aFile = array with name of file, index,
  1123. * ..............: field containing lookup data, and field containing the
  1124. * ..............: code to stuff into the GET:  nTop/nLeft - starting left
  1125. * ..............: and top pick box coordinates: cClr - color string:
  1126. * ..............: cBorder - border string.
  1127. * Returns.......: NIL
  1128. * Last Rev. Date: 12/02/93
  1129. * Last Rev. Time: 11:00
  1130. ******************************************************************************
  1131. LOCAL cColor, cScr, cTemp, stdColor, enhColor, curColor
  1132. LOCAL nKey, nRet := GE_NOEXIT
  1133. *LOCAL cName, cIndex, cDispField, lShadow
  1134. LOCAL nShadowRows, nTotRowsAvail, nMaxHt, nMaxBoxHt, nMaxDispHt, nBoxBottom,;
  1135.    nShdBottom, nMaxDispWidth, nMaxBoxWidth, nMaxWidth, nBoxRight, nShdRight
  1136. LOCAL cScreen
  1137.  
  1138. curColor := SETCOLOR()    && Get current color string
  1139.  
  1140. *nTop  := TOP
  1141. *nLeft := LEFT
  1142. *nBottom := BOTTOM
  1143. *nRight  := RIGHT
  1144.  
  1145. IF VALTYPE(cBorder) <> "C"                     && If cBorder is NIL
  1146.    cBorder = "┌─┐│┘─└│"                        && Default border
  1147. ENDIF
  1148.  
  1149. IF cClr <> NIL  && If COLOR option was specified, use it
  1150.    * Parse the color string for the Standard and Enhanced colors
  1151. * stdColor := SUBSTR( cClr, 1, AT(",", cClr) - 1 )  && Standard color
  1152.    enhColor := SUBSTR( cClr, AT(",", cClr) + 1 )     && Enhanced color for GET
  1153.  ELSE   && Otherwise, use current colors:
  1154. * stdColor := SUBSTR( curColor, RAT(",", curColor) + 1 ) && Unsel
  1155.    enhColor := SUBSTR( curColor, AT(",", curColor) + 1 )  && Enhanced
  1156. ENDIF
  1157.  
  1158. lShadow := IIF( VALTYPE(lShadow) == "U", .f., lShadow ) && Default SHADOW off
  1159.  
  1160. cFileName := SUBSTR( cDispField, 1, AT(">",cDispField) - 2 )
  1161. numPickRecs := &(cFileName+"->(RECCOUNT())")
  1162. SEEK odcHits->decision
  1163. lookupOrder( ALPHAORDER )
  1164.  
  1165. * Size the pick box based on the width of the displayed field and the starting
  1166. * location of the box. The number of records displayed should be the number
  1167. * of records in the lookup file or the maximum number that could be displayed
  1168. * in the screen rows available.  Likewise, the leftmost column should be
  1169. * set to be equal to the column for the GET field or spaced to allow the
  1170. * full width to be accomodated from the rightmost column.
  1171. nShadowRows := IIF( lShadow, 1, 0 )  && Space occupied by shadow row
  1172.     && (same as column)
  1173. nTotRowsAvail := MAXROW() - nTop + 1 && Total rows avail. for display
  1174. IF numPickRecs > nTotRowsAvail - nShadowRows-2 && If # of recs. > avail. disp.
  1175.    nMaxHt := nTotRowsAvail   && Max. Ht. Box + Shadow (if any)
  1176.    nMaxBoxHt  := nTotRowsAvail - nShadowRows  && Max. Ht. Box only
  1177.    nMaxDispHt := nMaxBoxHt - 2  && Max rows of display area
  1178.  ELSE    && If # of recs <= avail. disp.
  1179.    nMaxBoxHt  := numPickRecs + 2
  1180.    nMaxHt := nMaxBoxHt + nShadowRows
  1181.    nMaxDispHt := numPickRecs
  1182. ENDIF
  1183. nBoxBottom := nTop + nMaxBoxHt - 1
  1184. nShdBottom := nTop + nMaxHt - 1
  1185.  
  1186. nMaxDispWidth := LEN( &cDispField )  && Width of display area
  1187. nMaxBoxWidth  := nMaxDispWidth + 2    && Width of pickbox
  1188. nMaxWidth := nMaxBoxWidth + nShadowRows && Width of pickbox w/shadow
  1189.  
  1190. nRight := nLeft + nMaxWidth - 1
  1191.  
  1192. * Calculate right column and adjust left column if necessary:
  1193. IF nRight > MAXCOL()  && If right column is too far
  1194.    nRight := MAXCOL()   && over, anchor right column at
  1195.    nLeft := nRight - nMaxWidth + 1    && MAXCOL(), adjust left column
  1196. ENDIF
  1197.  
  1198. nBoxRight := nLeft + nMaxBoxWidth - 1
  1199. nShdRight := nLeft + nMaxWidth - 1
  1200.  
  1201. * Save the underlying screen:
  1202. cScreen := SAVESCREEN( nTop, nLeft, nShdBottom, nShdRight )
  1203.  
  1204. IF EMPTY(oObj:varGet())
  1205.    nKey = K_ENTER
  1206.  ELSE
  1207.    nkey := INKEY(0)
  1208. ENDIF
  1209. DO CASE
  1210.    CASE nkey = K_ENTER  // Pop up the picklist TBrowse
  1211.         @ nTop, nLeft, nBoxBottom, nBoxRight BOX cBorder COLOR cClr
  1212.         IF lShadow
  1213.            sha_shadow( nTop, nLeft, nBoxBottom, nBoxRight )
  1214.         ENDIF
  1215.         oObj:varPut( tBrowseData( nTop+1, nLeft+1, nBoxBottom - 1,  ;
  1216.                      nBoxRight-1, cFileName, cDispField, ;
  1217.                      cStuffField, cClr ) )
  1218.         oObj:exitState := GE_ENTER
  1219.  
  1220.    CASE key == K_F1  // Pop up a help message
  1221.         help( PROCNAME(), NIL,NIL,NIL)
  1222.  
  1223.    CASE nKey == K_UP
  1224.         oObj:exitState := GE_UP
  1225.  
  1226.    CASE nKey == K_SH_TAB
  1227.         oObj:exitState := GE_UP
  1228.  
  1229.    CASE nKey == K_DOWN
  1230.         oObj:exitState := GE_DOWN
  1231.  
  1232.    CASE nKey == K_TAB
  1233.         oObj:exitState := GE_DOWN
  1234.  
  1235.    CASE nKey == K_ESC
  1236.         IF ( SET( _SET_ESCAPE ) )
  1237.            oObj:exitState := GE_ESCAPE
  1238.         ENDIF
  1239.  
  1240.    CASE nKey == K_PGUP
  1241.         oObj:exitState := GE_WRITE
  1242.  
  1243.    CASE nKey == K_PGDN
  1244.         oObj:exitState := GE_WRITE
  1245.  
  1246.    CASE nKey == K_CTRL_HOME
  1247.         oObj:exitState := GE_TOP
  1248. ENDCASE
  1249. lookupOrder( KEYORDER )  && Put back in key order
  1250. *setLookup()  && Reset relations
  1251. RESTSCREEN( nTop, nLeft, nShdBottom, nShdRight, cScreen )
  1252. SETPOS(nTop, nLeft)
  1253. *DEVOUT( oObj:varGet(), cClr )
  1254. DEVOUT( &cDispField, cClr )   && Display the related field
  1255. RETURN oObj
  1256.  
  1257.  
  1258. FUNCTION tBrowseData( tRow,lCol,bRow,rCol,cFileName,cDispField,cStuffField,;
  1259.                       cColorString )
  1260. ******************************************************************************
  1261. * Function......: TBROWSEDATA()
  1262. * System........: ODC DATABASE SYSTEM
  1263. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  1264. * Description...: TBROWSE for picking the actual data item.
  1265. * Version.......: 1.00
  1266. * Language......: Clipper 5.2c
  1267. * Parameters....: oGet - GET object: aFile = array with name of file, index,
  1268. * ..............: field containing lookup data, and field containing the
  1269. * ..............: code to stuff into the GET:  nTop/nLeft - starting left
  1270. * ..............: and top pick box coordinates: cClr - color string:
  1271. * ..............: cBorder - border string.
  1272. * Returns.......: NIL
  1273. * Last Rev. Date: 12/02/93
  1274. * Last Rev. Time: 11:00
  1275. ******************************************************************************
  1276. MEMVAR getlist
  1277. LOCAL column, browse, key, n, saveOrder, saveColor, objBrowse,;
  1278.       saveWindow, retVal, cColors, saveRecPos, saveCurFile, saveCursor
  1279.  
  1280. * Create & initialize TBrowse object at row & column coordinates:
  1281. titleString = ""
  1282. objBrowse = TBROWSEDB( tRow,lCol,bRow,rCol )
  1283. objBrowse:addColumn(TBColumnNew( titleString,{ || &cDispField } ))
  1284. *objBrowse:addColumn(TBColumnNew( titleString,{ || chemical->c_name } ))
  1285. *objBrowse = newBrow( tRow,lCol,bRow,rCol,cDispField )
  1286. cColors := objBrowse:colorSpec              && Save the current colors
  1287. objBrowse:colorSpec = cColorString          && Colors for browse window
  1288. * Select the file (assume that it is open):
  1289. saveCursor = SETCURSOR(0)                   && Save cursor and turn it off
  1290. saveCurFile = ALIAS()                       && Save current file name
  1291. SELECT (cFileName)                          && Select the 'pick' file
  1292. saveRecPos := RECNO()                       && Save the current record position
  1293. GO TOP                                      && Go to the top of the file
  1294.  
  1295. DO CASE
  1296.    CASE objBrowse:rowPos == 1
  1297.         @tRow,rCol+1 SAY ""             && Show a down arrow to the right
  1298.    CASE objBrowse:rowPos == objBrowse:rowCount
  1299.         @tRow,rCol+1 SAY ""             && Show an up arrow to the right
  1300.    OTHERWISE
  1301.         @tRow,rCol+1 SAY ""
  1302. ENDCASE
  1303. DO WHILE .t.
  1304.    objBrowse:forceStable()
  1305.    * DO WHILE .NOT. objBrowse:forceStable()
  1306.    //  Allow user to interrupt by pressing a key.
  1307.    *   IF nextkey() <> 0
  1308.    *   EXIT
  1309.    *   ENDIF
  1310.    *ENDDO
  1311.    DO CASE
  1312.       CASE objBrowse:rowPos == 1
  1313.            @tRow,rCol+1 SAY ""             && Show a down arrow to the right
  1314.       CASE objBrowse:rowPos == objBrowse:rowCount
  1315.            @tRow,rCol+1 SAY ""             && Show an up arrow to the right
  1316.       OTHERWISE
  1317.            @tRow,rCol+1 SAY ""
  1318.    ENDCASE
  1319.  
  1320.    //  Wait for a keystroke.
  1321.    key := INKEY(0)
  1322.  // Move the pointer based on user's keystroke.
  1323.    DO CASE
  1324.       CASE key = K_ENTER // Select the highlighted record
  1325.            retVal = &cStuffField   && Return code of selected field
  1326.            * retVal = chemical->c_chemical  && Return code of selected field
  1327.            EXIT
  1328.  
  1329.    CASE key == K_F1  // Pop up a help message
  1330.         help( PROCNAME(), NIL,NIL,NIL)
  1331.  
  1332.    CASE key = K_UP   //  Up one row
  1333.         objBrowse:up()
  1334.  
  1335.    CASE key = K_DOWN // Down one row
  1336.         objBrowse:down()
  1337.  
  1338.    CASE key = K_PGUP
  1339.         objBrowse:pageup()
  1340.  
  1341.    CASE key = K_PGDN
  1342.         objBrowse:pagedown()
  1343.  
  1344.    CASE key = K_CTRL_PGUP
  1345.         objBrowse:gotop()
  1346.  
  1347.    CASE key = K_CTRL_PGDN
  1348.         objBrowse:gobottom()
  1349.  
  1350.    *CASE key = K_LEFT // Left one column
  1351.    *     objBrowse:left()
  1352.  
  1353.    *CASE key = K_RIGHT // Right one column
  1354.   *      objBrowse:right()
  1355.  
  1356.    CASE key = K_HOME
  1357.         objBrowse:home()
  1358.  
  1359.    CASE key = K_END
  1360.         objBrowse:end()
  1361.  
  1362.    CASE key = K_CTRL_LEFT
  1363.         objBrowse:panleft()
  1364.  
  1365.    CASE key = K_CTRL_RIGHT
  1366.         objBrowse:panright()
  1367.  
  1368.    CASE key = K_CTRL_HOME
  1369.         objBrowse:panhome()
  1370.  
  1371.    CASE key = K_CTRL_END
  1372.         objBrowse:panend()
  1373.  
  1374.    CASE key = K_ESC    //  Done browsing
  1375.         retVal = NIL  && No record selected
  1376.         GOTO saveRecPos
  1377.         EXIT
  1378.    ENDCASE
  1379. ENDDO  //  While browsing
  1380. SELECT (saveCurFile)
  1381. SETCURSOR( saveCursor )
  1382. RETURN retVal
  1383.  
  1384.  
  1385. FUNCTION editMemo( oObj, cClr, nTop, nLeft, nBottom, nRight )
  1386. ******************************************************************************
  1387. * Function......: EDITMEMO()
  1388. * System........:
  1389. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  1390. * Description...: UDC which enables editing of a memo or other large field
  1391. * ..............: in a box using the MEMOEDIT function within the usual GET
  1392. * ..............: READ full screen editing mode.  The user may jump from
  1393. * ..............: by modifying the GET object get:reader method.  This
  1394. * ..............: implementation was adapted from code written by Luiz
  1395. * ..............: Quintela of CA (formerly Nantucket).
  1396. * Version.......: 1.00
  1397. * Language......: Clipper 5.2c
  1398. * Parameters....: oObj = GET object, cClr = color spec. string
  1399. * Returns.......: NIL
  1400. * Last Rev. Date: 11/22/93
  1401. * Last Rev. Time: 09:16
  1402. ******************************************************************************
  1403. *LOCAL nTop, nLeft, nRight, nBottom
  1404. LOCAL cColor, cScr, cTemp, stdColor, enhColor, curColor
  1405. LOCAL nKey, nRet := GE_NOEXIT, cCurK2
  1406.  
  1407. curColor := SETCOLOR()       && Get current color string
  1408. cCurK2 := SETKEY(K_F2,NIL)   && Disable the F2 key
  1409. cCurK3 := SETKEY(K_F3,NIL)   && Disable the F3 key
  1410. *nTop  := TOP
  1411. *nLeft := LEFT
  1412. *nBottom := BOTTOM
  1413. *nRight  := RIGHT
  1414.  
  1415. IF cClr <> NIL                      && If COLOR option was specified, use it
  1416.    * Parse the color string for the Standard and Enhanced colors
  1417.    * stdColor := SUBSTR( cClr, 1, AT(",", cClr) - 1 ) && Standard color
  1418.    enhColor := SUBSTR( cClr, AT(",", cClr) + 1 )      && Enhanced color for GET
  1419.  ELSE                               && Otherwise, use current colors:
  1420.    * stdColor := SUBSTR( curColor, RAT(",", curColor) + 1 ) && Unsel
  1421.    enhColor := SUBSTR( curColor, AT(",", curColor) + 1 )    && Enhanced
  1422. ENDIF
  1423.  
  1424. * Redisplay the memoBox with the edited string in standard colors:
  1425. memoBox(nTop,nLeft,nBottom,nRight,oObj:varGet(), cClr, UNENHANCED)
  1426.  
  1427. nKey := INKEY(0)
  1428. DO CASE
  1429.    CASE nKey == K_ENTER
  1430.         cScr  := SAVESCREEN( nTop, nLeft, nBottom, nRight )
  1431.         * memoBox(nTop,nLeft,nBottom,nRight,oObj:varGet(), enhColor)
  1432.         memoBox(nTop,nLeft,nBottom,nRight,oObj:varGet(), cClr, ENHANCED)
  1433.         cColor := SETCOLOR( enhColor )
  1434.         SCROLL( nTop+1, nLeft+1, nBottom-1, nRight-1 )
  1435.         oObj:varPut( MEMOEDIT( oObj:varGet(), nTop+1, nLeft+2, ;
  1436.                      nBottom-1, nRight-2 ) )
  1437.         RESTSCREEN( nTop, nLeft, nBottom, nRight, cScr )
  1438.         oObj:exitState := GE_NOEXIT
  1439.  
  1440.    CASE nKey == K_UP
  1441.         oObj:exitState := GE_UP
  1442.  
  1443.    CASE nKey == K_SH_TAB
  1444.         oObj:exitState := GE_UP
  1445.  
  1446.    CASE nKey == K_DOWN
  1447.         oObj:exitState := GE_DOWN
  1448.  
  1449.    CASE nKey == K_TAB
  1450.         oObj:exitState := GE_DOWN
  1451.  
  1452.    CASE nKey == K_ESC
  1453.         IF ( SET( _SET_ESCAPE ) )
  1454.            oObj:exitState := GE_ESCAPE
  1455.         ENDIF
  1456.  
  1457.    CASE nKey == K_PGUP
  1458.         oObj:exitState := GE_WRITE
  1459.  
  1460.    CASE nKey == K_PGDN
  1461.         oObj:exitState := GE_WRITE
  1462.  
  1463.    CASE nKey == K_CTRL_HOME
  1464.         oObj:exitState := GE_TOP
  1465.  
  1466. ENDCASE
  1467. SETCOLOR( curColor )
  1468. SETKEY(K_F2, cCurK2)              && Restore the function keys
  1469. SETKEY(K_F3, cCurK3)
  1470. RETURN (NIL)
  1471.  
  1472.  
  1473. FUNCTION memoBox( nTop, nLeft, nBottom, nRight, cMemoStr, cColor, colorType)
  1474. ******************************************************************************
  1475. * Function......: MEMOBOX()
  1476. * System........:
  1477. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  1478. * Description...: Displays a memo box and a string within the confines of
  1479. * ..............: box using the MEMOLINE and MLCOUNT functions to provide
  1480. * ..............: line wrapping.
  1481. * Version.......: 1.00
  1482. * Language......: Clipper 5.2c
  1483. * Parameters....: 4 box coordinates, character string
  1484. * Returns.......: NIL
  1485. * Last Rev. Date: 12/06/93
  1486. * Last Rev. Time: 10:40
  1487. ******************************************************************************
  1488. LOCAL nLines := nBottom - nTop - 1, i := 1, nlineLen := nRight - nLeft - 3, ;
  1489.    lWrap := .t., saveColor, curColor, useColor, cRemStr
  1490.  
  1491. curColor = SETCOLOR()
  1492. IF cColor <> NIL && If COLOR option was specified, use it
  1493.    * Parse the color string for the Standard and Enhanced colors
  1494.    stdColor := SUBSTR( cColor, 1, AT(",", cColor) - 1 )  && Standard color
  1495.    enhColor := SUBSTR( cColor, AT(",", cColor) + 1 )     && Enh. color for GET
  1496.  ELSE  && Otherwise, use current colors:
  1497.    stdColor := SUBSTR( curColor, RAT(",", curColor) + 1 ) && Unsel
  1498.    nFirstCom:= AT(",",curColor) + 1
  1499.    cRemStr := SUBSTR( curColor, AT(",", curColor) + 1 )  && Enhanced
  1500.    enhColor := SUBSTR( cRemStr, 1, AT(",", cRemStr) - 1 )
  1501. ENDIF
  1502. useColor = IIF( colorType, enhColor, stdColor )
  1503. SETCOLOR( useColor )
  1504. @ nTop, nLeft CLEAR TO nBottom, nRight
  1505. @ nTop, nLeft, nBottom, nRight BOX "█▀███▄██" COLOR useColor
  1506. FOR i := 1 TO nLines
  1507.  @ nTop + i, nLeft + 2 SAY MEMOLINE( cMemoStr, nlineLen, i,, lWrap )
  1508. NEXT
  1509. SETCOLOR( curColor )
  1510. RETURN NIL
  1511.  
  1512.  
  1513. FUNCTION indexBar( aColors )
  1514. ******************************************************************************
  1515. * Function......: INDEXBAR()                                                 *
  1516. * System........: HM/ODC DATABASE MANAGER                                    *
  1517. * Version.......: 1.1                                                        *
  1518. * Author........: Mark J. Wallin, Ph.D., SEMCOR, Inc., based on an article   *
  1519. * ..............: by Greg Lief, DBMS Mag. 12/91, p.82.                       *
  1520. * Description...: Displays a status bar when indexing, via a command         *
  1521. * ..............: replacement: INDEX ON...TO... GRAPH                        *
  1522. * Language......: Clipper 5.2c                                               *
  1523. * Parameters....: None                                                       *
  1524. * Returns.......: NIL                                                        *
  1525. * Last Rev. Date: 04/23/93                                                   *
  1526. * Last Rev. Time: 11:23                                                      *
  1527. ******************************************************************************
  1528. STATIC nLastRec
  1529. STATIC nScreen
  1530. STATIC nGraphLen
  1531. STATIC nSpacing
  1532. LOCAL nCurRec := RECNO()
  1533. LOCAL ii := 1
  1534.  
  1535. *RETURN .t.
  1536. IF nLastrec == Nil
  1537.    // Establish Nlastrec AND Ngraphlen Variables.
  1538.    nLastRec := LASTREC()
  1539.    nSpacing := nLastrec/60
  1540.    nGraphlen := 0
  1541.  
  1542.    //Save screen and draw initial box.
  1543.    nScreen := scrnSave(12, 08, 14, 71)
  1544.    @12,08, 14, 71 BOX B_SINGLE + ' ' COLOR( aColors[COLHELP])
  1545.    @12,10 SAY "[Indexing " + UPPER(ALIAS()) + "]" COLOR(aColors[COLHELP])
  1546.    @13,10 SAY REPLICATE(CHR(178),60) COLOR(aColors[COLHELP])
  1547.    SETPOS(13, 10)
  1548.  
  1549.    //If the data file is empty clear the screen and reset variables
  1550.    IF nLastrec = 0
  1551.       @ 13, 10 Say REPLICATE(CHR(219),60) COLOR(aColors[COLHELP])
  1552.       scrnRest( nScreen )
  1553.       nLastrec := NIL
  1554.       nGraphLen := NIL
  1555.    ENDIF
  1556.  
  1557.  ELSE
  1558.    //Display characters only if necessary
  1559.    IF nGraphLen != INT(nCurRec/nSpacing)
  1560.       nGraphLen++
  1561.  
  1562.       IF nLastRec < 60
  1563.          FOR ii := 1 TO INT(1/nSpacing)
  1564.              DISPOUT(CHR(219),'+W/RB')
  1565.          NEXT ii
  1566.        ELSE
  1567.          DISPOUT(CHR(219),'+W/RB')
  1568.       ENDIF
  1569.    ENDIF
  1570.  
  1571.    IF nCurRec == nLastRec
  1572.        //If we are finished, restore screen and reset Nlastrec and Ngraphlen
  1573.        scrnRest( nScreen )
  1574.        nLastRec := NIL
  1575.        nGraphLen := NIL
  1576.     ENDIF
  1577. ENDIF
  1578. RETURN .t.
  1579.  
  1580.  
  1581. FUNCTION dispSemLogo( aColors )
  1582. ******************************************************************************
  1583. * Function......: DISPSEMLOGO()
  1584. * System........: ODC DATABASE SYSTEM
  1585. * Version.......: 1.1
  1586. * Author........: Mark J. Wallin, Ph.D.
  1587. * Description...: Startup logo.
  1588. * Copyright.....: 1993,  Mark J. Wallin, SEMCOR, Inc.
  1589. * Language......: Developed to be run under CLIPPER 5.2c
  1590. * Last Rev. Date: 01/11/94
  1591. * Last Rev. Time: 11:39
  1592. ******************************************************************************
  1593. LOCAL saveCursor, saveColor
  1594. saveCursor := SETCURSOR( SC_NONE )
  1595. saveColor := SETCOLOR( aColors[COLBKGD] )
  1596. @ 0, 0, 24, 79 BOX "▒▒▒▒▒▒▒▒▒"
  1597. *SETCOLOR( saveColor )
  1598. SETCOLOR( aColors[COLSTD])
  1599. @ 3, 2 SAY "                                                                          "
  1600. @ 4, 2 SAY "                                ▄████▄ ███████                            "
  1601. @ 5, 2 SAY "                                ██████▄ ██████                            "
  1602. @ 6, 2 SAY "                                 ▀█████▄ █████                            "
  1603. @ 7, 2 SAY "                                █ ▀█████▄ ████                            "
  1604. @ 8, 2 SAY "                                ██ ▀█████▄ ███                            "
  1605. @ 9, 2 SAY "                                ███ ▀█████▄ ██                            "
  1606. @10, 2 SAY "                                ████ ▀█████▄ █                            "
  1607. @11, 2 SAY "                                █████ ▀█████▄                             "
  1608. @12, 2 SAY "                                ██████ ▀██████                            "
  1609. @13, 2 SAY "                                ███████ ▀████▀                            "
  1610. SETCOLOR( aColors[COLLOGO] )
  1611. @14, 2 SAY "              ┌─────╖ ┌─────╖ ┌───────╖ ┌─────╖ ┌─────╖ ┌──────╖          "
  1612. @15, 2 SAY "              │ ╔═══╝ │ ╔═══╝ │ ╔╕ ╔╕ ║ │ ╔═╕ ║ │ ╔═╕ ║ │ ╔══╕ ║          "
  1613. @16, 2 SAY "              │ ╙───╖ │ ╙─╖   │ ║│ ║│ ║ │ ║ ╘═╝ │ ║ │ ║ │ ╙──┘ ║          "
  1614. @17, 2 SAY "              ╘═══╕ ║ │ ╔═╝   │ ║╘═╝│ ║ │ ║ ┌─╖ │ ║ │ ║ │ ╔═╕ ╔╝          "
  1615. @18, 2 SAY "              ┌───┘ ║ │ ╙───╖ │ ║   │ ║ │ ╙─┘ ║ │ ╙─┘ ║ │ ║ │ ╙╖          "
  1616. @19, 2 SAY "              ╘═════╝ ╘═════╝ ╘═╝   ╘═╝ ╘═════╝ ╘═════╝ ╘═╝ ╘══╝          "
  1617. @20, 2 SAY "                                                                          "
  1618. sha_shadow( 3, 2,20,75 )
  1619. INKEY(3)                  && Pause 3 seconds
  1620. CLEAR SCREEN
  1621. SETCURSOR( saveCursor )
  1622. SETCOLOR( saveColor )
  1623. RETURN NIL
  1624.  
  1625.  
  1626. FUNCTION RadioGets(bVar, cVar, aChoices, aGetList, cLocType)
  1627. ******************************************************************************
  1628. * Function......: RADIOGETS()
  1629. * System........: HM/ODC Database Manager
  1630. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  1631. * Description...: Issue radio button GETS for array of character strings
  1632. * ..............: contained in aChoices.  bVar is a GET/SET block for the
  1633. * ..............: GET variable, cVar is the variable name. From an article
  1634. * ..............: by Rick Spence, DBA, Jan. '93, pp 121.
  1635. * ..............: Modification: added a parameter to enable horizontal or
  1636. * ..............: vertical stacking of buttons.
  1637. * Version.......: 1.00
  1638. * Language......: Clipper 5.2c
  1639. * Parameters....: bVar - GET/SET block, cVar - variable name, array of
  1640. * ..............: choices, Getlist, layout - HORIZ or VERT
  1641. * Returns.......: NIL
  1642. * Last Rev. Date: 12/15/93
  1643. * Last Rev. Time: 12:27
  1644. ******************************************************************************
  1645.  
  1646. LOCAL oGet
  1647. LOCAL nRow := Row(), nCol := Col()
  1648. LOCAL nGets := Len(aChoices)
  1649. LOCAL nGet
  1650. LOCAL nStartGet := Len(aGetList) + 1
  1651. LOCAL nSaveRow, nSaveCol
  1652.  
  1653.   // For each element in aChoices
  1654.   FOR nGet := 1 To nGets
  1655.  
  1656.       // Display ( ) before the get
  1657.       DevPos(nRow, nCol)
  1658.       DevOut("( ) ")
  1659.  
  1660.       // Create an empty get object and add it to the list
  1661.       oGet := GetNew()
  1662.       Aadd(aGetList, oGet)
  1663.  
  1664.       // Its position is 4 spaces to the right of the cursor
  1665.       // (just past ( ) )
  1666.       oGet:col := nCol + 4
  1667.       // Modification by Mark J. Wallin to allow for both Horizontal and
  1668.       // vertical display of the GET's.
  1669.       IF cLocType == VERTICAL
  1670.          // We increment the row number so the gets are displayed vertically
  1671.          oGet:row   := nRow++
  1672.        ELSE
  1673.          // We add the length of the current choice text to the column so the
  1674.          // GET's are displayed horizontally.
  1675.          // Be careful not to go off the end of the screen!
  1676.          oGet:row := nRow
  1677.          nCol := nCol + LEN(aChoices[nGet]) + 5
  1678.       ENDIF
  1679.       // Set get:name for hot keys
  1680.       oGet:name := cVar
  1681.  
  1682.  // Here's where it gets a bit tricky. The get object's get/set
  1683.  // block must just return the character string describing the
  1684.  // radio button ("Amex", e.g. ). We cannot, however, set it as:
  1685.  //   {|| aChoices[nGet] }
  1686.  // as this code block is reevaluated at READ time when nGet is
  1687.  // invalid. We solve the problem with a detached local.
  1688.       oGet:block := t(aChoices[nGet])
  1689.  
  1690.  // Cargo is an arry of two elements. The first element contains
  1691.  // the get/set block for the real variable, the second element
  1692.  // is an array of offsets inside getlist of the other gets that
  1693.  // comprise the radio buttons
  1694.       oGet:cargo := {bVar, Array(nGets)}
  1695.  
  1696.  // Fill cargo[2] with element numbers of other gets in radio
  1697.  // button list. nStartGet is the element number of the first one.
  1698.       Aeval(oGet:cargo[2], {|x, n| oGet:cargo[2, n] := nStartGet + n - 1})
  1699.  
  1700.  // Radio gets have their own reader, of course
  1701.       oGet:reader := {|o| RadioReader(o, aGetList, cLocType) }
  1702.       oGet:display()
  1703.   NEXT
  1704. RETURN oGet
  1705.  
  1706. // Just return a code block, which, when evaluated, will return c.
  1707. // As the returned code block references a local variable that variable
  1708. // becomes "detached" from the activation stack.
  1709. FUNCTION t(c)
  1710. RETURN {|x| c }
  1711.  
  1712.  
  1713. Proc RadioReader( oGet, aGetList, cLocType )
  1714. ******************************************************************************
  1715. * Function......: RADIOREADER()
  1716. * System........: HM/ODC Database Manager
  1717. * Version.......: 1.1
  1718. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  1719. * Description...: Reader for radio buttons GET object [from Rick Spence.]
  1720. * Language......: Clipper 5.2c
  1721. * Parameters....: oGet - GET object, aGetList - local GET list, cLocType -
  1722. * ..............: choices, Getlist, layout - HORIZ or VERT
  1723. * Returns.......: NIL
  1724. * Last Rev. Date: 12/15/93
  1725. * Last Rev. Time: 12:27
  1726. ******************************************************************************
  1727.  
  1728. LOCAL cSaveKey
  1729. * Disable our F2 function key during this routine:
  1730. *cSaveKey := SETKEY(K_F2,NIL)
  1731. // read the GET if the WHEN condition is satisfied
  1732. IF ( GetPreValidate(oGet) )
  1733.    // activate the GET for reading
  1734.    oGet:SetFocus()
  1735.  
  1736.    DO WHILE ( oGet:exitState == GE_NOEXIT )
  1737.       // check for initial typeout (no editable positions)
  1738.       IF ( oGet:typeOut )
  1739.          oGet:exitState := GE_ENTER
  1740.       ENDIF
  1741.  
  1742.       // apply keystrokes until exit
  1743.       DO WHILE ( oGet:exitState == GE_NOEXIT )
  1744.          RadioApplyKey(oGet, InKey(0), aGetList, cLocType)
  1745.       ENDDO
  1746.  
  1747.       // disallow exit if the VALID condition is not satisfied
  1748.       IF ( !GetPostValidate(oGet) )
  1749.          oGet:exitState := GE_NOEXIT
  1750.       ENDIF
  1751.    ENDDO
  1752.  
  1753.    // de-activate the GET
  1754.    oGet:KillFocus()
  1755. ENDIF
  1756. RETURN
  1757.  
  1758.  
  1759. PROC RadioApplyKey(oGet, nKey, aGetList, cLocType)
  1760. ******************************************************************************
  1761. * Function......: RADIOAPPLYKEY()
  1762. * System........: HM/ODC Database Manager
  1763. * Version.......: 1.1
  1764. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  1765. * Description...: Key function for radio buttons GET object [from Rick Spence].
  1766. * Language......: Clipper 5.2c
  1767. * Parameters....: oGet - GET object, aGetList - local GET list, cLocType -
  1768. * Returns.......: NIL
  1769. * Last Rev. Date: 12/15/93
  1770. * Last Rev. Time: 12:27
  1771. ******************************************************************************
  1772. LOCAL cKey
  1773. LOCAL bKeyBlock
  1774. LOCAL nSaveRow, nSaveCol
  1775. LOCAL cSaveKey
  1776. * Disable our F2 function key during this routine:
  1777. *cSaveKey := SETKEY(K_F2,NIL)
  1778.  
  1779. // check for SET KEY first
  1780. IF ( (bKeyBlock := SetKey(nKey)) <> NIL )
  1781.    GetDoSetKey(bKeyBlock, oGet)
  1782.    SETKEY(K_F2, cSaveKey)
  1783.    RETURN // NOTE
  1784. ENDIF
  1785.  
  1786. DO CASE
  1787.    CASE ( nKey == K_UP )
  1788.         oGet:exitState := GE_UP
  1789.  
  1790.    CASE ( nKey == K_LEFT ) .AND. cLocType == HORIZONTAL
  1791.         oGet:exitState := GE_UP
  1792.  
  1793.    CASE ( nKey == K_SH_TAB )
  1794.         oGet:exitState := GE_UP
  1795.  
  1796.    CASE ( nKey == K_DOWN )
  1797.         oGet:exitState := GE_DOWN
  1798.  
  1799.    CASE (nKey == K_RIGHT ) .AND. cLocType == HORIZONTAL
  1800.         oGet:exitState := GE_DOWN
  1801.  
  1802.    CASE ( nKey == K_TAB )
  1803.         oGet:exitState := GE_DOWN
  1804.  
  1805.    CASE ( nKey == K_ENTER )
  1806.         oGet:exitState := GE_ENTER
  1807.  
  1808.    CASE nKey == K_SPACE
  1809.         // Toggle state of this radio button. If the get
  1810.         // currently contains this radio button, clear it.
  1811.         // If it does not, set it to that value
  1812.         IF Eval(oGet:cargo[1]) == Eval(oGet:block)
  1813.            Eval(oGet:cargo[1], "")
  1814.          ELSE
  1815.            Eval(oGet:cargo[1], Eval(oGet:block))
  1816.         ENDIF
  1817.  
  1818.         // And redraw the getlist
  1819.         DrawRadios(aGetlist, oGet)
  1820.  
  1821.    CASE ( nKey == K_ESC )
  1822.         IF ( Set(_SET_ESCAPE) )
  1823.            oGet:undo()
  1824.            oGet:exitState := GE_ESCAPE
  1825.         ENDIF
  1826.  
  1827.    CASE (nKey == K_PGUP )
  1828.         oGet:exitState := GE_WRITE
  1829.  
  1830.    CASE (nKey == K_PGDN )
  1831.         oGet:exitState := GE_WRITE
  1832.  
  1833.    CASE ( nKey == K_CTRL_HOME )
  1834.         oGet:exitState := GE_TOP
  1835.  
  1836.    // both ^W and ^End terminate the READ (the default)
  1837.    CASE (nKey == K_CTRL_W)
  1838.         oGet:exitState := GE_WRITE
  1839.  
  1840.    CASE (nKey == K_INS)
  1841.         Set( _SET_INSERT, !Set(_SET_INSERT) )
  1842.  
  1843. ENDCASE
  1844. *SETKEY(K_F2, cSaveKey )  && Reactivate the F2 key
  1845. RETURN
  1846.  
  1847.  
  1848. PROC DrawRadios(aGetList, oGet)
  1849. ******************************************************************************
  1850. * Function......: DRAWRADIOS()
  1851. * System........: HM/ODC Database Manager
  1852. * Version.......: 1.1
  1853. * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ
  1854. * Description...: Draws all radio buttons in aGetList to which the GET object
  1855. * ..............: oGet is attached [from Rick Spence].
  1856. * Language......: Clipper 5.2c
  1857. * Parameters....: aGetList, oGet - local GET object
  1858. * Returns.......: NIL
  1859. * Last Rev. Date: 12/15/93
  1860. * Last Rev. Time: 12:27
  1861. ******************************************************************************
  1862. LOCAL cSelected := Eval(oGet:cargo[1])
  1863. LOCAL nRadios := Len(oGet:cargo[2])
  1864. LOCAL oGet1, nSaveRow := Row(), nSaveCol := Col(), nGet
  1865.  
  1866. FOR nGet := 1 TO nRadios
  1867.     oGet1 := aGetList[oGet:cargo[2, nGet]]
  1868.     DevPos(oGet1:row, oGet1:col - 3)
  1869.     IF Eval(oGet1:cargo[1]) == Eval(oGet1:block)
  1870.        DevOut(RADIO_BUTTON)
  1871.      ELSE
  1872.        DevOut(" ")
  1873.     ENDIF
  1874. NEXT
  1875. DevPos(nSaveRow, nSaveCol)
  1876. RETURN
  1877.  
  1878.  
  1879. * MULTIUSER FUNCTIONS FOR NETWORKING:
  1880.  
  1881. FUNCTION netUse( cFileName, cFileAlias, lExclUse, nWaitTime )
  1882. ******************************************************************************
  1883. * Function......: NETUSE()                                                   *
  1884. * System........: CREDIT COLLECTIONS DATABASE MANAGER                        *
  1885. * Version.......: 2.0                                                        *
  1886. * Author........: Mark J. Wallin, Ph.D.                                      *
  1887. * Description...: Trys to open a file for exclusive or shared use.           *
  1888. * ..............: SET INDEXes in calling procedure if successful.            *
  1889. * ..............: Pass the following parameters                              *
  1890. * ..............:    1. Character - name of the .DBF file to open            *
  1891. * ..............:    2. Logical - mode of open (exclusive/.NOT. exclusive)   *
  1892. * ..............:    3. Numeric - seconds to wait (0 = wait forever)         *
  1893. * Copyright.....: 1990-1994, Mark J. Wallin, 21st Century Computing          *
  1894. * Language......: CLIPPER 5.2c                                               *
  1895. * Parameters....: Name of File to be opened, Alias of File, Exclusive .t./.f.*
  1896. * ..............: retry time in seconds                                      *
  1897. * Returns.......: .t./.f.                                                    *
  1898. * Last Rev. Date: 01/20/94                                                   *
  1899. * Last Rev. Time: 00:51                                                      *
  1900. ******************************************************************************
  1901. LOCAL lWait, lRetVal := .t., nTime, cCurFile, cMsgScrn, cCurCursor, ;
  1902.       cCurColor, cCurScrn, lOutLoop := .t.
  1903.  
  1904. *  Example:
  1905. *    IF netUse("file","file", .t., 5)
  1906. *       SET INDEX TO indexFile
  1907. *     ELSE
  1908. *       msg( "File not available" )
  1909. *    ENDIF
  1910.  
  1911. cCurScrn  := scrnSave(0, 0,24,79)            && Save current screen, colors
  1912. cCurColor := SETCOLOR( aColors[COLMSG] )     && and set cursor off
  1913. cCurCursor:= SETCURSOR( SC_NONE )
  1914.  
  1915. nTime := nWaitTime
  1916. lWait := (nWaitTime == 0)
  1917. DO WHILE (forever .OR. wait_time > 0)
  1918.    * Check to see if the file is already opened in some user area under its'
  1919.    * name or its' alias.  If already open, close it.  Then try to re-open it
  1920.    * in the specified shared or exclusive mode.
  1921.    IF SELECT( cFileName) <> 0                  && 012094mjw
  1922.       SELECT (cFileName)
  1923.       USE
  1924.     ELSE
  1925.       IF SELECT(cFileAlias) <> 0
  1926.          SELECT (cFileAlias)
  1927.          USE
  1928.       ENDIF
  1929.    ENDIF
  1930.    IF lExclUse                                          && Open Exclusive
  1931.       USE (cFileName) NEW EXCLUSIVE ALIAS ( cFileAlias )
  1932.     ELSE                                                && Open Shared
  1933.       USE (cFileName) NEW ALIAS (cFileAlias)
  1934.    ENDIF
  1935.    IF .NOT. NETERR()                                    && USE succeeds
  1936.       lRetVal := .t.
  1937.       EXIT
  1938.    ENDIF
  1939.    cMsgScrn := msg("Attempting to open file",0)
  1940.    IF LASTKEY() == 27 .OR. nWaitTime == 0  && User pressed <Esc> or timeout
  1941.       nQuery := ALERT("Attempt to open file was unsuccessful: Retry?",;
  1942.                       {"Yes","No"})
  1943.       IF nQuery <> 1
  1944.          lRetVal := .f.
  1945.          EXIT
  1946.        ELSE
  1947.          scrnRest( cMsgScrn )
  1948.          IF nWaitTime == 0
  1949.             nWaitTime := nTime
  1950.          ENDIF
  1951.       ENDIF
  1952.    ENDIF
  1953.    nWaitTime := nWaitTime - 1
  1954. ENDDO
  1955. SETCOLOR(cCurColor)
  1956. SETCURSOR(cCurCursor)
  1957. scrnRest(cCurScrn)
  1958. RETURN lRetVal
  1959.  
  1960.  
  1961. FUNCTION appendRec( nWaitTime )
  1962. ******************************************************************************
  1963. * Function......: APPENDREC()                                                *
  1964. * System........: Library Function                                           *
  1965. * Version.......: 1.1                                                        *
  1966. * Author........: Mark J. Wallin, Ph.D.                                      *
  1967. * Description...: Multi-user function to append a blank record in a data     *
  1968. * ..............: file.  Allows the user to abort if the attempt fails.      *
  1969. * Copyright.....: 1990-1994, Mark J. Wallin, 21st Century Computing          *
  1970. * Language......: Developed to be run under CLIPPER 5.2c                     *
  1971. * Parameters....: wait_time in seconds: 0 = wait forever.                    *
  1972. * Returns.......: NIL                                                        *
  1973. * Last Rev. Date: 01/05/94                                                   *
  1974. * Last Rev. Time: 00:47                                                      *
  1975. ******************************************************************************
  1976. LOCAL lForever, nTime, cCurFileName, lRetVal := .t.
  1977. LOCAL lOutLoop := .t.
  1978. LOCAL cCurScrn, cCurColor, cCurCursor
  1979.  
  1980. cCurFileName := ALIAS()
  1981. nTime := nWaitTime
  1982.  
  1983. APPEND BLANK                                 && Try to append a blank
  1984. IF .NOT. NETERR()
  1985.    RETURN lRetVal                            && APPEND was successful
  1986. ENDIF
  1987.  
  1988. cCurScrn  := scrnSave(0, 0,24,79)            && Save current screen, colors
  1989. cCurColor := SETCOLOR( aColors[COLMSG] )     && and set cursor off
  1990. cCurCursor:= SETCURSOR( SC_NONE )
  1991.  
  1992. lForever  := (nWaitTime == 0)
  1993.  
  1994. DO WHILE lOutLoop
  1995.    DO WHILE ( lForever .OR. nWaitTime > 0 )
  1996.       INKEY(.5)                              && Pause for 1/2 second
  1997.       nWaitTime := nWaitTime - .5            && Decrement 1/2 second
  1998.       APPEND BLANK
  1999.       IF .NOT. neterr()
  2000.          lRetVal   := .t.
  2001.          RETURN lRetVal
  2002.       ENDIF
  2003.       cMsgScrn := msg("Attempting to Add Record",0)
  2004.       *cMsgScrn := msg("PLEASE WAIT: Unable to add record",0)
  2005.       *IF TYPE("lwin") = "U"    &&  Window not opened yet
  2006.       *   lwin = WINDOW(9,25,16,56,.t.,"PLEASE WAIT")
  2007.       *   @ 13,31 say 'Unable to add record'
  2008.       *   SAY_CEN(14,80,'('+upper(file_alias)+')')
  2009.       *end if
  2010.       IF LASTKEY() == 27 .OR. nWaitTime == 0  && User pressed <Esc> or timeout
  2011.          nQuery := ALERT("Attempt to add record was unsuccessful: Retry?",;
  2012.                          {"Yes","No"})
  2013.          IF nQuery <> 1
  2014.             lOutLoop = .f.
  2015.             lRetVal := .f.
  2016.             EXIT
  2017.           ELSE
  2018.             scrnRest( cMsgScrn )
  2019.             IF nWaitTime == 0
  2020.                nWaitTime := nTime
  2021.             ENDIF
  2022.          ENDIF
  2023.       ENDIF
  2024.    ENDDO
  2025. ENDDO
  2026. SETCOLOR(cCurColor)
  2027. SETCURSOR(cCurCursor)
  2028. scrnRest(cCurScrn)
  2029. RETURN lRetVal
  2030.  
  2031.  
  2032. FUNCTION recLock( nWaitTime )
  2033. ******************************************************************************
  2034. * Function......: RECLOCK()                                                  *
  2035. * System........: Library Function                                           *
  2036. * Version.......: 1.1                                                        *
  2037. * Author........: Mark J. Wallin, Ph.D.                                      *
  2038. * Description...: Locks a record, allowing user to abort if lock fails.      *
  2039. * ..............:                                                            *
  2040. * Copyright.....: 1990-1994, Mark J. Wallin, 21st Century Computing          *
  2041. * Language......: Developed to be run under CLIPPER 5.2c                     *
  2042. * Parameters....: nWaitTime - seconds to wait, 0 = wait forever              *
  2043. * Returns.......: NIL                                                        *
  2044. * Last Rev. Date: 01/05/94                                                   *
  2045. * Last Rev. Time: 00:47                                                      *
  2046. ******************************************************************************
  2047. LOCAL lWait, lRetVal := .t., nTime, cCurFile, cMsgScrn, cCurCursor, ;
  2048.       cCurColor, cCurScrn, lOutLoop := .t.
  2049.  
  2050. cCurFile := ALIAS()
  2051.  
  2052. IF RLOCK()
  2053.    RETURN lRetVal                                 && Lock successful
  2054. ENDIF
  2055.  
  2056. cCurScrn  := scrnSave(0, 0,24,79)            && Save current screen, colors
  2057. cCurColor := SETCOLOR( aColors[COLMSG] )     && and set cursor off
  2058. cCurCursor:= SETCURSOR( SC_NONE )
  2059.  
  2060. lWait := ( nWaitTime == 0 )
  2061. nTime := nWaitTime
  2062. DO WHILE lOutLoop
  2063.    DO WHILE ( lWait .OR. nWaitTime > 0 )
  2064.       INKEY(.5)                              &&   Wait 1/2 second
  2065.       nWaitTime := nWaitTime - .5
  2066.       IF RLOCK()
  2067.          lRetVal := .t.
  2068.          lOutLoop = .f.
  2069.          EXIT
  2070.       ENDIF
  2071.       cMsgScrn := msg("Attempting to Lock Record",0)
  2072.       IF LASTKEY() == 27 .OR. nWaitTime == 0  && User pressed <Esc> or timeout
  2073.          nQuery := ALERT("Attempt to lock record was unsuccessful: Retry?",;
  2074.                          {"Yes","No"})
  2075.          IF nQuery <> 1
  2076.             lOutLoop = .f.
  2077.             lRetVal := .f.
  2078.             EXIT
  2079.           ELSE
  2080.             scrnRest( cMsgScrn )
  2081.             IF nWaitTime == 0
  2082.                nWaitTime := nTime
  2083.             ENDIF
  2084.          ENDIF
  2085.       ENDIF
  2086.    ENDDO
  2087. ENDDO
  2088. SETCOLOR(cCurColor)
  2089. SETCURSOR(cCurCursor)
  2090. scrnRest(cCurScrn)
  2091. RETURN lRetVal
  2092.  
  2093.  
  2094. FUNCTION fileLock( nWaitTime )
  2095. ******************************************************************************
  2096. * Function......: FILELOCK()                                                 *
  2097. * System........: CREDIT COLLECTIONS DATABASE MANAGER                        *
  2098. * Version.......: 2.0                                                        *
  2099. * Author........: Mark J. Wallin, Ph.D.                                      *
  2100. * Description...: Attempts to lock the current shared file.                  *
  2101. * Copyright.....: 1990-1994, Mark J. Wallin, 21st Century Computing          *
  2102. * Language......: Developed to be run under CLIPPER 5.2c                     *
  2103. * Parameters....: Retry time in seconds, 0 = forever                         *
  2104. * Returns.......: .t./.f.                                                    *
  2105. * Last Rev. Date: 01/05/94                                                   *
  2106. * Last Rev. Time: 00:47                                                      *
  2107. ******************************************************************************
  2108. LOCAL lWait, lRetVal := .t., nTime, cCurFile, cMsgScrn, cCurCursor, ;
  2109.       cCurColor, cCurScrn
  2110.  
  2111. IF FLOCK()
  2112.    RETURN lRetVal                                  && Lock was successful
  2113. ENDIF
  2114.  
  2115. cCurScrn  := scrnSave(0, 0,24,79)            && Save current screen, colors
  2116. cCurColor := SETCOLOR( aColors[COLMSG] )     && and set cursor off
  2117. cCurCursor:= SETCURSOR( SC_NONE )
  2118.  
  2119. nTime := nWaitTime
  2120. lWait := (nWaitTime == 0)
  2121. DO WHILE (forever .OR. wait_time > 0)
  2122.    IF FLOCK                                             && Open Exclusive
  2123.       lRetVal := .t.
  2124.       EXIT
  2125.    ENDIF
  2126.    cMsgScrn := msg("Attempting to lock file",0)
  2127.    IF LASTKEY() == 27 .OR. nWaitTime == 0  && User pressed <Esc> or timeout
  2128.       nQuery := ALERT("Attempt to lock file was unsuccessful: Retry?",;
  2129.                       {"Yes","No"})
  2130.       IF nQuery <> 1
  2131.          lRetVal := .f.
  2132.          EXIT
  2133.        ELSE
  2134.          scrnRest( cMsgScrn )
  2135.          IF nWaitTime == 0
  2136.             nWaitTime := nTime
  2137.          ENDIF
  2138.       ENDIF
  2139.    ENDIF
  2140.    nWaitTime := nWaitTime - 1
  2141. ENDDO
  2142. SETCOLOR(cCurColor)
  2143. SETCURSOR(cCurCursor)
  2144. scrnRest(cCurScrn)
  2145. RETURN lRetVal
  2146.