Power-Programmierung/CD1.mdf/xbase/library/dbase/duflp/screen.prg

Text File | 1992-07-06 | 52KB | 1,283 lines

*-------------------------------------------------------------------------------
*-- Program...: SCREEN.PRG
*-- Programmer: Ken Mayer (KENMAYER)
*-- Date......: 06/29/1992
*-- Notes.....: A few routines not left in PROC.PRG, these are not used as much
*--             by my own systems. See the file: README.TXT for details on how
*--             to use this library file.
*-------------------------------------------------------------------------------

FUNCTION Radio
*-------------------------------------------------------------------------------
*-- Programmer..: Ed Lafferty (GICHIN)
*-- Date........: 06/08/1992
*-- Notes.......: Routine to create and size a popup with radio buttons
*--               for choosing only one of up to four options.  Pressing
*--               the <Space Bar> on an option turns it on or off.
*--               Pressing <Enter> chooses the selected option and leaves
*--               the routine.
*-- Written for.: dBase IV, 1.1
*-- Rev. History: 02/25/1992 - original procedure.
*--               02/27/1992 -- Ken Mayer -- added option for color, but had
*--               to take number of choices back to 4 to do so. Minor
*--               alterations performed to add color choice ... and cleaning
*--               up after self ... (original cleared the screen first ...
*--               this version saves screen, restores back to it ...) Oh yeah,
*--               I turned it into a function, rather than a procedure, as well.
*--               06/08/1992 -- Ken Mayer -- explicit color handling.
*-- Calls.......: CENTER                Procedure in PROC.PRG
*--               SHADOW                Procedure in PROC.PRG
*--               EXTRCLR()             Function in PROC.PRG
*--               COLORBRK()            Function in PROC.PRG
*--               RECOLOR               Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: Radio(<nULRow>,<nULCol>,<nChoice>,"<cTxt1>","<cTxt2>",;
*--                        "<cTxt3>","<cTxt4>","<cTitle>","<cColor>")
*-- Example.....: cPort = Radio(8,15,1,"LPT1","LPT2","LPT3","",;
*--                             "Choose a printer port","rg+/gb,n/w,rg+/gb")
*-- Returns.....: number of chosen button in nChoice
*-- Parameters..: nUlrow  = upper left row of popup
*--               nUlcol  = upper left column of popup
*--               nChoice = default chosen button
*--               cTxt1   = Text for 1st button
*--               cTxt2   =  "    "  2nd   "
*--               cTxt3   =  "    "  3rd   "
*--               cTxt4   =  "    "  4th   "
*--               cTitle  = Text for the box title
*--               cColor  = Color string (i.e., "RG+/GB,N/W,RG+/GB")
*-------------------------------------------------------------------------------

    parameters nUlrow, nUlcol, nChoice, cTxt1, cTxt2, cTxt3, cTxt4, ;
                    cTitle, cColor
    private nHeight, nKey, nCnt, nWidth, cStr, cTxt0, cMidCol, cFirstCol,;
                   cCursor,cCurColor,cTempCol

    cCursor = set("CURSOR")
    store cTitle to cTxt0
    save screen to sRadio
    store 0 to nHeight, nKey, nCnt, nWidth
    store nChoice to nOrig  && in case user presses <Esc> to exit ...

    *-- save current colors
    cCurColor = set("ATTRIBUTES")
    *-- set new ones
    cTempCol = colorbrk(cColor,1)
    set color of normal  to &cTempCol
    set color of message to &cTempCol
    cTempCol = colorbrk(cColor,2)
    set color of highlight to &cTempCol
    cTempCol = colorbrk(cColor,3)
    set color of box to &cTempCol

    *-- deal with these colors in displaying some stuff ...
    cMidCol = colorbrk(cColor,2)
    *-- First color (for message) is easier ...
    cFirstCol = colorbrk(cColor,1)

    *-- Determine height and width of popup
    do case
        case len(cTxt4) > 0
           nHeight = 4
        case len(cTxt3) > 0
           nHeight = 3
        case len(cTxt2) > 0
           nHeight = 2
        otherwise
           nHeight = 1
    endcase

    do while nCnt <=nHeight
       store "cTxt"+str(nCnt,1) to cStr
       if len(&cstr) > nWidth
          nWidth = len(&cStr)
       endif
       nCnt = nCnt + 1
    enddo

    *-- create popup
    define window wRadio from nUlRow,nUlCol to nUlRow+nHeight+3,nUlCol+nWidth+9;
            double color &cColor
    do center with 23,80,"&cFirstCol","Press "+chr(24)+chr(25)+;
                                    ", <Space> to select/de-select, <Enter> to quit"
    do shadow with nULRow, nULCol, nULRow+nHeight+3, nULCol+nWidth+9
    activate window wRadio

    *-- display screen
    store 1 to nCnt
    do center with 0, nWidth+8, "", cTitle
    do while nCnt <= nHeight
       store "cTxt"+str(nCnt,1) to cStr
       @ nCnt+1, 2 SAY "[ ]" color &cMidCol
        @ nCnt+1, 6 say &cStr
       nCnt = nCnt + 1
    enddo

    *-- prepare for and get nChoice
    if nChoice > 0
       store nChoice to nCnt
        @nCnt+1,3 say "■" color &cMidCol
    else
       store 1 to nCnt
    endif
    store .F. to ldone

    *-- this loop processes user input ...
    do while .not. ldone
        @ nCnt+1,3 say "" color &cMidCol
        nkey = inkey(0)
        do case
        case nkey = 27                   && Press Esc to exit
           store nOrig to nChoice        && Leave at "default"
           store .T. to ldone
        case nkey = 13
           store .T. to ldone
        case nkey = 32                   && Press Enter or Space
              set cursor off
              if nChoice = nCnt
                 @ nCnt+1,3 say " " color &cMidCol
                 store 0 to nChoice
              else
                 @ nChoice+1,3 say " " color &cMidCol
                 @ nCnt+1,3 say "■" color &cMidCol
                 store nCnt to nChoice
              endif
              set cursor on
        case nkey = 5                    && Press up arrow
           if nCnt > 1
              nCnt = nCnt - 1
           else
              nCnt = nHeight
           endif
        case nkey = 24                   && Press down arrow
           if nCnt < nHeight
              nCnt = nCnt + 1
           else
              nCnt = 1
           endif
        endcase
    enddo

    *-- cleanup
    deact window wRadio
    release window wRadio
    restore screen from sRadio
    release screen sRadio
    set message to
    set cursor &cCursor
    do ReColor with cCurColor

