POINT Software Programming

home *** CD-ROM | disk | FTP | other *** search

/ POINT Software Programming / PPROG1.ISO / clipper / cliplib / semlib.prg < prev

Wrap

Text File | 1994-01-20 | 81.3 KB | 2,146 lines

****************************************************************************** * Title.........: SEMLIB.PRG (Library routines) * * Author........: Mark J. Wallin, Ph.D., * * Description...: Various common functions for Clipper applications. * * Copyright.....: 1993, 1994 Mark J. Wallin, SEMCOR, Inc. * * Version.......: 1.1 * * Language......: Clipper 5.2c * * Last Rev. Date: 01/20/94 * * Last Rev. Time: 00:52 * ****************************************************************************** #include "setcurs.ch" #include "getexit.ch" #include "inkey.ch" #include "box.ch" #include "error.ch" #include "set.ch" #include "directry.ch" #include "projfile.ch" * Define Color Array Index Constants #define COLSTD 1 #define COLGET 2 #define COLTITL 3 #define COLMEN 4 #define COLSHD 5 #define COLSTAT 6 #define COLBKGD 7 #define COLBOX 8 #define COLMSG 9 #define COLFLSH 10 #define COLLOGO 11 #define COLHELP 12 #define SHADOWON .t. #define SHADOWOFF .f. #define ENHANCED .t. #define UNENHANCED .f. * SoftSEEK constants: #define EXACT .t. #define NOT_EXACT .f. FUNCTION pullDown(aList,aSelect,menuColor,pop,topRow,topLeftCol,; cBorder,lShadow) ****************************************************************************** * Title....: PULLDOWN() (Library routine first dev. by Mark J. Wallin) * * System...: ODC DATABASE SYSTEM * * Author...: Mark J. Wallin, Ph.D. * * Company..: Copyright 1993, SEMCOR, Inc. * * Last Rev.: 11/30/93 * * Purpose..: Displays a self-sizing pulldown menu with optional shadow. * * Parameter: Array of menu items, color of menu, pop-up (t/f), top row, * * .........: top left column, border string (or NIL), shadow (.t./.f.) * * Returns..: numeric value of choice, 0 if <Esc> pressed * ****************************************************************************** MEMVAR mhelpvar LOCAL numItems, boxWidth, boxTopRow, boxBotRow, boxLftCol, boxRgtCol, oldColor LOCAL cScreen, nChoice, nKey := LASTKEY(), nOffset := 1, menuWidth, ; boxShadWidth, maxHeight, maxRgtCol * oldColor = SETCOLOR(menuColor) * Size the pop-up box from the maximum width of the menu items and the number * of menu items IF VALTYPE(cBorder) <> "C" && If cBorder is NIL cBorder = "┌─┐│┘─└│" && Default border ENDIF numItems := LEN(aList) && Number of elements in array maxHeight:= numItems && Assumes we have enough room! menuWidth := maxArray(aList) && Maximum width of PROMPTS boxWidth := menuWidth + 2 boxShadWidth := boxWidth IF lShadow boxShadWidth++ maxHeight++ ENDIF IF topRow == NIL && If top row not specified: boxTopRow := INT((25 - numItems)/2) - 1 && center the box. ELSE && Otherwise, use specified row boxTopRow := topRow ENDIF IF topLeftCol == NIL && If left col. not specified: boxLftCol := INT((80 - boxWidth)/2) && center the box. ELSE && Otherwise, use spec'd. col. boxLftCol := topLeftCol ENDIF boxBotRow := boxTopRow + numItems + 1 && Bottom row of box ( < 25) maxBotRow := boxTopRow + maxHeight + 1 && Bottom row w/shadow, if any boxRgtCol := boxLftCol + boxWidth - 1 && Right column of box maxRgtCol := boxLftCol + boxShadWidth - 1 && (including shadow, if any) IF maxRgtCol > MAXCOL() && If the box is partly maxRgtCol := MAXCOL() && off screen, adjust left col. boxRgtCol := MAXCOL() - 1 boxLftCol := MAXCOL() - boxWidth && MAXCOL() - 1 + ... - 1 ENDIF IF pop && If this is a popup menu which disappears after choice && Save the underlying screen area: cScreen := SAVESCREEN(boxTopRow,boxLftCol,maxBotRow,maxRgtCol) ENDIF txtLeftCol := boxLftCol + 1 txtRgtCol := boxLftCol + menuWidth - 1 @ boxTopRow,boxLftCol,boxBotRow,boxRgtCol BOX cBorder COLOR menuColor IF lShadow sha_shadow(boxTopRow,boxLftCol,boxBotRow,boxRgtCol) ENDIF * Pop up the menu using ACHOICE, store selection in nChoice: *mHelpVar := "ALIST" oldColor = SETCOLOR(menuColor) nChoice := ACHOICE(boxTopRow+1,boxLftCol+nOffset,boxBotRow-1, ; boxRgtCol-nOffset,aList,aSelect) && ,"cUserFunction") SETCOLOR( oldColor ) *mHelpVar := "" IF pop && If this is a popup menu which disappears after choice && Restore the underlying screen & colors RESTSCREEN(boxTopRow,boxLftCol,maxBotRow,maxRgtCol,cScreen) ENDIF *SETCOLOR(oldColor) && Restore original screen colors RETURN nChoice FUNCTION moveptr( moveType, nFile, nIndOrder, cFilterExp, a1, aKeyVals ) ****************************************************************************** * Function......: MOVEPTR() * System........: ODC DOCUMENT DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: Moves record pointer for NEXT, PREVIOUS, TOP, BOTTOM with * ..............: limits set by common key. * Copyright.....: 1993, Mark J. Wallin, SEMCOR, Inc. * Version.......: 1.00 * Language......: Developed to be run under CLIPPER 5.2c * Parameters....: * Returns.......: NIL * Last Rev. Date: 12/22/93 * Last Rev. Time: 09:38 ****************************************************************************** LOCAL saveOrd, curRec, cMsgScrn *LOCAL xFilter := { ".t.", "docVer->doc_key == aKeyVals[ fDOCUM ]", ; * "odcHits->rcv_key == aKeyVals [ fDOCVER ]" } LOCAL xFilter := { {|| .t. }, {|| docVer->doc_key == aKeyVals[ fDOCUM ] },; {|| odcHits->rcv_key == aKeyVals[ fDOCVER ] } } saveOrd := INDEXORD() && Save current index order curRec := RECNO() && Save current record position * Sample Filters: * DOCUM -> filter = "" && No filter * DOCVER-> filter = docVer->doc_id = aKeyVals[ fDOCUM ] && Filter: doc. id * DOCHIT-> filter = odcHits->hit_id = aKeyVals [ fDOCVER ] && Filter: rev. id cFilterExp := xFilter[ nFile ] && Use internal filter instead of passed val. IF RECCOUNT() = 0 .OR. EOF() && If no records exist or cMsgScrn := msg("No records exist",2) scrnRest( cMsgScrn ) RETURN NIL && positioned at EOF, abort move ENDIF SET ORDER TO 1 *IF EMPTY(xfilter) * xfilter = "dummy" *ENDIF DO CASE CASE moveType == "N" && NEXT record IF .NOT. EOF() SKIP * IF EOF() .OR. .NOT. &(cFilterExp) IF EOF() .OR. .NOT. EVAL(cFilterExp) SKIP -1 ?? CHR(7) IF EOF() ALERT("*** END OF FILE ***") ELSE ALERT("*** NO MORE RECORDS ***") ENDIF ENDIF ELSE ?? CHR(7) ALERT("*** END OF FILE ***") *IF .NOT. BOF() * SKIP -1 *ENDIF ENDIF CASE moveType == "P" && PREVIOUS record IF .NOT. BOF() SKIP -1 IF BOF() ?? CHR(7) ALERT("*** TOP OF FILE ***") ELSE IF .NOT. EVAL(cFilterExp) && If out of record range ?? CHR(7) ALERT("*** NO MORE RECORDS ***") SKIP ENDIF ENDIF ELSE ?? CHR(7) ALERT("*** TOP OF FILE ***") ENDIF CASE moveType == "T" && GO TO TOP Record IF VALTYPE( EVAL(cFilterExp) ) == "L" && If no range specified, GO TOP && go to the top record: ELSE && Otherwise, skip backward DO WHILE .NOT. BOF() .AND. EVAL(cFilterExp) && until key doesn't SKIP -1 && match cFilterExp, then SKIP ENDDO && to last match IF BOF() .OR. .NOT. EVAL(cFilterExp) .AND. .NOT. EOF() SKIP ENDIF ENDIF CASE moveType == "B" && GO TO BOTTOM Record within IF VALTYPE( EVAL(cFilterExp) ) == "L" && the group matching the GO BOTTOM && filter. ELSE DO WHILE .NOT. EOF() SKIP IF .NOT. EVAL(cFilterExp) SKIP -1 EXIT ENDIF ENDDO IF EOF() SKIP -1 ENDIF ENDIF ENDCASE IF curRec <> RECNO() && If rec # not the same setFile( a1, aKeyVals, nFile ) && Display the new record * Note: Although we are passing the a1 and aKeyVals arrays by value, the * individual elements changed in SETFILE() are reflected back * as if passed by reference. ENDIF SET ORDER TO saveOrd && Restore previous index order RETURN .t. FUNCTION moveToNext( aKeyVals, nFile ) ****************************************************************************** * Function......: MOVETONEXT() * System........: HM DOCUMENT DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Copyright.....: SEMCOR, Inc., 1993 * Description...: Moves record pointer to the next record with a matching * ..............: key after a DELETE. If the key doesn't match, the pointer * ..............: is moved back to the previous matching record, if any. * Copyright.....: 1993, Mark J. Wallin, SEMCOR, Inc. * Version.......: 1.1 * Language......: Developed to be run under CLIPPER 5.2c * Parameters....: * Returns.......: NIL * Last Rev. Date: 12/06/93 * Last Rev. Time: 12:22 ****************************************************************************** LOCAL saveOrd, curRec LOCAL xFilter := { {|| .t. }, {|| docVer->doc_key == aKeyVals[ fDOCUM ] },; {|| odcHits->rcv_key == aKeyVals[ fDOCVER ] } } cFilterExp := xFilter[ nFile ] && Use internal filter instead of passed val. IF RECCOUNT() = 0 RETURN NIL ENDIF SET ORDER TO 1 * Current record was deleted: move to next or previous records with matching * keys, if possible IF .NOT. EOF() SKIP IF EOF() .OR. .NOT. EVAL(cFilterExp) SKIP -2 && Back up 2 records IF BOF() .OR. .NOT. EVAL(cFilterExp) ?? CHR(7) ALERT("*** NO MORE RECORDS ***") ENDIF ENDIF ENDIF RETURN NIL FUNCTION valData( cFieldValue, cLookup, cKeyField ) ****************************************************************************** * Function......: VALDATA() * System........: HM/ODC DOCUMENT DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Copyright.....: 1993 Mark J. Wallin, Ph.D., SEMCOR, Inc. * Description...: Validates data in a field. If the data is not present in * ..............: a specified lookup file, the user is given the option of * ..............: adding the data or re-entering it. The user can use the * ..............: F2 or F3 keys to add valid data to the field. * Version.......: 1.1 * Language......: Clipper 5.2c * Parameters....: cFieldValue = Data entered, cLookup = alias->field in * ..............: lookup file (alias) to get new data, cKeyField = field in * ..............: lookup file which gets new key code. * Returns.......: .t./.f. * Last Rev. Date: 12/28/93 * Last Rev. Time: 14:04 ****************************************************************************** LOCAL cFileName, cAppField, cCurFile, retVal := .t., cMsgScrn LOCAL getList := {} IF EMPTY(cFieldValue) && Allow a blank entry RETURN retVal ENDIF cFileName := SUBSTR( cLookup, 1, AT(">",cLookup) - 2 ) cAppField := SUBSTR( cLookup, AT(">",cLookup)+1 ) cCurFile := ALIAS() SELECT (cFileName) SET ORDER TO 2 && Order by description text SEEK cFieldValue && Look for match IF .NOT. FOUND() nQuery = ALERT("This entry was not found in the data lookup file;"+; "Do you wish to add it to the list of valid data? ",; {"Yes","No"}) IF nQuery == 1 && If user wants to add the new data: nRecCount = RECCOUNT() && Count # of records before append newKey := genKey( nRecCount, 4 ) && Generate new base36 key APPEND BLANK REPLACE &cAppField WITH cFieldValue REPLACE &cKeyField WITH newKey ENDIF ENDIF SELECT (cCurFile) RETURN retVal FUNCTION selectRec( cFileName,nIndexOrd,cTitleString,bDispString,bMatchVal,; bMatchBlk, cColorString ) ****************************************************************************** * Function......: SELECTREC() * System........: HM/ODC DOCUMENT DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: General purpose record selector via a 'filtered' browse. * ..............: The filter is applied via a SKIPBLOCK on matching key. * ..............: The current file and record position is saved and the * ..............: 'pick' file is opened and set to the proper index order. * ..............: Passed code blocks set the range limits for the tBrowse. * ..............: The RECNO() of the selected record is returned or set to * ..............: zero if no record is selected. When completed, the * ..............: original file settings are restored. * Copyright.....: 1994 Mark J. Wallin, SEMCOR, Inc. * Version.......: 1.1 * Language......: Clipper 5.2c * Parameters....: File name, index order, display title string, code block of * ..............: display fields, code block of match values for top/bottom * ..............: range of records, code block of criteria for skip block to * ..............: act as 'filter' for tBrowse, browse display colors. * Returns.......: NIL * Last Rev. Date: 01/04/94 * Last Rev. Time: 10:03 ****************************************************************************** LOCAL column, browse, key, n, saveOrder, cCurColor, objBrowse, cBorder,; saveWindow, retVal, cColors, nReturnRec, cCurFile, saveCursor,; nSaveOrder, nOrigRec LOCAL f_blk, l_blk, while_blk LOCAL nDispWidth, nBoxLeftCol, nBoxRightCol, tRow := 9, bRow := 23 * Size the display window: nDispWidth := LEN(EVAL(bDispString)) nDispWidth := IIF( nDispWidth > 76, 76, nDispWidth ) && Maximum width nBoxLeftCol := (80 - INT(nDispWidth))/2 - 1 nBoxRightCol:= nBoxLeftCol + nDispWidth + 1 cBorder = "┌─┐│┘─└│" && Default border * Save the required screen area and current colors: cCurScrn := scrnSave( 9, nBoxLeftCol, 24,nBoxRightCol + 1 ) cCurColor := SETCOLOR( cColorString ) * Make a shadowed box for the tBrowse display: @ 9, nBoxLeftCol,23,nBoxRightCol BOX cBorder COLOR "W+/RB" sha_shadow( 9, nBoxLeftCol,23,nBoxRightCol ) * Create & initialize TBrowse object at row & column coordinates: objBrowse = TBROWSEDB( tRow+1,nBoxLeftCol+1,bRow-1,nBoxRightCol-1 ) objBrowse:addColumn(TBColumnNew( cTitleString, bDispString )) cColors := objBrowse:colorSpec && Save the current colors objBrowse:colorSpec := cColorString && Set colors for browse window * Select the file (assume that it is open): saveCursor:= SETCURSOR(0) && Save cursor and turn it off cCurFile := ALIAS() && Save current file name nOrigRec := RECNO() && Save the oritinal record position SELECT (cFileName) && Select the 'pick' file nSaveOrder := INDEXORD() && Save current order SET ORDER TO nIndexOrd nReturnRec := RECNO() && Initialize the RETURN record value * Code blocks for going to top & bottom of selected data within the range * of selected data in the browse window: f_blk := {|| gototop( EVAL(bMatchVal), EXACT )} && First matching record l_blk := {|| gotobott(EVAL(bMatchVal))} && Last matching record * The while_blk is effectively a filter for the data and is much faster * than using an actual filter in a large dataset. It is used in the * SKIPBLOCK method which controls the movement of the record pointer while_blk := bMatchBlk && {|| cKeyExp == cMatchVal } * Assign the code blocks to the browse object methods. If the bMatchVal * code block evaluates to "", the top and bottom of the file is 'unfiltered' * and we use the default methods. Otherwise, substitute f_blk & l_blk IF EVAL(bMatchVal) <> NIL objBrowse:gotopblock := f_blk && SEEK to 1st matching record objBrowse:gobottomblock := l_blk && SEEK to last record ENDIF objBrowse:skipblock := {|n| movepointer(n, while_blk)} * Setup an arrow indicator in the upper righthand corner of the tBrowse * which tells the user when he is at the top or bottom of the data on display: DO CASE CASE objBrowse:rowPos == 1 @tRow,nBoxRightCol SAY "" && Show a down arrow to the right CASE objBrowse:rowPos == objBrowse:rowCount @tRow,nBoxRightCol SAY "" && Show an up arrow to the right OTHERWISE @tRow,nBoxRightCol SAY "" ENDCASE objBrowse:gotop() DO WHILE .t. objBrowse:forceStable() && New way of stabilizing display * DO WHILE .NOT. objBrowse:forceStable() // Allow user to interrupt by pressing a key. * IF nextkey() <> 0 * EXIT * ENDIF * ENDDO DO CASE CASE objBrowse:rowPos == 1 @tRow,nBoxRightCol SAY "" && Show a down arrow to the right CASE objBrowse:rowPos == objBrowse:rowCount @tRow,nBoxRightCol SAY "" && Show an up arrow to the right OTHERWISE @tRow,nBoxRightCol SAY "" ENDCASE // Wait for a keystroke. key := INKEY(0) // Move the pointer based on user's keystroke. DO CASE CASE key = K_ENTER // Select the highlighted record & return nReturnRec := RECNO() EXIT CASE key == K_F1 // Pop up a help message even from INKEY() help( PROCNAME(), NIL,NIL,NIL) CASE key = K_UP // Up one row objBrowse:up() CASE key = K_DOWN // Down one row objBrowse:down() CASE key = K_PGUP objBrowse:pageup() CASE key = K_PGDN objBrowse:pagedown() CASE key = K_CTRL_PGUP objBrowse:gotop() CASE key = K_CTRL_PGDN objBrowse:gobottom() *CASE key = K_LEFT // Left one column * objBrowse:left() *CASE key = K_RIGHT // Right one column * objBrowse:right() CASE key = K_HOME objBrowse:home() CASE key = K_END objBrowse:end() CASE key = K_CTRL_LEFT objBrowse:panleft() CASE key = K_CTRL_RIGHT objBrowse:panright() CASE key = K_CTRL_HOME objBrowse:panhome() CASE key = K_CTRL_END objBrowse:panend() CASE key = K_ESC // Aborted browse without moving record pointer nReturnRec := 0 && Indicate that user escaped without selection EXIT ENDCASE ENDDO // While browsing SET ORDER TO nSaveOrder && Restore original index order SELECT (cCurFile) && Switch to original file GOTO nOrigRec && Go back to original record SETCURSOR( saveCursor ) && Reset cursor SETCOLOR( cCurColor ) && Reset colors scrnRest( cCurScrn ) && Restore screen RETURN nReturnRec && Return value of selected recno FUNCTION goToTop(searcher, lExact) ****************************************************************************** * Function......: GOTOTOP() * System........: HM/ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Copyright.....: 1993 Mark J. Wallin, Ph.D., SEMCOR, Inc. * Description...: SEEKS to user selected 'top' of a file using SOFTSEEK for * ..............: a TBROWSE function. This code was adapted from the * ..............: Clipper's developer seminar by guru RICK SPENCE. * Version.......: 1.1 * Language......: Clipper 5.2c * Parameters....: searcher = String key to SEEK on * Returns.......: NIL * Last Rev. Date: 04/27/93 * Last Rev. Time: 17:50 ****************************************************************************** LOCAL save_soft := SET(_SET_SOFTSEEK) IF .NOT. lExact && If we don't want an exact match... SET(_SET_SOFTSEEK, .t.) ELSE && Otherwise, set for exact match. SET(_SET_SOFTSEEK, .f.) ENDIF SEEK searcher SET(_SET_SOFTSEEK, save_soft) RETURN NIL FUNCTION goToBott(searcher) ****************************************************************************** * Function......: GOTOBOTT() * System........: HM/ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Copyright.....: 1993 Mark J. Wallin, Ph.D., SEMCOR, Inc. * Description...: SEEKS to user selected 'bottom' of a file using SOFTSEEK * ..............: for a TBROWSE function. This code was adapted from the * ..............: Clipper's developer seminar by guru RICK SPENCE. * * ..............: It works by incrementing the last character of the search * * ..............: key and soft SEEKing past the 'end' record, then skipping * * ..............: back. There may be a problem if the last character in the * * ..............: search string is CHR(255) * Version.......: 1.1 * Language......: Clipper 5.2c * Parameters....: aInputArray = array of strings * Returns.......: Numeric width of longest string * Last Rev. Date: 04/27/93 * Last Rev. Time: 13:55 ****************************************************************************** LOCAL save_soft := set(_SET_SOFTSEEK, .T.) SEEK substr(searcher,1,len(searcher)-1) + chr(asc(substr(searcher,len(searcher)))+1) SKIP-1 SET(_SET_SOFTSEEK, save_soft) && Reset the SOFT SEEK setting RETURN NIL FUNCTION movePointer(num_to_skip, while_blk) ****************************************************************************** * Function......: TBROWSEGET() * System........: HM/ODC DATABASE SYSTEM * Version.......: 1.1 * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Copyright.....: 1993 Mark J. Wallin, Ph.D., SEMCOR, Inc. * Description...: Code block function controlling the SKIPBLOCK variable in * ..............: the TBROWSE routine. The function receives the NUM_TO_SKIP * ..............: value from TBROWSE methods and the WHILE_BLK parameter is * ..............: a code block which defines the limits of the pointer * ..............: movement between index key values. The operation of the * ..............: function assumes that the record pointer is at the first * ..............: matching key in the allowed SKIP range. This function * ..............: effectively provide a FILTER without using a filter, which * ..............: speeds up operation with large data files. * Language......: Clipper 5.2c * Parameters....: top row, left column, bottom row, right column, file name, * ..............: display fields, color string. * Returns.......: Selected GET value. * Last Rev. Date: 12/22/93 * Last Rev. Time: 17:00 ****************************************************************************** LOCAL num_skipped := 0, curColor, oldCursor && Counter IF LASTREC() == 0 .OR. EOF() && No records -- EXIT RETURN num_skipped ENDIF IF ( num_to_skip > 0 .AND. RECNO() <> LASTREC() + 1 ) * Loop as many times as there were SKIPs requested. DO WHILE (num_skipped < num_to_skip ) SKIP 1 * If SKIP goes out of range, back up and terminate. IF EOF() .OR. .NOT. EVAL( while_blk ) SKIP -1 EXIT ENDIF num_skipped++ && Increment number skipped counter ENDDO * If a backward SKIP is called for... ELSEIF ( num_to_skip < 0 ) DO WHILE ( num_skipped > num_to_skip ) SKIP -1 IF BOF() EXIT ENDIF IF .NOT. EVAL( while_blk ) SKIP 1 EXIT ENDIF num_skipped-- && Decrement number skipped counter ENDDO ENDIF SETCOLOR(curColor) RETURN num_skipped FUNCTION toggleFile( a1, aKeyVals, nFile, aF ) ****************************************************************************** * Function......: TOGGLEFILE() * System........: HM/ODC DOCUMENT DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: Toggles the file displayed between 3 files: DOCUM, DOCVER, * ..............: and ODCHITS. Also stores fields of current record in * ..............: memvars, stores keys in aKeyVals array, and displays the * ..............: record. * Copyright.....: 1993-94, Mark J. Wallin, SEMCOR, Inc. * Version.......: 1.1 * Language......: Developed to be run under CLIPPER 5.2c * Parameters....: a1 - field memvar array, aKeyVals, nFile * Returns.......: NIL * Last Rev. Date: 12/10/93 * Last Rev. Time: 16:00 ****************************************************************************** LOCAL cCurColor, aColors := getColors() cCurColor := SETCOLOR(aColors[COLSTD]) && Make sure we are in Std. color nFile++ && Increment the file number nFile := IIF( nFile > 3, 1, nFile) && Wrap around to 1st file if req. SELECT ( aF[ nFile ] ) && Select the proper data file curFile := aF[ nFile ] && Set current file scrDisp( nFile ) && Display screen for file setFile( @a1, @aKeyVals, nFile ) SETCOLOR( cCurColor ) && Restore the last color RETURN NIL //============================================================= //====================[ SYSTEM : Automem ]===================== //============================================================= /* AUTHOR: Kim Taulbee [CS: 71021,3340] Copyright (c) 1992, Intelligent Software Solutions, All Rights Reserved. AutoClear( <Array> ) Populate array with empty variables identical to field list of currently selected work area. AutoStore( <Array> ) Populate array with contents of current record in current work area. AutoReplace( <Array> ) Replace fields in current record with contents of Array. AutoAppend( <Array> ) Append new record and populate with contents of Array. AutoAppend will try to find a blank record to use before appending a blank. AutoBlank() Clear the contents of current record. AutoPack() Clear the contents of each record marked for deletion in SELECTed database. Cleared records are then RECALLed. This provides an easy way to avoid using PACK. You can clear and re-use deleted records instead of PACKing the database. */ //------------------------------------- FUNCTION AutoClear( aM ) // Create blank aMemvars from open dbf LOCAL i LOCAL nSaveRec := RECNO() DBGOTO(0) ASIZE( aM, FCOUNT() ) FOR i := 1 TO LEN( aM ) aM[i] := FIELDGET(i) NEXT DBGOTO( nSaveRec ) RETURN( NIL ) //------------------------------------- FUNCTION AutoStore( aM ) // Store field data to amemvars LOCAL i ASIZE( aM, FCOUNT() ) FOR i := 1 TO LEN( aM ) aM[i] := FIELDGET(i) NEXT RETURN( NIL ) //------------------------------------- FUNCTION AutoReplace( aM ) // Replace fields in current record with automemvars. LOCAL i := 0 ASIZE( aM, FCOUNT() ) FOR i := 1 TO LEN( aM ) FIELDPUT(i, aM[i] ) NEXT RETURN( NIL ) //------------------------------------- FUNCTION AutoAppend( aM ) // Append blank and Replace fields with automemvars // Use empty records if they exist LOCAL i LOCAL lAppend := .F. DBGOTOP() FOR i := 1 TO FCOUNT() IF ! EMPTY( FIELDGET(i) ) lAppend := .T. EXIT ENDIF NEXT IF lAppend .OR. EOF() .OR. BOF() DBAPPEND() ENDIF AutoReplace( aM ) RETURN( NIL ) //------------------------------------- FUNCTION AutoBlank() LOCAL aTemp := {} AutoClear( @aTemp ) AutoReplace( aTemp ) RETURN( NIL ) //------------------------------------- FUNCTION AutoPack() /* Pseudo-pack function. Finds records marked for deletion, clears all fields, then recalls record. This makes records available for reuse by AutoAppend() and avoids using PACK. It tends to be a little slow, I'm open to suggestions. */ LOCAL aTemp := {} AutoClear( @aTemp ) DBGOTOP() WHILE !EOF() IF DELETED() AutoReplace( aTemp ) RECALL ENDIF DBSKIP(1) ENDDO RETURN( NIL ) * Miscellaneous files: FUNCTION maxArray(mArray) ****************************************************************************** * Function......: MAXARRAY() * System........: ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Copyright.....: 1991 * Description...: Returns length of longest string in an array of strings * Last Rev. Date: 12/05/91 * Last Rev. Time: 16:58 ****************************************************************************** LOCAL n, maxLen := 0, lenString FOR n := 1 TO LEN(mArray) lenString = LEN(mArray[n]) IF lenString > maxLen maxLen = lenString ENDIF NEXT RETURN maxLen FUNCTION prtOk() ****************************************************************************** * Function......: PRTOK() * System........: ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D., SEMCOR, Inc. * Description...: Checks status of printer - Stays in loop until printer is * * ..............: ready or escape is pressed. If printer is on, a prompt is * * ..............: displayed to "Press any key to Print or <Esc> to abort". * * Last Rev. Date: 01/06/94 * Last Rev. Time: 15:41 ****************************************************************************** LOCAL notDone := .t., nChoice, retVal := .t. DO WHILE notDone IF .NOT. ISPRINTER() && Printer NOT ready! nChoice=ALERT("Printer not ready! Press OK to print, ;"+; "<Esc> or Abort to terminate. ",{"OK","Abort"}) IF nChoice <> 1 notDone := .f. retVal := .f. ENDIf ELSE && Printer is ready nChoice=ALERT("Prepare paper and press any key to ;"+; "print or <Esc> to abort. ",{"OK","Abort"}) notDone := .f. IF nChoice <> 1 retVal := .f. ENDIF ENDIF ENDDO RETURN retVal FUNCTION printCodes( cCtrlCode ) ****************************************************************************** * Function......: PRINTCODES() * System........: ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D., SEMCOR, Inc. * Description...: Sends a print code without affecting PROW() and PCOL() * Copyright.....: 1993, Mark J. Wallin, SEMCOR, Inc. * Version.......: 1.00 * Language......: Clipper 5.2c * Parameters....: cCtrlCode = control code strings * Returns.......: NIL string * Last Rev. Date: 12/16/93 * Last Rev. Time: 18:06 ****************************************************************************** LOCAL nRow, nCol, lPrinter lPrinter := SET(_SET_PRINTER, .t.) SET CONSOLE OFF nRow := PROW() nCol := PCOL() ?? cCtrlCode SETPRC(_SET_PRINTER, lPrinter) SET CONSOLE ON RETURN "" FUNCTION msg(msgText, nTimeDelay) ****************************************************************************** * Function......: MSG() (LIBRARY FUNCTION) * System........: ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: Prints a message is a self-sizing box and passes back the * ..............: screen area saved in the routine. The message will locate * ..............: itself in a (shadow) box at the bottom of the screen. * ..............: The message box display will persist for nTimeDelay * ..............: or if the value is 0, there will be no delay. The message * ..............: area is cleared manually by retoring the passed screen area * Last Rev. Date: 12/21/93 * Last Rev. Time: 12:37 ****************************************************************************** LOCAL nMsgLen:=LEN(msgText), tTextRow, lTextCol := 4, bTextRow := 22, ; rTextCol:=76, aColors := getColors() LOCAL tBoxRow, lBoxCol, bBoxRow, rBoxCol, nLineCount := 1, cCurColor, ; cCurScrn cCursor := SETCURSOR(0) && Turn cursor off cCurColor := SETCOLOR( aColors[COLMSG] ) IF nMsgLen > 70 nMsgLen := 70 nLineCount := MLCOUNT( msgText, 70,,.t.) && Count # of lines, width = 70 ENDIF tTextRow := bTextRow - nLineCount + 1 IF nLineCount == 1 lTextCol := INT((80 - nMsgLen)/2) rTextCol := lTextCol + nMsgLen - 1 ENDIF lBoxCol := lTextCol - 2 rBoxCol := rTextCol + 2 tBoxRow := tTextRow - 1 bBoxRow := bTextRow + 1 cCurScrn := scrnsave( tBoxRow, lBoxCol, bBoxRow + 1, rBoxCol + 1) @ tBoxRow, lBoxCol, bBoxRow, rBoxCol BOX B_SINGLE+" " sha_shadow( tBoxRow, lBoxCol, bBoxRow, rBoxCol) FOR i = 1 TO nLineCount @tTextRow + (i-1), lTextCol SAY MEMOLINE( msgText, nMsgLen, i, .t.) NEXT SETCOLOR(cCurColor) && Restore the colors IF nTimeDelay > 0 && If displaying for a specified period, clear the INKEY( nTimeDelay ) && screen when finished, otherwise, the screen must scrnRest( cCurScrn ) && be restored by program action. ENDIF SETCURSOR( cCursor ) RETURN (cCurScrn) && Return underlying screen area FUNCTION scrnRest(scrname) ****************************************************************************** * Function......: SCRNREST() (LIBRARY FUNCTION) * System........: ODC DATABASE SYSTEM * Author........: James Occhigrosso - Copyright(c) 1991 * Description...: Loads screen from character variable created by SCRNSAVE * Last Rev. Date: 11/29/93 * Last Rev. Time: 11:09 ****************************************************************************** * Restore screen to original coordinates RESTSCREEN(ASC(SUBSTR(scrname,1,1)), ASC(SUBSTR(scrname,2,1)), ; ASC(SUBSTR(scrname,3,1)), ASC(SUBSTR(scrname,4,1)), ; SUBSTR(scrname,5) ) RETURN NIL FUNCTION scrnSave(top, left, bottom, right) ****************************************************************************** * Function......: SCRNSAVE() (LIBRARY FUNCTION) * System........: ODC DATABASE SYSTEM * Author........: James Occhigrosso - Copyright(c) 1991 * Description...: Save partial screen and its coordinates in char. variable * Last Rev. Date: 11/29/93 * Last Rev. Time: 11:09 ****************************************************************************** * Convert coordinates to a 4 character string and place it * at the beginning of the screen variable RETURN(CHR(top) + CHR(left) + CHR(bottom) + CHR(right) + ; SAVESCREEN(top, left, bottom, right) ) FUNCTION getColors() ****************************************************************************** * Function......: GETCOLORS() (LIBRARY FUNCTION) * System........: HM DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: Assigns a colors strings to global memvars. The program * ..............: checks for the presence of a color or monochrome monitor * ..............: and sets the colors accordingly. * Last Rev. Date: 01/11/94 * Last Rev. Time: 10:40 ****************************************************************************** LOCAL aColors[13] IF ISCOLOR() aColors[1] := "B/BG,R/W" && Standard colors aColors[2] := "W/B, W+/R" && 'GET' colors aColors[3] := "B/W" && Title line colors aColors[4] := "W+/B" && Menu colors aColors[5] := "N/N" && Shadow colors aColors[6] := "GR+/B" && Status line colors aColors[7] := "W/N" && Background screen colors aColors[8] := "W+/BG" && Box colors aColors[9] := "W+/RB" && Message colors aColors[10]:= "W+*/B" && Flashing letters aColors[11]:= "R/BG" && Logo colors aColors[12]:= "W+/R" && Help screen colors * Set new palette colors: *palette(1,24) && Set BLUE to GRAYISH-BLUE *palette(4,12) && Set RED to DEEP ROSE palette(5,28) && Set MAGENTA to PALE WINE palette(2,48) && Set GREEN to OLIVE GREEN *palette(3,49) && Set CYAN to PALE CYAN ELSE aColors[1] := "W/N,N/W" && Standard colors aColors[2] := "W/N,W+/W" && 'GET' colors aColors[3] := "N/W" && Title line colors aColors[4] := "N/W" && Menu colors aColors[5] := "W/N" && Shadow colors aColors[6] := "N/W" && Status line colors aColors[8] := "W/N" && Background screen colors aColors[9] := "W+/N" && Box colors aColors[10]:= "N/W" && Message colors aColors[11]:= "W+*/N" && Flashing letters aColors[12]:= "W+/N" && Logo colors aColors[13]:= "N/W" && Help screen colors ENDIF RETURN aColors FUNCTION dispTitle( titleStr ) ****************************************************************************** * Function......: DISPTITLE() * System........: HM DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: Function to display a title line * Copyright.....: 1993, Mark J. Wallin, SEMCOR, Inc. * Version.......: 1.1 * Language......: Developed to be run under CLIPPER 5.2c * Last Rev. Date: 11/24/93 * Last Rev. Time: 11:46 ****************************************************************************** LOCAL curColor, aColors := getColors() curColor := SETCOLOR( aColors[COLTITL] ) && Save cur. color, set title color @ 0, 8 CLEAR TO 0,79 && Clear top line, start at col. 8 in order center( titleStr, 80, 0) && to avoid affecting the CLOCK display RETURN NIL FUNCTION center(text,width,row) ****************************************************************************** * Function......: CENTER * System........: HM DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: This routine centers text on a ROW that is WIDTH wide * Last Rev. Date: 03/18/92 * Last Rev. Time: 12:46 ****************************************************************************** LOCAL strLen, startCol IF width == NIL width := 80 ENDIF IF row == NIL row := 0 ENDIF text := ALLTRIM(text) strLen := LEN(text) IF width < strlen RETURN .f. ENDIF startCol := INT((width - strLen)/2) @ row, startCol SAY text RETURN .t. FUNCTION genKey(last_Key, numDigit) ****************************************************************************** * Function......: GENKEY.PRG (LIBRARY FUNCTION) * System........: ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: Assigns a unique id key (base 36) from for an N character * ..............: string (e.g. '000000' to 'ZZZZZZ' for a 6 digit string). * ..............: The last key is stored as an integer number in a control * ..............: file. If the last key used was 36^N (maximum key), the * ..............: the routine looks for the first open id in the file. * Parameters....: Last key used (obtain from control file), number of digits * ..............: in id key. * Returns.......: New base 36 key. * Last Rev. Date: 12/06/93 * Last Rev. Time: 17:46 ****************************************************************************** LOCAL intKey, newKey := REPLICATE("0",numDigit), maxKey := 36^numDigit LOCAL saveRec * Maximum number of keys for 6 digit base 36 is 2,176,782,336 - more than * the maximum number of records that Clipper or .DBF files can hold. * If the file has no records, the value of NEWKEY returned will be a string * of zeroes of length numDigit. saveRec := RECNO() GO TOP intKey = last_Key + 1 && Integer val. of last case key + 1 DO WHILE .NOT. EOF() IF intKey > maxKey && If key is greater than maximum, intKey := 0 && start over from 0 ENDIF newKey := numTo36(intKey, numDigit) && Convert to base36 key SEEK newKey && See if key not already used intKey++ && Increment the integer value ENDDO && If not previously used, EXIT LOOP IF saveRec > 0 GOTO saveRec ENDIF RETURN newKey FUNCTION numTo36( num, numDigit ) ****************************************************************************** * Function......: NUMTO36 * System........: ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: This routine converts any (base 10) integer to a base 36 * ..............: number (numbers using the digits 0-9 and A-Z). This * ..............: function was developed to be used in with the GENKEY() * ..............: function which generates unique keys. * Last Rev. Date: 11/27/93 * Last Rev. Time: 17:37 ****************************************************************************** LOCAL num36 := "", div := 36^(numDigit - 1), n := 1, rem FOR n := 1 TO numDigit rem := INT(num/div) && Divide by decreasing powers num := MOD(num,div) && of 36. The remainder becomes div := div/36 && the new dividend. IF rem <= 9 && If the remainder is 9 or less num36 := num36 + CHR(48 + rem) && use numeric characters. ELSE num36 := num36 + CHR(55 + rem) && If the remainder is > 9, use ENDIF && alphabetical characters A-Z. NEXT n && Concatenate digits along the way RETURN num36 FUNCTION b36ToNum( sNum36, numDigit ) ****************************************************************************** * Function......: B36TONUM * System........: ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D. * Description...: This routine converts an N digit base 36 number to an * ..............: integer. This function is the reverse to numTo36() and * ..............: was developed to be used in the function which generates * ..............: unique keys. The function accepts an N character string * ..............: and returns the equivalent integer. * Last Rev. Date: 11/27/93 * Last Rev. Time: 17:35 ****************************************************************************** LOCAL num10 := 0, digit FOR n := 1 TO numDigit digit := SUBSTR(sNum36,n,1) IF .NOT. ISALPHA(digit) num10 := num10 + VAL(digit) * 36^(numDigit - n) ELSE num10 := num10 + (ASC(digit) - 55) * 36^(numDigit - n) ENDIF NEXT RETURN num10 FUNCTION pickList( oObj, cDispField, cStuffField, nTop, nLeft, cClr, cBorder,; lShadow) ****************************************************************************** * Function......: PICKLIST() * System........: * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Description...: PICK LIST with GET - Pops up a pick list of choices from * ..............: a specified file. Upon selection, a code is stuffed into * ..............: the GET object, rather than the actual item displayed. * ..............: The pickbox is self-sizing, based on the width of the * ..............: displayed field and the number of records in the lookup * ..............: file. If there are more records in the file than can be * ..............: displayed, the box is sized to go to the bottom of the * ..............: screen. * Version.......: 1.00 * Language......: Clipper 5.2c * Parameters....: oGet - GET object: aFile = array with name of file, index, * ..............: field containing lookup data, and field containing the * ..............: code to stuff into the GET: nTop/nLeft - starting left * ..............: and top pick box coordinates: cClr - color string: * ..............: cBorder - border string. * Returns.......: NIL * Last Rev. Date: 12/02/93 * Last Rev. Time: 11:00 ****************************************************************************** LOCAL cColor, cScr, cTemp, stdColor, enhColor, curColor LOCAL nKey, nRet := GE_NOEXIT *LOCAL cName, cIndex, cDispField, lShadow LOCAL nShadowRows, nTotRowsAvail, nMaxHt, nMaxBoxHt, nMaxDispHt, nBoxBottom,; nShdBottom, nMaxDispWidth, nMaxBoxWidth, nMaxWidth, nBoxRight, nShdRight LOCAL cScreen curColor := SETCOLOR() && Get current color string *nTop := TOP *nLeft := LEFT *nBottom := BOTTOM *nRight := RIGHT IF VALTYPE(cBorder) <> "C" && If cBorder is NIL cBorder = "┌─┐│┘─└│" && Default border ENDIF IF cClr <> NIL && If COLOR option was specified, use it * Parse the color string for the Standard and Enhanced colors * stdColor := SUBSTR( cClr, 1, AT(",", cClr) - 1 ) && Standard color enhColor := SUBSTR( cClr, AT(",", cClr) + 1 ) && Enhanced color for GET ELSE && Otherwise, use current colors: * stdColor := SUBSTR( curColor, RAT(",", curColor) + 1 ) && Unsel enhColor := SUBSTR( curColor, AT(",", curColor) + 1 ) && Enhanced ENDIF lShadow := IIF( VALTYPE(lShadow) == "U", .f., lShadow ) && Default SHADOW off cFileName := SUBSTR( cDispField, 1, AT(">",cDispField) - 2 ) numPickRecs := &(cFileName+"->(RECCOUNT())") SEEK odcHits->decision lookupOrder( ALPHAORDER ) * Size the pick box based on the width of the displayed field and the starting * location of the box. The number of records displayed should be the number * of records in the lookup file or the maximum number that could be displayed * in the screen rows available. Likewise, the leftmost column should be * set to be equal to the column for the GET field or spaced to allow the * full width to be accomodated from the rightmost column. nShadowRows := IIF( lShadow, 1, 0 ) && Space occupied by shadow row && (same as column) nTotRowsAvail := MAXROW() - nTop + 1 && Total rows avail. for display IF numPickRecs > nTotRowsAvail - nShadowRows-2 && If # of recs. > avail. disp. nMaxHt := nTotRowsAvail && Max. Ht. Box + Shadow (if any) nMaxBoxHt := nTotRowsAvail - nShadowRows && Max. Ht. Box only nMaxDispHt := nMaxBoxHt - 2 && Max rows of display area ELSE && If # of recs <= avail. disp. nMaxBoxHt := numPickRecs + 2 nMaxHt := nMaxBoxHt + nShadowRows nMaxDispHt := numPickRecs ENDIF nBoxBottom := nTop + nMaxBoxHt - 1 nShdBottom := nTop + nMaxHt - 1 nMaxDispWidth := LEN( &cDispField ) && Width of display area nMaxBoxWidth := nMaxDispWidth + 2 && Width of pickbox nMaxWidth := nMaxBoxWidth + nShadowRows && Width of pickbox w/shadow nRight := nLeft + nMaxWidth - 1 * Calculate right column and adjust left column if necessary: IF nRight > MAXCOL() && If right column is too far nRight := MAXCOL() && over, anchor right column at nLeft := nRight - nMaxWidth + 1 && MAXCOL(), adjust left column ENDIF nBoxRight := nLeft + nMaxBoxWidth - 1 nShdRight := nLeft + nMaxWidth - 1 * Save the underlying screen: cScreen := SAVESCREEN( nTop, nLeft, nShdBottom, nShdRight ) IF EMPTY(oObj:varGet()) nKey = K_ENTER ELSE nkey := INKEY(0) ENDIF DO CASE CASE nkey = K_ENTER // Pop up the picklist TBrowse @ nTop, nLeft, nBoxBottom, nBoxRight BOX cBorder COLOR cClr IF lShadow sha_shadow( nTop, nLeft, nBoxBottom, nBoxRight ) ENDIF oObj:varPut( tBrowseData( nTop+1, nLeft+1, nBoxBottom - 1, ; nBoxRight-1, cFileName, cDispField, ; cStuffField, cClr ) ) oObj:exitState := GE_ENTER CASE key == K_F1 // Pop up a help message help( PROCNAME(), NIL,NIL,NIL) CASE nKey == K_UP oObj:exitState := GE_UP CASE nKey == K_SH_TAB oObj:exitState := GE_UP CASE nKey == K_DOWN oObj:exitState := GE_DOWN CASE nKey == K_TAB oObj:exitState := GE_DOWN CASE nKey == K_ESC IF ( SET( _SET_ESCAPE ) ) oObj:exitState := GE_ESCAPE ENDIF CASE nKey == K_PGUP oObj:exitState := GE_WRITE CASE nKey == K_PGDN oObj:exitState := GE_WRITE CASE nKey == K_CTRL_HOME oObj:exitState := GE_TOP ENDCASE lookupOrder( KEYORDER ) && Put back in key order *setLookup() && Reset relations RESTSCREEN( nTop, nLeft, nShdBottom, nShdRight, cScreen ) SETPOS(nTop, nLeft) *DEVOUT( oObj:varGet(), cClr ) DEVOUT( &cDispField, cClr ) && Display the related field RETURN oObj FUNCTION tBrowseData( tRow,lCol,bRow,rCol,cFileName,cDispField,cStuffField,; cColorString ) ****************************************************************************** * Function......: TBROWSEDATA() * System........: ODC DATABASE SYSTEM * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Description...: TBROWSE for picking the actual data item. * Version.......: 1.00 * Language......: Clipper 5.2c * Parameters....: oGet - GET object: aFile = array with name of file, index, * ..............: field containing lookup data, and field containing the * ..............: code to stuff into the GET: nTop/nLeft - starting left * ..............: and top pick box coordinates: cClr - color string: * ..............: cBorder - border string. * Returns.......: NIL * Last Rev. Date: 12/02/93 * Last Rev. Time: 11:00 ****************************************************************************** MEMVAR getlist LOCAL column, browse, key, n, saveOrder, saveColor, objBrowse,; saveWindow, retVal, cColors, saveRecPos, saveCurFile, saveCursor * Create & initialize TBrowse object at row & column coordinates: titleString = "" objBrowse = TBROWSEDB( tRow,lCol,bRow,rCol ) objBrowse:addColumn(TBColumnNew( titleString,{ || &cDispField } )) *objBrowse:addColumn(TBColumnNew( titleString,{ || chemical->c_name } )) *objBrowse = newBrow( tRow,lCol,bRow,rCol,cDispField ) cColors := objBrowse:colorSpec && Save the current colors objBrowse:colorSpec = cColorString && Colors for browse window * Select the file (assume that it is open): saveCursor = SETCURSOR(0) && Save cursor and turn it off saveCurFile = ALIAS() && Save current file name SELECT (cFileName) && Select the 'pick' file saveRecPos := RECNO() && Save the current record position GO TOP && Go to the top of the file DO CASE CASE objBrowse:rowPos == 1 @tRow,rCol+1 SAY "" && Show a down arrow to the right CASE objBrowse:rowPos == objBrowse:rowCount @tRow,rCol+1 SAY "" && Show an up arrow to the right OTHERWISE @tRow,rCol+1 SAY "" ENDCASE DO WHILE .t. objBrowse:forceStable() * DO WHILE .NOT. objBrowse:forceStable() // Allow user to interrupt by pressing a key. * IF nextkey() <> 0 * EXIT * ENDIF *ENDDO DO CASE CASE objBrowse:rowPos == 1 @tRow,rCol+1 SAY "" && Show a down arrow to the right CASE objBrowse:rowPos == objBrowse:rowCount @tRow,rCol+1 SAY "" && Show an up arrow to the right OTHERWISE @tRow,rCol+1 SAY "" ENDCASE // Wait for a keystroke. key := INKEY(0) // Move the pointer based on user's keystroke. DO CASE CASE key = K_ENTER // Select the highlighted record retVal = &cStuffField && Return code of selected field * retVal = chemical->c_chemical && Return code of selected field EXIT CASE key == K_F1 // Pop up a help message help( PROCNAME(), NIL,NIL,NIL) CASE key = K_UP // Up one row objBrowse:up() CASE key = K_DOWN // Down one row objBrowse:down() CASE key = K_PGUP objBrowse:pageup() CASE key = K_PGDN objBrowse:pagedown() CASE key = K_CTRL_PGUP objBrowse:gotop() CASE key = K_CTRL_PGDN objBrowse:gobottom() *CASE key = K_LEFT // Left one column * objBrowse:left() *CASE key = K_RIGHT // Right one column * objBrowse:right() CASE key = K_HOME objBrowse:home() CASE key = K_END objBrowse:end() CASE key = K_CTRL_LEFT objBrowse:panleft() CASE key = K_CTRL_RIGHT objBrowse:panright() CASE key = K_CTRL_HOME objBrowse:panhome() CASE key = K_CTRL_END objBrowse:panend() CASE key = K_ESC // Done browsing retVal = NIL && No record selected GOTO saveRecPos EXIT ENDCASE ENDDO // While browsing SELECT (saveCurFile) SETCURSOR( saveCursor ) RETURN retVal FUNCTION editMemo( oObj, cClr, nTop, nLeft, nBottom, nRight ) ****************************************************************************** * Function......: EDITMEMO() * System........: * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Description...: UDC which enables editing of a memo or other large field * ..............: in a box using the MEMOEDIT function within the usual GET * ..............: READ full screen editing mode. The user may jump from * ..............: by modifying the GET object get:reader method. This * ..............: implementation was adapted from code written by Luiz * ..............: Quintela of CA (formerly Nantucket). * Version.......: 1.00 * Language......: Clipper 5.2c * Parameters....: oObj = GET object, cClr = color spec. string * Returns.......: NIL * Last Rev. Date: 11/22/93 * Last Rev. Time: 09:16 ****************************************************************************** *LOCAL nTop, nLeft, nRight, nBottom LOCAL cColor, cScr, cTemp, stdColor, enhColor, curColor LOCAL nKey, nRet := GE_NOEXIT, cCurK2 curColor := SETCOLOR() && Get current color string cCurK2 := SETKEY(K_F2,NIL) && Disable the F2 key cCurK3 := SETKEY(K_F3,NIL) && Disable the F3 key *nTop := TOP *nLeft := LEFT *nBottom := BOTTOM *nRight := RIGHT IF cClr <> NIL && If COLOR option was specified, use it * Parse the color string for the Standard and Enhanced colors * stdColor := SUBSTR( cClr, 1, AT(",", cClr) - 1 ) && Standard color enhColor := SUBSTR( cClr, AT(",", cClr) + 1 ) && Enhanced color for GET ELSE && Otherwise, use current colors: * stdColor := SUBSTR( curColor, RAT(",", curColor) + 1 ) && Unsel enhColor := SUBSTR( curColor, AT(",", curColor) + 1 ) && Enhanced ENDIF * Redisplay the memoBox with the edited string in standard colors: memoBox(nTop,nLeft,nBottom,nRight,oObj:varGet(), cClr, UNENHANCED) nKey := INKEY(0) DO CASE CASE nKey == K_ENTER cScr := SAVESCREEN( nTop, nLeft, nBottom, nRight ) * memoBox(nTop,nLeft,nBottom,nRight,oObj:varGet(), enhColor) memoBox(nTop,nLeft,nBottom,nRight,oObj:varGet(), cClr, ENHANCED) cColor := SETCOLOR( enhColor ) SCROLL( nTop+1, nLeft+1, nBottom-1, nRight-1 ) oObj:varPut( MEMOEDIT( oObj:varGet(), nTop+1, nLeft+2, ; nBottom-1, nRight-2 ) ) RESTSCREEN( nTop, nLeft, nBottom, nRight, cScr ) oObj:exitState := GE_NOEXIT CASE nKey == K_UP oObj:exitState := GE_UP CASE nKey == K_SH_TAB oObj:exitState := GE_UP CASE nKey == K_DOWN oObj:exitState := GE_DOWN CASE nKey == K_TAB oObj:exitState := GE_DOWN CASE nKey == K_ESC IF ( SET( _SET_ESCAPE ) ) oObj:exitState := GE_ESCAPE ENDIF CASE nKey == K_PGUP oObj:exitState := GE_WRITE CASE nKey == K_PGDN oObj:exitState := GE_WRITE CASE nKey == K_CTRL_HOME oObj:exitState := GE_TOP ENDCASE SETCOLOR( curColor ) SETKEY(K_F2, cCurK2) && Restore the function keys SETKEY(K_F3, cCurK3) RETURN (NIL) FUNCTION memoBox( nTop, nLeft, nBottom, nRight, cMemoStr, cColor, colorType) ****************************************************************************** * Function......: MEMOBOX() * System........: * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Description...: Displays a memo box and a string within the confines of * ..............: box using the MEMOLINE and MLCOUNT functions to provide * ..............: line wrapping. * Version.......: 1.00 * Language......: Clipper 5.2c * Parameters....: 4 box coordinates, character string * Returns.......: NIL * Last Rev. Date: 12/06/93 * Last Rev. Time: 10:40 ****************************************************************************** LOCAL nLines := nBottom - nTop - 1, i := 1, nlineLen := nRight - nLeft - 3, ; lWrap := .t., saveColor, curColor, useColor, cRemStr curColor = SETCOLOR() IF cColor <> NIL && If COLOR option was specified, use it * Parse the color string for the Standard and Enhanced colors stdColor := SUBSTR( cColor, 1, AT(",", cColor) - 1 ) && Standard color enhColor := SUBSTR( cColor, AT(",", cColor) + 1 ) && Enh. color for GET ELSE && Otherwise, use current colors: stdColor := SUBSTR( curColor, RAT(",", curColor) + 1 ) && Unsel nFirstCom:= AT(",",curColor) + 1 cRemStr := SUBSTR( curColor, AT(",", curColor) + 1 ) && Enhanced enhColor := SUBSTR( cRemStr, 1, AT(",", cRemStr) - 1 ) ENDIF useColor = IIF( colorType, enhColor, stdColor ) SETCOLOR( useColor ) @ nTop, nLeft CLEAR TO nBottom, nRight @ nTop, nLeft, nBottom, nRight BOX "█▀███▄██" COLOR useColor FOR i := 1 TO nLines @ nTop + i, nLeft + 2 SAY MEMOLINE( cMemoStr, nlineLen, i,, lWrap ) NEXT SETCOLOR( curColor ) RETURN NIL FUNCTION indexBar( aColors ) ****************************************************************************** * Function......: INDEXBAR() * * System........: HM/ODC DATABASE MANAGER * * Version.......: 1.1 * * Author........: Mark J. Wallin, Ph.D., SEMCOR, Inc., based on an article * * ..............: by Greg Lief, DBMS Mag. 12/91, p.82. * * Description...: Displays a status bar when indexing, via a command * * ..............: replacement: INDEX ON...TO... GRAPH * * Language......: Clipper 5.2c * * Parameters....: None * * Returns.......: NIL * * Last Rev. Date: 04/23/93 * * Last Rev. Time: 11:23 * ****************************************************************************** STATIC nLastRec STATIC nScreen STATIC nGraphLen STATIC nSpacing LOCAL nCurRec := RECNO() LOCAL ii := 1 *RETURN .t. IF nLastrec == Nil // Establish Nlastrec AND Ngraphlen Variables. nLastRec := LASTREC() nSpacing := nLastrec/60 nGraphlen := 0 //Save screen and draw initial box. nScreen := scrnSave(12, 08, 14, 71) @12,08, 14, 71 BOX B_SINGLE + ' ' COLOR( aColors[COLHELP]) @12,10 SAY "[Indexing " + UPPER(ALIAS()) + "]" COLOR(aColors[COLHELP]) @13,10 SAY REPLICATE(CHR(178),60) COLOR(aColors[COLHELP]) SETPOS(13, 10) //If the data file is empty clear the screen and reset variables IF nLastrec = 0 @ 13, 10 Say REPLICATE(CHR(219),60) COLOR(aColors[COLHELP]) scrnRest( nScreen ) nLastrec := NIL nGraphLen := NIL ENDIF ELSE //Display characters only if necessary IF nGraphLen != INT(nCurRec/nSpacing) nGraphLen++ IF nLastRec < 60 FOR ii := 1 TO INT(1/nSpacing) DISPOUT(CHR(219),'+W/RB') NEXT ii ELSE DISPOUT(CHR(219),'+W/RB') ENDIF ENDIF IF nCurRec == nLastRec //If we are finished, restore screen and reset Nlastrec and Ngraphlen scrnRest( nScreen ) nLastRec := NIL nGraphLen := NIL ENDIF ENDIF RETURN .t. FUNCTION dispSemLogo( aColors ) ****************************************************************************** * Function......: DISPSEMLOGO() * System........: ODC DATABASE SYSTEM * Version.......: 1.1 * Author........: Mark J. Wallin, Ph.D. * Description...: Startup logo. * Copyright.....: 1993, Mark J. Wallin, SEMCOR, Inc. * Language......: Developed to be run under CLIPPER 5.2c * Last Rev. Date: 01/11/94 * Last Rev. Time: 11:39 ****************************************************************************** LOCAL saveCursor, saveColor saveCursor := SETCURSOR( SC_NONE ) saveColor := SETCOLOR( aColors[COLBKGD] ) @ 0, 0, 24, 79 BOX "▒▒▒▒▒▒▒▒▒" *SETCOLOR( saveColor ) SETCOLOR( aColors[COLSTD]) @ 3, 2 SAY " " @ 4, 2 SAY " ▄████▄ ███████ " @ 5, 2 SAY " ██████▄ ██████ " @ 6, 2 SAY " ▀█████▄ █████ " @ 7, 2 SAY " █ ▀█████▄ ████ " @ 8, 2 SAY " ██ ▀█████▄ ███ " @ 9, 2 SAY " ███ ▀█████▄ ██ " @10, 2 SAY " ████ ▀█████▄ █ " @11, 2 SAY " █████ ▀█████▄ " @12, 2 SAY " ██████ ▀██████ " @13, 2 SAY " ███████ ▀████▀ " SETCOLOR( aColors[COLLOGO] ) @14, 2 SAY " ┌─────╖ ┌─────╖ ┌───────╖ ┌─────╖ ┌─────╖ ┌──────╖ " @15, 2 SAY " │ ╔═══╝ │ ╔═══╝ │ ╔╕ ╔╕ ║ │ ╔═╕ ║ │ ╔═╕ ║ │ ╔══╕ ║ " @16, 2 SAY " │ ╙───╖ │ ╙─╖ │ ║│ ║│ ║ │ ║ ╘═╝ │ ║ │ ║ │ ╙──┘ ║ " @17, 2 SAY " ╘═══╕ ║ │ ╔═╝ │ ║╘═╝│ ║ │ ║ ┌─╖ │ ║ │ ║ │ ╔═╕ ╔╝ " @18, 2 SAY " ┌───┘ ║ │ ╙───╖ │ ║ │ ║ │ ╙─┘ ║ │ ╙─┘ ║ │ ║ │ ╙╖ " @19, 2 SAY " ╘═════╝ ╘═════╝ ╘═╝ ╘═╝ ╘═════╝ ╘═════╝ ╘═╝ ╘══╝ " @20, 2 SAY " " sha_shadow( 3, 2,20,75 ) INKEY(3) && Pause 3 seconds CLEAR SCREEN SETCURSOR( saveCursor ) SETCOLOR( saveColor ) RETURN NIL FUNCTION RadioGets(bVar, cVar, aChoices, aGetList, cLocType) ****************************************************************************** * Function......: RADIOGETS() * System........: HM/ODC Database Manager * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Description...: Issue radio button GETS for array of character strings * ..............: contained in aChoices. bVar is a GET/SET block for the * ..............: GET variable, cVar is the variable name. From an article * ..............: by Rick Spence, DBA, Jan. '93, pp 121. * ..............: Modification: added a parameter to enable horizontal or * ..............: vertical stacking of buttons. * Version.......: 1.00 * Language......: Clipper 5.2c * Parameters....: bVar - GET/SET block, cVar - variable name, array of * ..............: choices, Getlist, layout - HORIZ or VERT * Returns.......: NIL * Last Rev. Date: 12/15/93 * Last Rev. Time: 12:27 ****************************************************************************** LOCAL oGet LOCAL nRow := Row(), nCol := Col() LOCAL nGets := Len(aChoices) LOCAL nGet LOCAL nStartGet := Len(aGetList) + 1 LOCAL nSaveRow, nSaveCol // For each element in aChoices FOR nGet := 1 To nGets // Display ( ) before the get DevPos(nRow, nCol) DevOut("( ) ") // Create an empty get object and add it to the list oGet := GetNew() Aadd(aGetList, oGet) // Its position is 4 spaces to the right of the cursor // (just past ( ) ) oGet:col := nCol + 4 // Modification by Mark J. Wallin to allow for both Horizontal and // vertical display of the GET's. IF cLocType == VERTICAL // We increment the row number so the gets are displayed vertically oGet:row := nRow++ ELSE // We add the length of the current choice text to the column so the // GET's are displayed horizontally. // Be careful not to go off the end of the screen! oGet:row := nRow nCol := nCol + LEN(aChoices[nGet]) + 5 ENDIF // Set get:name for hot keys oGet:name := cVar // Here's where it gets a bit tricky. The get object's get/set // block must just return the character string describing the // radio button ("Amex", e.g. ). We cannot, however, set it as: // {|| aChoices[nGet] } // as this code block is reevaluated at READ time when nGet is // invalid. We solve the problem with a detached local. oGet:block := t(aChoices[nGet]) // Cargo is an arry of two elements. The first element contains // the get/set block for the real variable, the second element // is an array of offsets inside getlist of the other gets that // comprise the radio buttons oGet:cargo := {bVar, Array(nGets)} // Fill cargo[2] with element numbers of other gets in radio // button list. nStartGet is the element number of the first one. Aeval(oGet:cargo[2], {|x, n| oGet:cargo[2, n] := nStartGet + n - 1}) // Radio gets have their own reader, of course oGet:reader := {|o| RadioReader(o, aGetList, cLocType) } oGet:display() NEXT RETURN oGet // Just return a code block, which, when evaluated, will return c. // As the returned code block references a local variable that variable // becomes "detached" from the activation stack. FUNCTION t(c) RETURN {|x| c } Proc RadioReader( oGet, aGetList, cLocType ) ****************************************************************************** * Function......: RADIOREADER() * System........: HM/ODC Database Manager * Version.......: 1.1 * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Description...: Reader for radio buttons GET object [from Rick Spence.] * Language......: Clipper 5.2c * Parameters....: oGet - GET object, aGetList - local GET list, cLocType - * ..............: choices, Getlist, layout - HORIZ or VERT * Returns.......: NIL * Last Rev. Date: 12/15/93 * Last Rev. Time: 12:27 ****************************************************************************** LOCAL cSaveKey * Disable our F2 function key during this routine: *cSaveKey := SETKEY(K_F2,NIL) // read the GET if the WHEN condition is satisfied IF ( GetPreValidate(oGet) ) // activate the GET for reading oGet:SetFocus() DO WHILE ( oGet:exitState == GE_NOEXIT ) // check for initial typeout (no editable positions) IF ( oGet:typeOut ) oGet:exitState := GE_ENTER ENDIF // apply keystrokes until exit DO WHILE ( oGet:exitState == GE_NOEXIT ) RadioApplyKey(oGet, InKey(0), aGetList, cLocType) ENDDO // disallow exit if the VALID condition is not satisfied IF ( !GetPostValidate(oGet) ) oGet:exitState := GE_NOEXIT ENDIF ENDDO // de-activate the GET oGet:KillFocus() ENDIF RETURN PROC RadioApplyKey(oGet, nKey, aGetList, cLocType) ****************************************************************************** * Function......: RADIOAPPLYKEY() * System........: HM/ODC Database Manager * Version.......: 1.1 * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Description...: Key function for radio buttons GET object [from Rick Spence]. * Language......: Clipper 5.2c * Parameters....: oGet - GET object, aGetList - local GET list, cLocType - * Returns.......: NIL * Last Rev. Date: 12/15/93 * Last Rev. Time: 12:27 ****************************************************************************** LOCAL cKey LOCAL bKeyBlock LOCAL nSaveRow, nSaveCol LOCAL cSaveKey * Disable our F2 function key during this routine: *cSaveKey := SETKEY(K_F2,NIL) // check for SET KEY first IF ( (bKeyBlock := SetKey(nKey)) <> NIL ) GetDoSetKey(bKeyBlock, oGet) SETKEY(K_F2, cSaveKey) RETURN // NOTE ENDIF DO CASE CASE ( nKey == K_UP ) oGet:exitState := GE_UP CASE ( nKey == K_LEFT ) .AND. cLocType == HORIZONTAL oGet:exitState := GE_UP CASE ( nKey == K_SH_TAB ) oGet:exitState := GE_UP CASE ( nKey == K_DOWN ) oGet:exitState := GE_DOWN CASE (nKey == K_RIGHT ) .AND. cLocType == HORIZONTAL oGet:exitState := GE_DOWN CASE ( nKey == K_TAB ) oGet:exitState := GE_DOWN CASE ( nKey == K_ENTER ) oGet:exitState := GE_ENTER CASE nKey == K_SPACE // Toggle state of this radio button. If the get // currently contains this radio button, clear it. // If it does not, set it to that value IF Eval(oGet:cargo[1]) == Eval(oGet:block) Eval(oGet:cargo[1], "") ELSE Eval(oGet:cargo[1], Eval(oGet:block)) ENDIF // And redraw the getlist DrawRadios(aGetlist, oGet) CASE ( nKey == K_ESC ) IF ( Set(_SET_ESCAPE) ) oGet:undo() oGet:exitState := GE_ESCAPE ENDIF CASE (nKey == K_PGUP ) oGet:exitState := GE_WRITE CASE (nKey == K_PGDN ) oGet:exitState := GE_WRITE CASE ( nKey == K_CTRL_HOME ) oGet:exitState := GE_TOP // both ^W and ^End terminate the READ (the default) CASE (nKey == K_CTRL_W) oGet:exitState := GE_WRITE CASE (nKey == K_INS) Set( _SET_INSERT, !Set(_SET_INSERT) ) ENDCASE *SETKEY(K_F2, cSaveKey ) && Reactivate the F2 key RETURN PROC DrawRadios(aGetList, oGet) ****************************************************************************** * Function......: DRAWRADIOS() * System........: HM/ODC Database Manager * Version.......: 1.1 * Author........: Mark J. Wallin, Ph.D., SEMCOR Inc., Moorestown, NJ * Description...: Draws all radio buttons in aGetList to which the GET object * ..............: oGet is attached [from Rick Spence]. * Language......: Clipper 5.2c * Parameters....: aGetList, oGet - local GET object * Returns.......: NIL * Last Rev. Date: 12/15/93 * Last Rev. Time: 12:27 ****************************************************************************** LOCAL cSelected := Eval(oGet:cargo[1]) LOCAL nRadios := Len(oGet:cargo[2]) LOCAL oGet1, nSaveRow := Row(), nSaveCol := Col(), nGet FOR nGet := 1 TO nRadios oGet1 := aGetList[oGet:cargo[2, nGet]] DevPos(oGet1:row, oGet1:col - 3) IF Eval(oGet1:cargo[1]) == Eval(oGet1:block) DevOut(RADIO_BUTTON) ELSE DevOut(" ") ENDIF NEXT DevPos(nSaveRow, nSaveCol) RETURN * MULTIUSER FUNCTIONS FOR NETWORKING: FUNCTION netUse( cFileName, cFileAlias, lExclUse, nWaitTime ) ****************************************************************************** * Function......: NETUSE() * * System........: CREDIT COLLECTIONS DATABASE MANAGER * * Version.......: 2.0 * * Author........: Mark J. Wallin, Ph.D. * * Description...: Trys to open a file for exclusive or shared use. * * ..............: SET INDEXes in calling procedure if successful. * * ..............: Pass the following parameters * * ..............: 1. Character - name of the .DBF file to open * * ..............: 2. Logical - mode of open (exclusive/.NOT. exclusive) * * ..............: 3. Numeric - seconds to wait (0 = wait forever) * * Copyright.....: 1990-1994, Mark J. Wallin, 21st Century Computing * * Language......: CLIPPER 5.2c * * Parameters....: Name of File to be opened, Alias of File, Exclusive .t./.f.* * ..............: retry time in seconds * * Returns.......: .t./.f. * * Last Rev. Date: 01/20/94 * * Last Rev. Time: 00:51 * ****************************************************************************** LOCAL lWait, lRetVal := .t., nTime, cCurFile, cMsgScrn, cCurCursor, ; cCurColor, cCurScrn, lOutLoop := .t. * Example: * IF netUse("file","file", .t., 5) * SET INDEX TO indexFile * ELSE * msg( "File not available" ) * ENDIF cCurScrn := scrnSave(0, 0,24,79) && Save current screen, colors cCurColor := SETCOLOR( aColors[COLMSG] ) && and set cursor off cCurCursor:= SETCURSOR( SC_NONE ) nTime := nWaitTime lWait := (nWaitTime == 0) DO WHILE (forever .OR. wait_time > 0) * Check to see if the file is already opened in some user area under its' * name or its' alias. If already open, close it. Then try to re-open it * in the specified shared or exclusive mode. IF SELECT( cFileName) <> 0 && 012094mjw SELECT (cFileName) USE ELSE IF SELECT(cFileAlias) <> 0 SELECT (cFileAlias) USE ENDIF ENDIF IF lExclUse && Open Exclusive USE (cFileName) NEW EXCLUSIVE ALIAS ( cFileAlias ) ELSE && Open Shared USE (cFileName) NEW ALIAS (cFileAlias) ENDIF IF .NOT. NETERR() && USE succeeds lRetVal := .t. EXIT ENDIF cMsgScrn := msg("Attempting to open file",0) IF LASTKEY() == 27 .OR. nWaitTime == 0 && User pressed <Esc> or timeout nQuery := ALERT("Attempt to open file was unsuccessful: Retry?",; {"Yes","No"}) IF nQuery <> 1 lRetVal := .f. EXIT ELSE scrnRest( cMsgScrn ) IF nWaitTime == 0 nWaitTime := nTime ENDIF ENDIF ENDIF nWaitTime := nWaitTime - 1 ENDDO SETCOLOR(cCurColor) SETCURSOR(cCurCursor) scrnRest(cCurScrn) RETURN lRetVal FUNCTION appendRec( nWaitTime ) ****************************************************************************** * Function......: APPENDREC() * * System........: Library Function * * Version.......: 1.1 * * Author........: Mark J. Wallin, Ph.D. * * Description...: Multi-user function to append a blank record in a data * * ..............: file. Allows the user to abort if the attempt fails. * * Copyright.....: 1990-1994, Mark J. Wallin, 21st Century Computing * * Language......: Developed to be run under CLIPPER 5.2c * * Parameters....: wait_time in seconds: 0 = wait forever. * * Returns.......: NIL * * Last Rev. Date: 01/05/94 * * Last Rev. Time: 00:47 * ****************************************************************************** LOCAL lForever, nTime, cCurFileName, lRetVal := .t. LOCAL lOutLoop := .t. LOCAL cCurScrn, cCurColor, cCurCursor cCurFileName := ALIAS() nTime := nWaitTime APPEND BLANK && Try to append a blank IF .NOT. NETERR() RETURN lRetVal && APPEND was successful ENDIF cCurScrn := scrnSave(0, 0,24,79) && Save current screen, colors cCurColor := SETCOLOR( aColors[COLMSG] ) && and set cursor off cCurCursor:= SETCURSOR( SC_NONE ) lForever := (nWaitTime == 0) DO WHILE lOutLoop DO WHILE ( lForever .OR. nWaitTime > 0 ) INKEY(.5) && Pause for 1/2 second nWaitTime := nWaitTime - .5 && Decrement 1/2 second APPEND BLANK IF .NOT. neterr() lRetVal := .t. RETURN lRetVal ENDIF cMsgScrn := msg("Attempting to Add Record",0) *cMsgScrn := msg("PLEASE WAIT: Unable to add record",0) *IF TYPE("lwin") = "U" && Window not opened yet * lwin = WINDOW(9,25,16,56,.t.,"PLEASE WAIT") * @ 13,31 say 'Unable to add record' * SAY_CEN(14,80,'('+upper(file_alias)+')') *end if IF LASTKEY() == 27 .OR. nWaitTime == 0 && User pressed <Esc> or timeout nQuery := ALERT("Attempt to add record was unsuccessful: Retry?",; {"Yes","No"}) IF nQuery <> 1 lOutLoop = .f. lRetVal := .f. EXIT ELSE scrnRest( cMsgScrn ) IF nWaitTime == 0 nWaitTime := nTime ENDIF ENDIF ENDIF ENDDO ENDDO SETCOLOR(cCurColor) SETCURSOR(cCurCursor) scrnRest(cCurScrn) RETURN lRetVal FUNCTION recLock( nWaitTime ) ****************************************************************************** * Function......: RECLOCK() * * System........: Library Function * * Version.......: 1.1 * * Author........: Mark J. Wallin, Ph.D. * * Description...: Locks a record, allowing user to abort if lock fails. * * ..............: * * Copyright.....: 1990-1994, Mark J. Wallin, 21st Century Computing * * Language......: Developed to be run under CLIPPER 5.2c * * Parameters....: nWaitTime - seconds to wait, 0 = wait forever * * Returns.......: NIL * * Last Rev. Date: 01/05/94 * * Last Rev. Time: 00:47 * ****************************************************************************** LOCAL lWait, lRetVal := .t., nTime, cCurFile, cMsgScrn, cCurCursor, ; cCurColor, cCurScrn, lOutLoop := .t. cCurFile := ALIAS() IF RLOCK() RETURN lRetVal && Lock successful ENDIF cCurScrn := scrnSave(0, 0,24,79) && Save current screen, colors cCurColor := SETCOLOR( aColors[COLMSG] ) && and set cursor off cCurCursor:= SETCURSOR( SC_NONE ) lWait := ( nWaitTime == 0 ) nTime := nWaitTime DO WHILE lOutLoop DO WHILE ( lWait .OR. nWaitTime > 0 ) INKEY(.5) && Wait 1/2 second nWaitTime := nWaitTime - .5 IF RLOCK() lRetVal := .t. lOutLoop = .f. EXIT ENDIF cMsgScrn := msg("Attempting to Lock Record",0) IF LASTKEY() == 27 .OR. nWaitTime == 0 && User pressed <Esc> or timeout nQuery := ALERT("Attempt to lock record was unsuccessful: Retry?",; {"Yes","No"}) IF nQuery <> 1 lOutLoop = .f. lRetVal := .f. EXIT ELSE scrnRest( cMsgScrn ) IF nWaitTime == 0 nWaitTime := nTime ENDIF ENDIF ENDIF ENDDO ENDDO SETCOLOR(cCurColor) SETCURSOR(cCurCursor) scrnRest(cCurScrn) RETURN lRetVal FUNCTION fileLock( nWaitTime ) ****************************************************************************** * Function......: FILELOCK() * * System........: CREDIT COLLECTIONS DATABASE MANAGER * * Version.......: 2.0 * * Author........: Mark J. Wallin, Ph.D. * * Description...: Attempts to lock the current shared file. * * Copyright.....: 1990-1994, Mark J. Wallin, 21st Century Computing * * Language......: Developed to be run under CLIPPER 5.2c * * Parameters....: Retry time in seconds, 0 = forever * * Returns.......: .t./.f. * * Last Rev. Date: 01/05/94 * * Last Rev. Time: 00:47 * ****************************************************************************** LOCAL lWait, lRetVal := .t., nTime, cCurFile, cMsgScrn, cCurCursor, ; cCurColor, cCurScrn IF FLOCK() RETURN lRetVal && Lock was successful ENDIF cCurScrn := scrnSave(0, 0,24,79) && Save current screen, colors cCurColor := SETCOLOR( aColors[COLMSG] ) && and set cursor off cCurCursor:= SETCURSOR( SC_NONE ) nTime := nWaitTime lWait := (nWaitTime == 0) DO WHILE (forever .OR. wait_time > 0) IF FLOCK && Open Exclusive lRetVal := .t. EXIT ENDIF cMsgScrn := msg("Attempting to lock file",0) IF LASTKEY() == 27 .OR. nWaitTime == 0 && User pressed <Esc> or timeout nQuery := ALERT("Attempt to lock file was unsuccessful: Retry?",; {"Yes","No"}) IF nQuery <> 1 lRetVal := .f. EXIT ELSE scrnRest( cMsgScrn ) IF nWaitTime == 0 nWaitTime := nTime ENDIF ENDIF ENDIF nWaitTime := nWaitTime - 1 ENDDO SETCOLOR(cCurColor) SETCURSOR(cCurCursor) scrnRest(cCurScrn) RETURN lRetVal