home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
POINT Software Programming
/
PPROG1.ISO
/
clipper
/
cliplib
/
semlib.prg
< prev
Wrap
Text File
|
1994-01-20
|
83KB
|
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