RETURN nChoice
*-- EoF: Radio()

PROCEDURE CheckBox
*-------------------------------------------------------------------------------
*-- Programmer..: Ed Lafferty (GICHIN)
*-- Date........: 02/28/1992
*-- Notes.......: Routine to create and size a popup with check boxes
*--               for choosing any of a number (up to five) options.  Pressing
*--               the <Space Bar> on an option turns it on or off.
*--               Pressing <Enter> chooses the selected option and leaves
*--               the routine. You must use a data structure with logical
*--               fields, or memvars that are logical for this. Either way,
*--               even if you don't use five logical fields/memvars, you must
*--               pass a field/memvar to the procedure -- see Example below
*--               (the logicals -- lCHK1, lCHK2, etc.-- must be fields or
*--               memvars due to a limitation in parameter passing in dBASE IV.)
*-- Written for.: dBase IV, Version 1.1
*-- Rev. History: 02/25/1992 - original procedure.
*--               02/28/1992 -- Ken Mayer -- modified to allow passing cColor,
*--               and a little cleanup of code and such. Minor changes.
*-- Calls.......: CENTER               Procedure in PROC.PRG
*--               SHADOW               Procedure in PROC.PRG
*--               EXTRCLR()            Function in PROC.PRG
*--               COLORBRK()           Function in PROC.PRG
*--               RECOLOR              Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: do checkbox with <nULCol>,<nULRow>,<lchk1>,<lchk2>,<lchk3>,;
*--                          <lchk4>,"<cTxt1>","<cTxt2>","<cTxt2>",;
*--                          "<cTxt3>","<cTxt4>","<cTxt0>","<cColor>"
*-- Example.....: do Checkbox with 8, 15, lchk1, lchk2, lchk3, lchk4,;
*--                    "LPT1", "LPT2", "LPT3","","Choose a printer port",;
*--                    "rg+/gb,w+/n,rg+/gb"
*-- Returns.....: .T. for selected items, .F. for non-selected items --
*--               this routine changes the value of the logical fields passed
*--               to it.
*-- Parameters..: nULRow = upper left row of popup
*--               nULCol = upper left column of popup
*--               lChkn  = default value of box 'n' -- MUST BE FIELDS/MEMVARS
*--               cTxt1  = Text for 1st box
*--               cTxt2  =  "    "  2nd   "
*--               cTxt3  =  "    "  3rd   "
*--               cTxt4  =  "    "  4th   "
*--               cTxt0  = Text for the box title
*--               cColor = Colors to be used in window ...
*-------------------------------------------------------------------------------

    parameters nUlrow, nUlcol, lChk1, lChk2, lChk3, lChk4, ;
                 cTxt1, cTxt2, cTxt3, cTxt4, cTxt0, cColor
    private nHeight, nKey, nCnt, nWidth, lOrig1, lOrig2, lOrig3, lOrig4,;
              cMidCol, cFirstCol, cCursor, cCurColor,cTempCol

    *-- save current colors
    cCurColor = set("ATTRIBUTES")
    *-- set new ones
    cTempCol = colorbrk(cColor,1)
    set color of normal  to &cTempCol
    set color of message to &cTempCol
    cTempCol = colorbrk(cColor,2)
    set color of highlight to &cTempCol
    cTempCol = colorbrk(cColor,3)
    set color of box to &cTempCol

    *-- setup ...
    cCursor = set("CURSOR")
    save screen to sCheck
    store 0 to nHeight, nKey, nCnt, nWidth
    *-- save original settings, in case <Esc> gets pressed below ...
    store lChk1 to lOrig1
    store lChk2 to lOrig2
    store lChk3 to lOrig3
    store lChk4 to lOrig4
    *-- deal with some colors ...
    cMidCol = colorbrk(cColor,2)
    cFirstCol = colorbrk(cColor,1)

    *-- Determine height and width of popup
    *-- Determine height
    do case
    case len(cTxt4) > 0
       nHeight = 4
    case len(cTxt3) > 0
       nHeight = 3
    case len(cTxt2) > 0
       nHeight = 2
    case len(cTxt1) > 0
       nHeight = 1
    endcase

    *-- Determine width
    do while nCnt <=nHeight
       store "cTxt"+str(nCnt,1) to cStr
       if len(&cstr) > nWidth
          nWidth = len(&cStr)
       endif
       nCnt = nCnt + 1
    enddo

    *-- create popup
    define window wCheck from nUlrow, nUlcol to nUlrow+nHeight+3, nUlcol+nWidth+8;
        double color &cColor
    do center with 23,80,"&cFirstCol","Press "+chr(24)+chr(25)+;
        ", <Space> to select/de-select, <Enter> to quit"
    do shadow with nULRow,nULCol,nULRow+nHeight+3,nULCol+nWidth+8
    activate window wCheck
    store 1 to nCnt
    do center with 0, nWidth+8, "", cTxt0

    *-- paint screen
    do while nCnt <= nHeight
       store "cTxt"+str(nCnt,1) to cStr
       store "lChk"+str(nCnt,1) to cChk
       @ nCnt+1, 2 SAY "[ ]" color &cMidCol
        @ nCnt+1, 6 say &cStr
       @ nCnt+1, 3 SAY IIF(&cChk,"X"," ") color &cMidCol
       nCnt = nCnt + 1
    enddo

    *-- prepare for and get nChoice
    store 1 to nCnt
    store .F. to ldone
    do while .not. ldone
        store "lChk"+str(nCnt,1) to cChk
        @ nCnt+1,3 say "" color &cMidCol
        nkey = inkey(0)
        do case
            case nkey = 27                   && Press Esc to exit
               store lorig1 to lChk1         && Therefore, restore original
               store lOrig2 to lChk2         && values to lChk<n>'s
               store lOrig3 to lChk3
               store lOrig4 to lChk4
               store .T. to ldone
            case nkey = 13                   && Press Enter when finished
               store .T. to ldone
            case nkey = 32                   && Press Space
                  set cursor off
                  if &cChk                          && Box was already selected,
                     @ nCnt+1,3 say " " color &cMidCol   && so now de-select it
                     store .F. to &cChk
                  else                              && Box was not already selected,
                     @ nCnt+1,3 say "X" color &cMidCol   && so now select it
                     store .T. to &cChk
                  endif
                  set cursor on
            case nkey = 5                    && Press up arrow
               if nCnt > 1
                  nCnt = nCnt - 1
               else
                  nCnt = nHeight
               endif
            case nkey = 24                   && Press down arrow
               if nCnt < nHeight
                  nCnt = nCnt + 1
               else
                  nCnt = 1
               endif
        endcase
    enddo

    *-- Cleanup
    release window wCheck
    restore screen from sCheck
    release screen sCheck
    set message to
    set cursor &cCursor
    do ReColor with cCurColor

RETURN
*-- EoP: ChkBox

FUNCTION MenuPad
*-------------------------------------------------------------------------------
*-- Programmer..: Douglas P. Saine (XRED)
*-- Date........: 02/11/1992
*-- Notes.......: Used to create menu prompts of an even length. It works
*--               on any prompt - menu pads or popups.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 02/07/1992 - original function.
*--               02/11/1992 -- Ken Mayer -- modified to truncate <cChoice>
*--                 if it's longer than <nLength>.
*-- Calls.......: ALLTRIM()            Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: MenuPad("<cChoice>",<nLength>)
*-- Example.....: Define pad pPad1 of mMain;
*--                      prompt MenuPad("Menu Choice1",25) at 2,5
*-- Returns.....: <cChoice> padded with spaces (or truncated, if necessary)
*--               to <nLength>.
*-- Parameters..: cChoice = Menu-Pad/Popup-Bar Prompt description
*--               nLength = Length of pad/bar ...
*-------------------------------------------------------------------------------

    parameters cChoice, nLength
    private cReturn

    if len(alltrim(cChoice)) > nLength  && is it too long?
        cReturn = left(cChoice,nLength)  && truncate it ...
    else             && otherwise, pad it with spaces to the length required
        cReturn = cChoice + space(nLength-len(alltrim(cChoice)))
    endif

RETURN cReturn
*-- EoF: MenuPad()

FUNCTION Banner
*-------------------------------------------------------------------------------
*-- Programmer..: Dan Madoni (Borland)
*-- Date........: 09/xx/1991
*-- Notes.......: This will display a left-scrolling message on the screen
*--               within the boundaries specified in the UDF by the user.
*--               It will wait for a keypress and then go away. Taken from
*--               TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Usage.......: Banner(<nRow>,<nCol>,<nWidth>,"<cMessage>","<cColor>")
*-- Example.....: ?? Banner(5,30,20,"Love your tie, is it new?","w+/r")
*-- Returns.....: Null ("")
*-- Parameters..: nRow     = Leftmost ROW position of scrolled message
*--               nCol     = Leftmost COL position of scrolled message
*--               nWidth   = Length of displayable area starting at nRow,nCol
*--               cMessage = Message to be scrolled
*--               cColor   = Color of scrolling message
*-------------------------------------------------------------------------------

    parameters nRow,nCol,nWidth,cMessage,cColor
    private cCursor,cTalk,cMsg,nCounter,cPause

    *-- save some environment essentials
    save screen to sBanner
    cCursor = set("CURSOR")
    cTalk   = set("TALK")
    set cursor off
    set talk off

    *-- deal with message
    cMsg = space(nWidth)+cMessage+" "
    nCounter = 0

    *-- loop
    do while .t.
        nCounter = nCounter + 1
        if nCounter > len(cMsg)
            nCounter = 1
        endif

        *-- user hits any key
        cPause = inkey(.15)
        if cPause # 0
            exit
        endif

        *-- display message within scrollable area
        @nRow,nCol say substr(cMsg,nCounter,nWidth) color &cColor
    enddo

    *-- restore environment
    restore screen from sBanner
    release screen sBanner
    set cursor &cCursor
    set talk &cTalk

RETURN ""
*-- EoF: Banner()

FUNCTION SeeMatch
*-------------------------------------------------------------------------------
*-- Programmer..: Dan Madoni (Borland)
*-- Date........: 09/xx/1991
*-- Notes.......: Can be included in format screen to display an instant
*--               lookup match on a particular field. A shadowed box will
*--               appear with the matching value ... Taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 06/12/1992 -- Minor -- added call to RECOLOR
*-- Calls.......: RECOLOR              Procedure in PROC.PRG
*-- Called by...: None
*-- Usage.......: SeeMatch("<cFile>",<cSeekExp>,"<cReturn>",<nULRow>,<nULCol>,;
*--                        <nBRRow>,<nBRCol>,"<cColor>)
*-- Example.....: SeeMatch("TRAVEL",LASTNAME,"TRAVELCODE",2,40,4,60,"w+/r")
*-- Returns.....: .t.
*-- Parameters..: cFile    = Database alias in which lookup will be performed.
*--                          -- this file must already be USEd in some area.
*--               cSeekExp = Expression which will be SEEKed.
*--               cReturn  = Name of field to contain the 'return' value.
*--               nULRow   = Upper Left Row for box
*--               nULCol   = Upper Left Column for box
*--               nBRRow   = Bottom Right Row
*--               nBRCol   = Bottom Right Column
*--               cColor   = Color of box
*-------------------------------------------------------------------------------

    parameters cFile,cSeeExp,cReturn,nULRow,nULCol,nBRRow,nBRCol,cColor
    private cRetVal, cAttr, cStartFile

    *-- store starting position ...
    cStartFile = alias()
    select &cFile

    *-- look for a matching expression
    seek cSeekExp
    if found()
        cRetVal = &cReturn
    else
        cRetVal = "<Not Found>"
    endif

    *-- Store current color and draw a box
    cAttr = set("ATTRIBUTES")
    @nULRow+1,nULCol+1 fill to nBRRow+1,nBRCol+1 color w/n  && shadow
    set color to &cColor
    @nULRow,nULCol clear to nBRRow,nBRCol  && clear out area text will go in
    @nULRow,nULCol To       nBRRow,nBRCol  && draw box

    *-- display matching expresion, and return to initial area ...
    @nULRow+1,nULCol+2 say cRetVal
    do ReColor with cAttr
    select cStartFile

RETURN .t.
*-- EoF: SeeMatch()

FUNCTION Dialog
*-------------------------------------------------------------------------------
*-- Programmer..: Larry Quaglia (Borland)
*-- Date........: 11/xx/1991
*-- Notes.......: This routine provides a 'standard' set of dialogue boxes
*--               and buttons for all applications. The concept is to provide
*--               standardization for your apps. Taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 11/xx/1991 -- first published in TechNotes.
*--               06/09/1992 -- Modified to handle explicit colors, changed
*--               the color parameters a tad ... (KENMAYER)
*-- Calls.......: SHADOW               Function in PROC.PRG
*--               RECOLOR              Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: Dialog("<cMsg>",<nType>,"<cBorder>",<nDefBut>,<lShadow>,;
*--                      "<cWind>","<cButton>")
*-- Example.....: Dialog("We have completed the transaction.",0,"DOUBLE",;
*--                      0,.t.,"RG+/GB","W+/N")
*-- Returns.....: Character -- Either 'ERROR' or title of Button.
*-- Parameters..: cMsg    = Message to be displayed -- maximum of 78 characters
*--                          (one line only)
*--               nType   = Dialogue box TYPE. Options are 0 to 5:
*--                         0:   'OK'
*--                         1: 'OK'  'CANCEL'
*--                         2: 'ABORT'  'RETRY'  'IGNORE'
*--                         3: 'YES'  'NO'  'CANCEL'
*--                         4: 'YES'  'NO'
*--                         5: 'RETRY' 'CANCEL'
*--               cBorder = Border Style -- options are: "" (null) for SINGLE
*--                         DOUBLE or PANEL.
*--               nDefBut = Default Button.
*--               lShadow = Display with a shadow or not (both on window and
*--                         buttons)?
*--               cWind   = Window Colors (must be valid dBASE color combo:
*--                          i.e., "RG+/GB")
*--               cButton = Highlighted Button Color (Same as above, should
*--                         contrast ...)
*-------------------------------------------------------------------------------

    parameters cMsg,nType,cBorder,nDefBut,lShadow,cWind,cButton
    private nMsgLen,cNewColor,aButton,nMaxLine,nY,nBoxLen,nNumButton,nCounter,;
            nBasex,nYCol,nMsgLoc,cCurColor

    save screen to sDialog              && so we can restore at end of routine

    *-- determine length of message
    nMsgLen = len(trim(ltrim(cMsg))) + 1

    *-- Check for valid parms
    do case
        case nMsgLen > 78
            RETURN "ERROR - Message Length"
        case .not. (upper(cBorder) = "DOUBLE" .or. upper(cBorder) = "PANEL" .or.;
                    len(trim(cBorder)) = 0)
            RETURN "ERROR - Border"
    endcase

    *-- save current color info and set color to user-defined
    cCurColor = set("ATTRIBUTES")
    set color of normal    to &cWind
    set color of box       to &cWind
    set color of message   to &cWind
    set color of highlight to &cButton

    *-- Allow use of <Tab> to move from button to button
    on key label tab keyboard chr(4)  && act as if right arrow were pushed

    *-- Define button array -- max of 3 buttons (at the moment)
    declare aButton[3]
    aButton[1] = ""
    aButton[2] = ""
    aButton[3] = ""

    *-- Establish screen height to properly center dialogue box
    nMaxLine = iif(right(set("DISP"),2) = "43",43,24)

    *-- Determine length of passed "message" parameter. If long enough, make
    *-- the dialog box a little bigger. If very short, make it just big
    *-- enough to accomodate the three buttons.
    nY = iif(int(nMsgLen) > 30,int(nMsgLen/2)+2,24)
    nBoxLen = 2 * nY

    *-- Setup the window and determine if shadow ... if yes, call shadow
    define window wDialog from int(nMaxLine/2)-5,40-nY to ;
        int(nMaxLine/2)+4,40+nY &cBorder
    if lShadow
        do shadow with int(nMaxLine/2)-5,40-nY,int(nMaxLine/2)+4,40+nY
    endif
    activate window wDialog
    clear

    *-- Determine the type of buttons and set appropriate parms.
    *-- These could be modified to your own needs.
    do case
        case nType = 0
            nNumButton = 1
            aButton[1] = "   OK   "
        case nType = 1
            nNumButton = 2
            aButton[1] = "   OK   "
            aButton[2] = " CANCEL "
        case nType = 2
            nNumButton = 3
            aButton[1] = " ABORT  "
            aButton[2] = " RETRY  "
            aButton[3] = " IGNORE "
        case nType = 3
            nNumButton = 3
            aButton[1] = "   YES  "
            aButton[2] = "   NO   "
            aButton[3] = " CANCEL "
        case nType = 4
            nNumButton = 2
            aButton[1] = "   YES  "
            aButton[2] = "   NO   "
        case nType = 5
            nNumButton = 2
            aButton[1] = " RETRY  "
            aButton[2] = " CANCEL "
    endcase

    *-- Get dialog box length to create a bar menu of appropriate size.
    *-- Define the bar menu in a loop. Deactivate it upon selection of
    *-- one of the buttons.
    nCounter = 1
    nBaseX = nBoxLen / (nNumButton + 1)
    define menu mDialog
    do while nCounter <= nNumButton
        pPadName = "PAD"+str(nCounter,1)  && pad name is 'PAD #'
        nYCol = (nCounter * nBaseX) - (int(len(aButton[nCounter]) /2))
        define pad &pPadName of mDialog prompt aButton[nCounter] at 4,nYCol

        *-- If shadow is on, put shadows on buttons as well ...
        if lShadow
            do shadow with 3,nYCol-2,5,nYCol+(len(aButton[nCounter]))-1
        endif
        @3,nYCol-1 to 5,nYCol+(len(aButton[nCounter]))  && box around button
        on selection pad &pPadName of mDialog deactivate menu
        nCounter = nCounter + 1
    enddo

    *-- place message (centered in box)
    nMsgLoc = int(nBoxLen/2) - int(nMsgLen/2)
    @1,nMsgLoc say cMsg

    *-- place cursor to the default button specified by the user
    nCounter = 1
    do while nCounter < nDefBut
        keyboard chr(4)
        nCounter = nCounter + 1
    enddo

    *-- Activate the whole thing, and return the button name
    activate menu mDialog
    cValue = trim(ltrim(prompt()))

    *-- deactivate it all, restore screen, etc.
    deactivate window wDialog
    release window wDialog
    release menu mDialog
    restore screen from sDialog
    release screen sDialog
    do ReColor with cCurColor
    on key label tab

RETURN cValue
*-- EoF: Dialog()

FUNCTION MsgExp
*-------------------------------------------------------------------------------
*-- Programmer..: Adam Menkes (Borland)
*-- Date........: 09/xx/1991
*-- Notes.......: Allows you to display message (or error message), centered
*--               like SET MESSAGE ... with added utility. Does not use
*--               "(Press Space)", which can be annoying. The message and the
*--               line on which it is displayed will be the same color.
*--               Taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Usage.......: MsgExp("<cExp>")
*-- Example.....: MsgExp("This is a message")
*-- Returns.....: Message displayed (centered) on screen
*-- Parameters..: cExp  = Message to be displayed
*-------------------------------------------------------------------------------

    parameters cMsg
    private nLen

    nLen = len(trim(cMsg))

RETURN space((80-nLen)/2) + trim(cMsg) + space((80-nLen)/2)+" "
*-- EoF: MsgExp

FUNCTION Pick2
*-------------------------------------------------------------------------------
*-- Programmer..: Malcolm C. Rubel
*-- Date........: 05/18/1992
*-- Notes.......: I stole ... er ... lifted ... this from Data Based Advisor
*--               (Nov. 1991), and dUFLPed it, as well as removing the FoxPro
*--               code ...
*--               It's purpose is to create a popup/picklist that will
*--               find the proper location (used with a GET) on the
*--               screen for itself, display the popup and return the
*--               appropriate value ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 11/xx/1991 -- Malcom C. Rubel -- Original Code
*--               05/15/1992 -- Ken Mayer -- several things. First, I dUFLPed
*--               the code, and documented it heavier than the original.
*--                Next, I had to write a function (USED()), as there wasn't
*--               one sitting around that I could see.
*--                I added the 'cTag' parameter, as well as a few minor changes
*--               to the other functions that come with this routine ...
*--               05/19/1992 -- Resolved a few minor problems, removed routine
*--               PK_SHOW as being unnecessary (used @nGetRow... GET to
*--               redisplay field/memvar). Added IsBlank() (copy of EMPTY()) to
*--               handle different field types (original only wanted characters).
*-- Calls.......: ScrRow()             Function in SCREEN.PRG
*--               ScrCol()             Function in SCREEN.PRG
*--               Used()               Function in FILES.PRG (and here)
*-- Usage.......: Pick2("<cLookFile>","<cTag>","<cSrchFld>","<cRetFld>",;
*--                     <nScrRow>,<nScrCol>)
*-- Example.....: @10,20 get author ;
*--                      valid required pick2("Library","Author",;
*--                      "Last","Last",10,20)
*-- Returns.....: lReturn (found/replaced a value or not ...)
*-- Parameters..: cLookFile = file to lookup in
*--               cTag      = MDX Tag to use (if blank, will use the first
*--                           tag in the MDX file, via the TAG(1) option ...)
*--               cSrchFld  = field(s) to browse -- if blank, function will
*--                           try to use a field of same name as what
*--                           cursor is on.
*--               cRetFld   = name of field value is to be returned from.
*--               nScrRow   = screen-row (of GET) -- if blank, function will
*--                           determine (use ,, to blank it ... or 0)
*--               nScrCol   = screen-col (of GET) -- if blank, function will
*--                           determine
*-------------------------------------------------------------------------------

    parameters cLookFile, cTag, cSrchFld, cRetFld, nScrRow, nScrCol
    private cLookFile,cSrchFld,cRetFld,nScrRow,nScrCol,cVarName,xValReturn,;
            lWasOpen,cCurrBuff,lExact,lReturn,lIsFound,;
            cBarFields,nWinWidth,nGetRow,nGetCol

    lReturn = .t.                       && return value must be a logical ...
                                        &&   assume the best ...
    cVarName = varread()                && name of the variable at GET
    xVarValue = &cVarName               && value of the variable at GET

    *-- was a 'fieldname' to get value from passed to function?
    if isblank(cRetFld)                 && passed as a null
        cRetFld = cSrchFld               && we'll return contents of same name
                                         &&   as the search field
    endif

    nScrRow = ScrRow()                  && get row for picklist
    nScrCol = ScrCol()                  && get column for picklist
    cCurrBuff = alias()                 && current buffer (work area)
    lExact = set("EXACT") = "ON"        && store status of 'EXACT'
    set exact on                        && we want 'exact' matches ...

    *-- deal with the 'lookup' file -- if not open, open it, if open,
    *-- select it ...
    if .not. used(cLookFile)            && file not open
        select select()                  && find next open area
        use &cLookFile                   && open file
        lWasOpen = .f.
    else
        select (cLookFile)               && file IS open, move to it ...
        lWasOpen = .t.
    endif

    *-- deal with MDX tag for 'lookup' file ...
    if len(trim(cTag)) = 0              && if a null tag was sent,
        set order to Tag(1)              && set the order to first tag
    else
        set order to &cTag               && set it to what user passed.
    endif

    *-- screen positions ...
    nGetRow = row()                     && position of 'get' on screen
    nGetCol = iif(isblank(xVarValue),col(),col()-len(&cRetFld))
                                        && get column of 'get' ...

    *-- if field is empty, do a lookup, otherwise, look for it in table
    if isblank(xVarValue)               && no data in field
        lIsFound = .f.                   && automatic lookup
    else
        lIsFound = seek(xVarValue)       && look for it in table
    endif

    *-- if not found, or field was empty, bring up the lookup ...
    if .not. lIsFound                   && not in table
        go top                           && move pointer to top of 'table'
        *-- make sure it fits on screen
        if cRetFld = cSrchFld            && one browse field
            nWinWidth = len(&cSrchFld) + 3 && width
            cBarFields = cSrchFld         && set the 'browse fields'
        else                             && else multiple ....
            nWinWidth = len(&cSrchFld)+len(&cRetFld)+5
            cBarFields = cSrchFld+", "+cRetFld
        endif

        *-- this is how we determine where to start the browse table ...
        nScrCol = iif(nScrCol+nWinWidth>77,77-nWinWidth,nScrCol)
        nScrRow = iif(nScrRow>14,14,nScrRow)

        *-- set it up ...
        define window wPick from nScrRow,nScrCol+2 to ;
            nScrRow+10,nScrCol+nWinWidth+2 panel
        activate window wPick
        *on key label ctrl-m keyboard chr(23) && when user presses <enter>,
                                             && force an <enter> ... weird.

        *-- activate
        browse fields &cBarFields freeze &cSrchFld noedit noappend;
            nodelete nomenu window wPick
        clear typeahead                  && in case they pressed the <Enter> key

        on key label ctrl-m              && reset

        release window wPick

        if lastkey() # 27                && not the <Esc> key
            store &cRetFld to &cVarName   && put return value into var ...
        else
            lReturn = .F.
        endif
    else
        store &cRetFld to &cVarName
    endif

    @nGetRow, nGetCol get &cVarName     && display new value in field/memvar
                                        &&  on screen
    clear gets                          && clear gets from this function

    *-- reset work areas, and so on ...
    if .not. lExact
        set exact off
    endif
    if .not. lWasOpen
        use
    endif
    if len(cCurrBuff) # 0
        select (cCurrBuff)
    else
        select select()
    endif

RETURN (lReturn)
*-- EoF: Pick2()

FUNCTION ScrRow
*-------------------------------------------------------------------------------
*-- Programmer..: Malcolm C. Rubel
*-- Date........: 11/xx/1991
*-- Notes.......: Returns the postion of the current 'GET'. If memvar
*--               nScrRow already exists, returns the value of that, unless
*--               it's zero, in which case we return the current position.
*--               This is part of PICK2.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/15/1992 -- Ken Mayer (KENMAYER) to deal with a value of
*--               0 for the nScrRow memvar.
*-- Calls.......: None
*-- Usage.......: ScrRow()
*-- Example.....: nScrRow = ScrRow()
*-- Returns.....: Numeric -- position of cursor on screen
*-- Parameters..: None
*-------------------------------------------------------------------------------

    if type('nScrRow') # 'N' .or. nScrRow = 0
        return (row())
    else
        return (nScrRow)
    endif
*-- EoF: ScrRow()

FUNCTION ScrCol
*-------------------------------------------------------------------------------
*-- Programmer..: Malcolm C. Rubel
*-- Date........: 11/xx/1991
*-- Notes.......: Returns the postion of the current 'GET'. If memvar
*--               nScrCol already exists, returns the value of that, unless
*--               it's zero, in which case we return the current position.
*--               This will also return a different value based on whether or
*--               not the field has something in it or not ... This is part of
*--               PICK2.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/15/1992 -- Ken Mayer (KENMAYER) to deal with a value of
*--               0 for the nScrCol memvar.
*-- Calls.......: IsBlank()            FUNCTION in PICK2.PRG
*-- Usage.......: ScrCol()
*-- Example.....: nScrCol = ScrCol()
*-- Returns.....: Numeric -- position of cursor on screen
*-- Parameters..: None
*-------------------------------------------------------------------------------

    if type('nScrCol') # 'N' .or. nScrCol = 0
        if isblank(cRetFld)
            return col() + len(cRetFld)
        else
            return col()
        endif
    else
        return (nScrCol)
    endif

*-- EoF: ScrCol()

FUNCTION YesNoCan
*-------------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 06/11/1992
*-- Notes.......: Asks a yes/no/cancel question in a dialog window/box
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
*--               04/29/1991 - Modified to Ken Mayer add shadow
*--               05/13/1991 - Modified to Ken Mayer remove need for extra
*--                            procedures (YES/NO) that were used for returning
*--                            values from Menu
*--                            (suggested by Clinton L. Warren (VBCES))
*--               01/20/1992 - Modified by Martin Leon (HMan) to handle user
*--                            pressing 'Y' or 'N' keys (with ON KEY ...).
*--               06/11/1992 - Modified by Joey Carroll (JOEY) to allow
*--                            answer choices to be "Yes", "No", or "Cancel"
*--                            or to allow for parameters to pass the contents
*--                            of the prompts. If none are passed, they default
*--                            to "Yes", "No", "Cancel". Further modified to
*--                            allow specification of location by row if
*--                            desired. Window size now varies as parameters
*--                            dictate.
*-- Calls.......: SHADOW               Procedure in PROC.PRG
*--               CENTER               Procedure in PROC.PRG
*--               ISBLANK()            Function in MISC.PRG
*--               COLORBRK()           Function in PROC.PRG
*--               RECOLOR              Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: YesNoCan("<cAnswer>","<cMess1>","<cMess2>","<cMess3>",;
*--                 "<cPrompt1>","<cPrompt2>","<cPrompt3>",;
*--                  <nTopRow>,"<cColor>")
*-- Example.....: cAnswer="Y"
*--               cAnswer=YesNoCan(cAnswer,"*** Warning ***",;
*--                            "A serious error has occured.",;
*--                             "Choose carefully.","Proceed",;
*--                             "Retry","Cancel",10,;
*--                             "w+/r,n/w,w+/r")
*--               do case
*--                  case cAnswer="Y"    && OR case pad()=PPAD1
*--                     * do your thing
*--                  case cAnswer="N"    && OR case pad()=PPAD2
*--                     skip
*--                  case cAnswer="C"    && OR case pad()=PPAD3
*--                     * e.g. - return
*--               endcase
*--
*--                 The middle set of colors should be different, as they
*--                 will be the colors of the YES/NO selections ...
*--                 Options may be blank by using nul values ("")
*-- Returns.....: First character of selected pad
*-- Parameters..: cAnswer  = default value (Yes or No or Cancel) for menu
*--               cMess1   =  First line of Message
*--               cMess2   =  Second line of message
*--               cMess3   =  Third line of message
*--               cPrompt1 =  Optional prompt for left pad
*--               cPrompt2 =  Optional prompt for middle pad
*--               cPrompt3 =  Optional prompt for right pad
*--               nTopRow  =  Optional top row of window
*--               cColor   =  Optional colors for window/menu/box
*-------------------------------------------------------------------------------

   parameter cAnswer,cMess1,cMess2,cMess3,;
      cPrompt1,cPrompt2,cPrompt3,nTopRow,cColor
   private nLMargin,nRMargin,lWrap,nTopRowMax,cKey1,cKey2,cKey3,nWinWidth
    private cPrompt1,cPrompt2,cPrompt3,cCurColor,cTempCol

    *-- save screen so we can restore ...
   save screen to sYesNoCan
    *-- save current color setup
    cCurColor = set("ATTRIBUTES")
    *-- set new colors based on passed parm
    cTempCol = colorbrk(cColor,1)
    set color of normal to &cTempCol
    set color of box    to &cTempCol
    cTempCol = colorbrk(cColor,2)
    set color of highlight to &cTempCol
    cTempCol = colorbrk(cColor,3)
    set color of highlight to &cTempCol

   * locate top row of window
   nTopRowMax = iif(set("STATUS") = "OFF",17,14) && protect Status Line
   nTopRow = iif(isblank(nTopRow),14,nTopRow) && no parameter passed
   nTopRow = min(nTopRowMax,nTopRow)

   * set pad prompts if none passed
   cPrompt1 = iif(isblank(cPrompt1),"Yes",cPrompt1)
   cPrompt2 = iif(isblank(cPrompt2),"No",cPrompt2)
   cPrompt3 = iif(isblank(cPrompt3),"Cancel",cPrompt3)
   cAnswer = iif(isblank(cAnswer),cPrompt1,cAnswer)

   * determine how wide the window needs to be
   nWinWidth = max(19,len(cPrompt1 + cPrompt2 + cPrompt3) +13)
   nWinWidth = max(nWinWidth,len(cMess1)+4)
   nWinWidth = max(nWinWidth,len(cMess2)+4)
   nWinWidth = max(nWinWidth,len(cMess3)+4)
   * and center it
   define window wYesNoCan from nTopRow,40-(nWinWidth+2)/2 ;
      to nTopRow+7,40+(nWinWidth+2)/2 double color &cColor.
   define menu mYesNoCan
   define pad pPad1 of mYesNoCan Prompt "["+cPrompt1+"]" ;
      at 5,02
   * center middle prompt between other two, not center of window
   define pad pPad2 of mYesNoCan Prompt "["+cPrompt2+"]"  ;
      at 5,((nWinWidth-len(cPrompt2))/2+(len(cPrompt1)-len(cPrompt3))/2)
   define pad pPad3 of mYesNoCan Prompt "["+cPrompt3+"]"  ;
      at 5,(nWinWidth-3)-(len(cPrompt3))
   on selection pad pPad1 of mYesNoCan deactivate menu
   on selection pad pPad2 of mYesNoCan deactivate menu
   on selection pad pPad3 of mYesNoCan deactivate menu

   do shadow with nTopRow,40-(nWinWidth+2)/2,nTopRow+7,40+(nWinWidth+2)/2
   activate window wYesNoCan

   do center with 0,nWinWidth,"",cMess1       && center the text
   do center with 2,nWinWidth,"",cMess2
   do center with 3,nWinWidth,"",cMess3

   *-- deal with user pressing first key of prompt
   cKey1 = left(cPrompt1,1)
   cKey2 = left(cPrompt2,1)
   cKey3 = left(cPrompt3,1)

   on key label &cKey1. keyboard iif( PAD() = "PPAD1", "", ;
      iif(pad() = "PPAD2", chr(19),CHR(4) ))+chr(13)
   on key label &cKey2. keyboard iif( PAD() = "PPAD2",  "", ;
      iif(pad() = "PPAD1",CHR(4),chr(19) ))+chr(13)
   on key label &cKey3. keyboard iif( PAD() = "PPAD3", "", ;
      iif(pad() = "PPAD2", CHR(4),chr(19) ))+chr(13)
   clear typeahead
    *-- otherwise deal with regular "menu" abilities
   do case
      case cAnswer=cKey1
           activate menu mYesNoCan pad pPad1
      case cAnswer=cKey2
           activate menu mYesNoCan pad pPad2
      case cAnswer=cKey3
           activate menu mYesNoCan pad pPad3
   endcase

    *-- clear out ON KEY settings ...
   on key label &cKey1.
   on key label &cKey2.
   on key label &cKey3.
    *-- reset environment
   deactivate window wYesNoCan
   release window wYesNoCan
   restore screen from sYesNoCan
   release screen sYesNoCan
   release menu mYesNoCan
    do recolor with cCurColor

RETURN upper(substr(prompt(),2,1))
*-- EoF: YesNoCan()

PROCEDURE ProgBar
*-------------------------------------------------------------------------------
*-- Programmer..: Joey D. Carroll (JOEY)
*-- Date........: 06/28/1992
*-- Notes.......: A visual indicator of program activity, i.e. shows
*--               user program didn't die during long processes which
*--               do not normally show 'on screen'.  Serves same purpose
*--               as MONITOR, but is more graphic.
*--               For best appearance, set cursor 'off' from calling
*--               program, outside of the loop which calls PROGBAR.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do PROGBAR with <nQuan>,<cWindCol>,<cFillCol1>,cFillCol2>, ;
*--                   <cMessage>,<nWindWidth>
*-- Example.....: *-- determine what process will be monitored and what the
*--               *-- final value will be, e.g. nReccount = reccount()
*--               use <anyfile>
*--               nReccount = reccount()
*--               set cursor off
*--               scan
*--                  do progbar with nReccount,",,w+/n","w+/r","w+/g", ;
*--                     "Processing records.  Be patient.",40
*--                  *-- do some needed process here
*--               endscan
*--               *-- cleanup
*-- Returns.....: None
*-- Parameters..: nQuan     = maximum number of iterations
*--               cWindCol  = the window colors
*--               cFillCol1 = color of ruler before process
*--               cFillCol2 = color of ruler after process
*--               cMessage  = message displayed to user, may be "".
*--               nWindWid  = (optional) desired width of ruler window.  If
*--                               not specified, width of screen.  If
*--                               specified, will not be less than length of
*--                               message.
*-------------------------------------------------------------------------------

   parameters nQuan,cWindCol,cFillCol1,cFillCol2,cMessage,nWindWidth
   private lMessage,x, nParms
   lMessage  = iif(.not. isblank(cMessage), .t., .f.)  && was message passed?
    *-- find out # of parameters passed ...
    if val(right(version(),3)) > 1.1
        nParms = pcount()
    else
        nParms = 6
    endif
   nWindWidth = iif(nParms = 6,nWindWidth,78) && all the way if width not passed
   nWindWidth = min(nWindWidth,78)            && width param > 78 not allowed
   *-- window width can't be narrower than messsage, so....
   nWindWidth = iif(lMessage,max(nWindWidth,len(cMessage) + 2),nWindWidth)
   *-- skip this section if we've been here before
   *-- this procedure called from inside a loop
   *-- following section ignored except on first iteration thru loop
   if type("nTimes") = "U"  && check to see if we been here before
      save screen to sProgBar
      public nFactor,nTimes  && make these available on all iterations
      nProgLine = iif(set("status") = "ON",20,22)  && don't overwrite status
      *-- determine how wide the window needs to be
      define window wProgBar from ;
         nProgLine - iif(lMessage, 2, 1),(80 - (nWindWidth + 2)) / 2 ;
         to nProgLine + 1,(80 + (nWindWidth + 2)) / 2 - 1 ;
         double color &cWindCol
      activate window wProgBar
      @ 0,0 say replicate(".",nWindWidth - 1)  && the ruler
      @ 0,0 say "0%"                        && and some gradation %'s
      @ 0,nWindWidth / 4 - 2 say "25%"
      @ 0,nWindWidth / 2 - 2 say "50%"
      @ 0,3*(nWindWidth / 4) - 2 say "75%"
      @ 0,nWindWidth - 4 say "100%"
      @ 0,0 fill to 0,nWindWidth - 1 color &cFillCol1  && color of ruler before process
      if lMessage
         @ 1,(nWindWidth - (len(cMessage))) / 2 say cMessage color &cFillCol1
         @ 1,0 fill to 1,nWindWidth - 1 color &cFillCol1
      endif
      nFactor = nQuan/nWindWidth   && e.g. how many records per bar part(cols)
      nTimes = 0  && times thru loop
   endif      && type("nTimes") = "U"

   *-- this section will be processed as many times as required by nQuan
   nTimes = nTimes + 1
   @ 0,0 fill to 0,int(nTimes / nFactor) ;
         - iif(int(nTimes / nFactor) - 1 >= 0, 1, 0) ;
         color &cFillCol2    && color of ruler as processing takes place
   if nTimes = nQuan  && we done
      x = inkey(.5)   && leave on screen just a liitle while after completion
      *-- cleanup your mess
      deactivate window wProgBar
      release window wProgBar
      restore screen from sProgBar
      release screen sProgBar
      release nProgBar,nFactor,nTimes,lMessage,x
   endif  && nTimes = nQuan
RETURN
*-- EoP: ProgBar

PROCEDURE ProgBar2
*-------------------------------------------------------------------------------
*-- Programmer..: Joey D. Carroll (JOEY)
*-- Date........: 06/28/1992
*-- Notes.......: A crippled version of PROGBAR for those who want it simple.
*--               A visual indicator of program activity, i.e. shows
*--               user program didn't die during long processes which
*--               do not normally show 'on screen'.  Serves same purpose
*--               as MONITOR, but is more graphic.
*--               For best appearance, set cursor 'off' from calling
*--               program, outside of the loop which calls PROGBAR.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do PROGBAR2 with <nQuan>,<cWindCol>,<cFillCol1>,cFillCol2>
*-- Example.....: *-- determine what process will be monitored and what the
*--               *-- final value will be, e.g. nReccount = reccount()
*--               use <anyfile>
*--               nReccount = reccount()
*--               set cursor off
*--               scan
*--                  do progbar2 with nReccount,",,w+/n","w+/r","w+/g"
*--                  *-- do some needed process here
*--               endscan
*--               *-- cleanup
*-- Returns.....: None
*-- Parameters..: nQuan     = maximum number of iterations
*--               cWindCol  = the window colors
*--               cFillCol1 = color of ruler before process
*--               cFillCol2 = color of ruler after process
*-------------------------------------------------------------------------------

   parameters nQuan,cWindCol,cFillCol1,cFillCol2   && e.g. how many records
   private nWindWidth
   nWindWidth = 78  && hard coded, wall to wall

   *-- skip this section if we've been here before
   *-- this procedure called from inside a loop
   *-- following section ignored except on first iteration thru loop
   if type("nTimes") = "U"
      save screen to sProgBar
      public nFactor,nTimes
      if set("status") = "ON"  && different location if status "on"
         define window wProgBar from 19,0 to 21,79 double color &cWindCol
      else
         define window wProgBar from 21,0 to 23,79 double color &cWindCol
      endif   && set("status") = "ON"
      activate window wProgBar
      @ 0,0 say replicate(".",nWindWidth - 1)  && the ruler
      @ 0,0 say "0%"                        && and some gradation %'s
      @ 0,nWindWidth / 4 - 2 say "25%"
      @ 0,nWindWidth / 2 - 2 say "50%"
      @ 0,3*(nWindWidth / 4) - 2 say "75%"
      @ 0,nWindWidth - 4 say "100%"
      @ 0,0 fill to 0,nWindWidth - 1 color &cFillCol1  && color of ruler before process
      nFactor = nQuan/nWindWidth   && e.g. how many records per bar part(cols)
      nTimes = 0  && times thru loop
   endif      && type("nTimes") = "U"

   *-- the section will be processed as many times as required by nQuan
   nTimes = nTimes+1
   @ 0,0 fill to 0,int(nTimes/nFactor) ;
         - iif(int(nTimes/nFactor) -1 >= 0,1,0) ;
         color &cFillCol2    && color of ruler as processing takes place

   if nTimes = nQuan  && we done
      x = inkey(.5)   && leave on screen just a liitle while after completion
      * cleanup your mess
      deactivate window wProgBar
      release window wProgBar
      restore screen from sProgBar
      release screen sProgBar
      release nProgBar,nFactor,nTimes,nWindWidth,x
   endif

RETURN
*-- EoP: PROGBAR2

*-------------------------------------------------------------------------------
*-- Function USED is here from the FILES.PRG file, for use with PICK2 above.
*-------------------------------------------------------------------------------

FUNCTION Used
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KENMAYER)
*-- Date........: 05/15/1992
*-- Notes.......: Created because the picklist routine by Malcolm Rubel
*--               from DBA Magazine (11/91) calls a function that checks
*--               to see if a DBF file is open ... the one he calls doesn't
*--               exist. This is designed to loop until all possible work
*--               areas are checked (for 1.1 this maxes at 10, for 1.5 it's
*--               40 ... this routine checks both). Written for PICK2,
*--               this should be transportable ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: None
*-- Calls.......: None
*-- Usage.......: Used("<cFile>")
*-- Example.....: if used("Library")
*--                  select library
*--               else
*--                  select select()
*--                  use library
*--               endif
*-- Returns.....: Logical (.t. if file is in use, .f. if not)
*-- Parameters..: cFile = file to check for
*-------------------------------------------------------------------------------

    parameters cFile
    private lReturn, nAlias, nMax

    *-- maximum # of work areas is based on version of dBASE ...
    *-- if 1.5 or higher, the max is 40, if 1.1 or lower, it's 10.
    if val(right(version(),3)) > 1.1
        nMax = 40
    else
        nMax = 10
    endif

    *-- a small loop
    nAlias = 0                          && start at 0, increment as we go
    lReturn = .f.                       && assume it's not open
    do while nAlias < nMax              && loop until we find it, or we max
        nAlias = nAlias + 1              && increment
        if alias(nAlias) = upper(cFile)  && is THIS the one?
            lReturn = .t.                 && if so, set lReturn to .t.
            exit                          &&   and exit the loop
        endif  && if alias ...
    enddo

RETURN lReturn
*-- EoF: Used()

*-------------------------------------------------------------------------------
*-- EoP: SCREEN.PRG
*-------------------------------------------------------------------------------