Media Share 9/MEDIASHARE_09.ISO/progmisc/dblib201.zip/SCREEN.PRG

Text File | 1993-04-27 | 102KB | 2,476 lines

*-------------------------------------------------------------------------------
*-- Program...: SCREEN.PRG
*-- Programmer: Ken Mayer (CIS: 71333,1030)
*-- Date......: 02/23/1993
*-- 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 (CIS: 76150,3302)
*-- 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.
*-- Calls.......: CENTER                Procedure in PROC.PRG
*--               SHADOW                Procedure in PROC.PRG
*--               COLORBRK()            Function 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

    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 ...

    *-- 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"
    activate screen
    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

RETURN nChoice
*-- EoF: Radio()

PROCEDURE CheckBox
*-------------------------------------------------------------------------------
*-- Programmer..: Ed Lafferty (CIS: 76150,3302)
*-- Date........: 04/22/1993
*-- 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.5+
*-- 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.
*--               04/22/1993 -- Angus Scott-Fleming:
*--                   Revised for 1.5:
*--                   Turned cursor on
*--                   Moved help-line info inside box.
*--                   Reorganized parameters to allow calling
*--                      with variable # of choices, and evaluate with pCOUNT()
*--                   NOTE: If more than 9 pairs are needed, two loops will
*--                      have to be changed from STR(NCNT,1) to lTrim STR(cCnt,2))
*--                   Enabled error-trapping for poorly located boxes.
*--                   Appended "." to all &Macros.
*-- Calls.......: CENTER               Procedure in PROC.PRG
*--               SHADOW               Procedure in PROC.PRG
*--               COLORBRK()           Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: do checkbox with <nULCol>,<nULRow>,<cTitle>,<cColor>,;
*--                          <lchk1>,<cTxt1>,[<lchk2>,<cTxt2>];
*--                          [,<lchk3>,<cTxt3>][,<lchk4>,<cTxt4>];
*--                          [... to 9]
*-- Example.....: do Checkbox with 8, 15, "Choose a printer port",;
*--                    "rg+/gb,w+/n,rg+/gb", lchk1, "LPT1", lchk2, "LPT2", ;
*--                    lchk3, "LPT3"
*-- 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
*--               cTitle = Title for box
*--               cColor = Colors for window
*--               lChkn  = default value of box 'n' -- MUST BE FIELDS/MEMVARS
*--               cTxtn  = Text for 'n'th box
*--               cColor = Colors to be used in window ...
*-------------------------------------------------------------------------------

    parameters nUlrow, nUlcol, cTitle, cColor, lChk1, cTxt1, lChk2, cTxt2,;
                  lChk3, cTxt3, lChk4, cTxt4, lChk5, cTxt5, lChk6, cTxt6,;
                 lChk7, cTxt7, lChk8, cTxt8, lChk9, cTxt9
    private nHeight, nKey, nCnt, nWidth, cMidCol, cFirstCol, cCursor,;
               cPrompt, nBRRow, nBRCol

    *-- setup ...
    cCursor = set("CURSOR")
    save screen to sCheck
    store 0 to nHeight, nKey, nWidth
    cPrompt = "Press "+chr(24)+chr(25)+;
        ", <Space> to select/de-select, <Enter> to quit"

    *-- save original settings, in case <Esc> gets pressed below ...
    *-- determine height/width of popup
    nWidth  = max(len(cPrompt),len(cTitle))
    nHeight = (pcount() - 4)/2
    nCnt    = 0
    do while nCnt < nHeight
        nCnt = nCnt + 1
        cCnt = str(nCnt,1)
        private lOrig&cCnt.
        store lChk&cCnt. to lOrig&cCnt.
        nWidth = max(nWidth,len(cTxt&cCnt.))
    enddo
    *-- add border to window
    nWidth = min(nWidth+8,79)

    *-- deal with some colors ...
    cMidCol   = colorbrk(cColor,2)
    cFirstCol = colorbrk(cColor,1)

    *-- create popup and trap errors defining the window
    nBrRow = nULRow + nHeight + 5
    nBRCol = nULCol + nWidth
    if nBRRow > 24
        *-- center window vertically
        nULRow = max(12-(nHeight+5)/2,0)
        nBRRow = min(23,(nULRow+nHeight+5))
    endif
    if nBRCol > 80
        *-- center window horizontally
        nULCol = max(40 - nWidth/2,0)
        nBRCol = min(79,(nULCol+nWidth))
    endif

    define window wCheck from nUlrow, nUlcol to nBRRow, nBRCol;
        double color &cColor.
    activate screen
    do shadow with nULRow,nULCol,nBRRow,nBRCol
    activate window wCheck

    *-- paint screen
    do center with 0,nWidth,"",cTitle
    store 1 to nCnt
    do while nCnt <= nHeight
        store "cTxt"+str(nCnt,1) to cStr
        store "lChk"+str(nCnt,1) to cChk
        @nCnt+1,2 say "["+iif(&cChk.,"X"," ")+"]" color &cMidCol.
        @nCnt+1,6 say left(&cStr.,nWidth-9)
        nCnt = nCnt + 1
    enddo
    do center with nCnt+2,nWidth,"",cPrompt

    *-- 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
                nCnt = 0
                do while nCnt < nHeight
                    nCnt = nCnt + 1
                    cCnt = str(nCnt,1)
                    store lOrig&cCnt. to lChk&cCnt.
                enddo
               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.

RETURN
*-- EoP: ChkBox

FUNCTION MenuPad
*-------------------------------------------------------------------------------
*-- Programmer..: Douglas P. Saine (CIS: 74660,3574)
*-- 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/01/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: 09/01/1991 -- Original
*-- 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........: 06/12/1992
*-- 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: 09/01/1991 -- Original
*--               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........: 06/09/1992
*-- 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/01/1991 -- first published in TechNotes.
*--               06/09/1992 -- Modified to handle explicit colors, changed
*--               the color parameters a tad ... (Ken Mayer)
*-- 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
        activate screen
        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
            activate screen
            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........: 02/05/1993
*-- 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: 09/01/1991 -- Original routine
*--               02/05/1993 -- Modified by Lee Hite to handle a string that
*--                             is greater than 80 characters (this can be
*--                             a real problem if the message is in row 24!)
*-- 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 = (80-len(trim(cMsg)))/2

RETURN space(nLen) + trim(cMsg) + space(nLen+0.5)
*-- EoF: MsgExp

FUNCTION YesNoCan
*-------------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 02/01/1993
*-- 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.
*--               09/21/1992 - Modified by JOEY to fix bug caused if leading
*--                            blanks in parameters cPrompt1,cPrompt2,cPrompt3
*--                            Corrected example - case pad()="PPAD1"
*--                            instead of          case pad()=PPAD1
*--               02/01/1993 - Mods by Lee Hite: Routine would not wait for
*--                            user response if "default" answer did not match
*--                            one of the prompts. Now first prompt becomes
*--                            default if no match is found on invocation.
*--                            Also, match is no longer case sensitive.  Also
*--                            made window height variable if message
*--                            lines 2 and/or 3 are null strings.  Finally,
*--                            added "confirmation" parameter which when set
*--                            true will force user to press [Enter] before
*--                            function returns.
*-- Calls.......: SHADOW               Procedure in PROC.PRG
*--               CENTER               Procedure in PROC.PRG
*--               ISBLANK()            Function in MISC.PRG, Internal in 1.5
*-- Called by...: Any
*-- Usage.......: YesNoCan("<cAnswer>","<cMess1>","<cMess2>","<cMess3>",;
*--                 "<cPrompt1>","<cPrompt2>","<cPrompt3>",;
*--                  <nTopRow>,"<cColor>",[lConfirm])
*-- 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
*--               lConfirm =  Optional "confirmation" parameter -- if true
*--                           user must press [Enter], otherwise pressing
*--                           a valid prompt key automatically returns
*-------------------------------------------------------------------------------

   parameter cAnswer,cMess1,cMess2,cMess3,;
      cPrompt1,cPrompt2,cPrompt3,nTopRow,cColor,lConfirm
   private nLMargin,nRMargin,lWrap,nTopRowMax,cKey1,cKey2,cKey3,nWinWidth, ;
      cConfirm, nWinHgth, nMsgRow
    private cPrompt1,cPrompt2,cPrompt3

    *-- save screen so we can restore ...
   save screen to sYesNoCan
   * 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)

   * program bombs if prompts passed contain leading blanks
   cPrompt1 = ltrim(trim(cPrompt1))
   cPrompt2 = ltrim(trim(cPrompt2))
   cPrompt3 = ltrim(trim(cPrompt3))

   * 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 how high it needs to be
   nWinHgth = iif(""=cMess2,7,8)
   nWinHgth = iif(""=cMess3,nWinHgth-1,nWinHgth)
   * and center it
   define window wYesNoCan from nTopRow,40-(nWinWidth+2)/2 ;
      to nTopRow+nWinHgth-1,40+(nWinWidth+2)/2 double color &cColor.
   define menu mYesNoCan
   define pad pPad1 of mYesNoCan Prompt "["+cPrompt1+"]" ;
      at nWinHgth-3,02
   * center middle prompt between other two, not center of window
   define pad pPad2 of mYesNoCan Prompt "["+cPrompt2+"]" at nWinHgth-3, ;
      ((nWinWidth-len(cPrompt2))/2+(len(cPrompt1)-len(cPrompt3))/2)
   define pad pPad3 of mYesNoCan Prompt "["+cPrompt3+"]"  ;
      at nWinHgth-3,(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

   activate screen
   do shadow with nTopRow,40-(nWinWidth+2)/2,nTopRow+nWinHgth-1, ;
      40+(nWinWidth+2)/2
   activate window wYesNoCan

   do center with 0,nWinWidth,"",cMess1       && center the text
   *-- deal with blank message lines
   nMsgRow = 2
   if "" <> cMess2
      do center with nMsgRow,nWinWidth,"",cMess2
      nMsgRow = nMsgRow + 1
   endif
   if "" <> cMess3
      do center with nMsgRow,nWinWidth,"",cMess3
   endif
   *-- deal with user pressing first key of prompt
   cKey1 = left(cPrompt1,1)
   cKey2 = left(cPrompt2,1)
   cKey3 = left(cPrompt3,1)

   *-- set [CR] at end of keyboard command depending on "confirm" parameter
   cConfirm = iif(lConfirm,"",chr(13))

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

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

PROCEDURE ProgBar2
*-------------------------------------------------------------------------------
*-- Programmer..: Joey D. Carroll (JOEY)
*-- Date........: 10/26/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: 06/28/1992 -- Original
*--               10/26/1992 -- protected existing active window.
*-- 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,wPrevWind
        wPrevWind = window()
      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
        *-- if window was active, re-activate
        if .not. isblank(wPrevWind)
            activate window wPrevWind
        endif
      release nProgBar,nFactor,nTimes,nWindWidth,x,wPrevWind
   endif

RETURN
*-- EoP: PROGBAR2

PROCEDURE MovePad
*-------------------------------------------------------------------------------
*-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
*-- Date........: 07/29/1992
*-- Notes.......: Used to move the selected pad in a dBASE Bar Menu if the user
*--               selects the first letter/key of the pad. The routine doesn't
*--               re-evalute PAD(), and is based on Genifer code (improved on
*--               by Angus). This should be used with the ON KEY command.
*--               NOTE: This routine assumes you are using the dUFLP/dHUNG
*--               standard for naming pads, and that the first character of
*--               each pad NAME is 'p' (i.e., pColor, pExit, etc.).
*-- Written for.: dBASE IV, 1.5, should work in 1.1.
*-- Rev. History: 07/24/1992 -- Original
*--               07/29/1992 -- Added header/notes.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do MovePad with <cLetter>,<lSelect>,<cChoices>
*-- Example.....: on key label "C" do MovePad with "C",.t.,cChoices
*-- Returns.....: None
*-- Parameters..: cLetter  = first letter/key on pad
*--               lSelect  = select pad, or move cursor to it? (Act as if user
*--                          pressed <Enter> after moving to it?)
*--               cChoices = list of possible choices (i.e.,
*--                                 "Enter,Edit,Delete,Print,Exit")
*-------------------------------------------------------------------------------

   parameters cLetter, lSelect, cChoices
   private nToMove

   *-- determine how many pads to move, based on position of choice in list
   *-- of choices (cChoices).
   nToMove = at(cLetter,cChoices) - at(substr(pad(),2,1),cChoices)

   *-- if it is a negative value, move to the left, and press <Enter> if
   *-- lSelect = .t. (otherwise, just move there and stop).
   if nToMove < 0
        keyboard replicate(chr(5), -nToMove) + iif(lSelect,chr(13),"")
    else
        keyboard replicate(chr(24), nToMove) + iif(lSelect,chr(13),"")
    endif

RETURN
*-- EoP: MovePad

PROCEDURE Monitor
*-------------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 06/08/1992
*-- Notes.......: Displays a status message to monitor a long-running
*--                 operation that operates on multiple records . . .
*--                 Should be used with MONITOROFF (below) to cleanup.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/29/1991 - Modified by Ken Mayer to add shadow
*--               06/08/1992 - Modified to handle explicit color setting
*-- Calls.......: SHADOW               Procedure in PROC.PRG
*--               CENTER               Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: do monitor with "<cText>","<cColor>"
*-- Example.....: do monitor with "Processing REPORT.DBF","rg+/gb,rg+/gb,rg+/gb"
*--               nRec = 0
*--               do while  && (or SCAN)
*--                  && stuff -- process records
*--                  nRec = nRec + 1
*--                  @4,30 display ltrim(str(nRec)) && current record
*--                                                 && in window MONITOR
*--               enddo  && (or endscan)
*--               do MonitorOff  && procedure to clean-up after this one
*-- Returns.....: None
*-- Parameters..: cText  = Text to display
*--               cColor = Colors for window
*-------------------------------------------------------------------------------

    parameters cText,cColor
    private cTempCol

    save screen to sMonitor
    activate screen
    define window wMonitor From 10,10 to 18,70 double color &cColor
    do shadow with 10,10,18,70
    activate window wMonitor

    do center with 1,60,"",cText
    do center with 2,60,"","Please do not interrupt"
    @4,10 say "Working on record          of " + ltrim(str(reccount(),5))

RETURN
*-- EoP: Monitor

PROCEDURE MonitorOff
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 05/23/1991
*-- Notes.......: Used to deal with ending routines for MONITOR
*--                 procedure above.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/23/1991 -- Original
*-- Calls.......: None
*-- Called by...: Routine using MONITOR  Procedure in PROC.PRG
*-- Usage.......: do monitoroff
*-- Example.....: do monitoroff
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------

    deactivate window wMonitor
    release window wMonitor
    restore screen from sMonitor
    release screen sMonitor

RETURN
*-- EoP: MonitorOff

FUNCTION NewBorder
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
*-- Date........: 01/20/1993
*-- Notes.......: Will save current border setting (the returned value),
*--               and set a new one with one of a set of pre-defined
*--               borders. This will create a new variable if it doesn't
*--               already exist, called: c_Border, which is a PUBLIC Character
*--               variable. The purpose is so that you can keep using this
*--               string for other purpose (i.e., DEFINE WINDOW and such ...)
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/20/1993 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: NewBorder("<cStyle>")
*-- Example.....: cOldBorder = NewBorder("K")
*--               @5,10 to 15,60  && draw box with new "border" setting
*--               *-- define a window with new "border" setting
*--               define window wTest from 10,20 to 20,60 &c_Border
*--               set border to &cOldBorder  && reset border to original
*-- Returns.....: Current border setting (before calling routine)
*-- Parameters..: cStyle = Style from one of the following:
*--                        A = Double
*--                                     ╔════╗
*--                                     ║    ║
*--                                     ╚════╝
*--                        B = Single
*--                                     ┌────┐
*--                                     │    │
*--                                     └────┘
*--                        C = Panel
*--                                     ██████
*--                                     █    █
*--                                     ██████
*--                        D = None
*--                        E = Double Top, Single Left, Right, and Bottom
*--                                      ╒════╕
*--                                      │    │
*--                                      └────┘
*--                        F = Single Top, Double Left, Right and Bottom
*--                                      ╓────╖
*--                                      ║    ║
*--                                      ╚════╝
*--                        G = Double Top, Left, Right, Single Bottom
*--                                      ╔════╗
*--                                      ║    ║
*--                                      ╙────╜
*--                        H = Single Top, Left, Right, Double Bottom
*--                                      ┌────┐
*--                                      │    │
*--                                      ╘════╛
*--                        I = Double Top, Single Left and Right, Double Bottom
*--                                      ╒════╕
*--                                      │    │
*--                                      ╘════╛
*--                        J = Single Top, Double Left and Right, Single Bottom
*--                                      ╓────╖
*--                                      ║    ║
*--                                      ╙────╜
*--                        K = Single Top and Left, Double Right and Bottom
*--                                      ┌────╖
*--                                      │    ║
*--                                      ╘════╝
*--                        L = Single Top, Double Left, Single Right, Dbl Bottom
*--                                      ╓────┐
*--                                      ║    │
*--                                      ╚════╛
*--                        M = Double Top and Left, Single Right and Bottom
*--                                      ╔════╕
*--                                      ║    │
*--                                      ╙────┘
*--                        N = Double Top, Single Left, Double Right, Sgl Bottom
*--                                      ╒════╗
*--                                      │    ║
*--                                      └────╜
*--                        O = Double Top, Single Left, Double Right and Bottom
*--                                      ╒════╗
*--                                      │    ║
*--                                      ╘════╝
*--                        P = Double Top, Left, Single Right, Double Bottom
*--                                      ╔═════╕
*--                                      ║     │
*--                                      ╚═════╛
*--                        Q = Single Top, Double Left, Single Right and Bottom
*--                                      ╓─────┐
*--                                      ║     │
*--                                      ╙─────┘
*--                        R = Single Top and Left, Double Right, Single Bottom
*--                                      ┌─────╖
*--                                      │     ║
*--                                      └─────╜
*--                        S = Panel, but with more room on the interior ...
*--                            the default 'panel' mode for borders uses
*--                            ASCII 219 (alla way around), where this
*--                            uses 220-223 ...
*--                                      ▐▀▀▀▀▀▌
*--                                      ▐     ▌
*--                                      ▐▄▄▄▄▄▌
*-------------------------------------------------------------------------------

    parameters cStyle
    cReturn = set("BORDER")    && current border -- if version of dBASE is
                               && less than 1.5, comment this out ...

    if type("c_Border") = "U"  && if this is undefined
        public c_Border         &&   declare it as public
    endif

    *-- here we go ...
    do case
        case cStyle = "A"
            c_Border = "DOUBLE"   && pre-defined
        case cStyle = "B"
            c_Border = "SINGLE"   && pre-defined
        case cStyle = "C"
            c_Border = "PANEL"    && pre-defined
        case cStyle = "D"
            c_Border = "NONE"     && pre-defined
        case cStyle = "E"
            *-- items are: top line, bottom line, left line, right line,
            *-- upper left corner, upper right corner, bottom left corner,
            *-- bottom right corner
            c_Border = "205,196,179,179,213,184,192,217"
        case cStyle = "F"
            c_Border = "196,205,186,186,214,183,200,188"
        case cStyle = "G"
            c_Border = "205,196,186,186,201,187,211,189"
        case cStyle = "H"
            c_Border = "196,205,179,179,218,191,212,190"
        case cStyle = "I"
            c_Border = "205,205,179,179,213,184,212,190"
        case cStyle = "J"
            c_Border = "196,196,186,186,214,183,211,189"
        case cStyle = "K"
            c_Border = "196,205,179,186,218,183,212,188"
        case cStyle = "L"
            c_Border = "196,205,186,179,214,191,200,190"
        case cStyle = "M"
            c_Border = "205,196,186,179,201,184,211,217"
        case cStyle = "N"
            c_Border = "205,196,179,186,213,187,192,189"
        case cStyle = "O"
            c_Border = "205,205,179,186,213,187,212,188"
        case cStyle = "P"
            c_Border = "205,205,186,179,201,184,200,190"
        case cStyle = "Q"
            c_Border = "196,196,186,179,214,191,211,217"
        case cStyle = "R"
            c_Border = "196,196,179,186,218,183,192,189"
        case cStyle = "S"
            c_Border = "223,220,222,221,222,221,222,221"
    endcase

    set border to &c_Border

RETURN cReturn
*-- EoF: NewBorder

FUNCTION VidRow
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 01/28/1993
*-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
*--               to return the ABSOLUTE position of the current ROW on the
*--               screen, despite any active windows, etc.
*--               This is based on original routines by David Frankenbach,
*--               but includes the load/release in one routine, rather
*--               than requiring three functions to perform this ...
*--               ***************************
*--               ** REQUIRES VDCURSOR.BIN **
*--               ***************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/28/1993 -- Original
*-- Calls.......: VDCURSOR.BIN
*-- Called by...: Any
*-- Usage.......: VidRow()
*-- Example.....: ?VidRow()
*-- Returns.....: Numeric ROW position for current row on screen
*-- Parameters..: None
*-------------------------------------------------------------------------------

    private cX

    cX = space(2)             && define argument memvar
    load vdcursor             && load the .BIN file
    call vdcursor with cX     && call it with the memvar
    release module vdcursor   && release from memory

RETURN (asc(substr(cX,2))-1) && return the value of the absolute cursor position
*-- EoF: VidRow()

FUNCTION VidCol
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 01/28/1993
*-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
*--               to return the ABSOLUTE position of the current COLUMN on the
*--               screen, despite any active windows, etc.
*--               This is based on original routines by David Frankenbach,
*--               but includes the load/release in one routine, rather
*--               than requiring three functions to perform this ...
*--               ***************************
*--               ** REQUIRES VDCURSOR.BIN **
*--               ***************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/28/1993 -- Original
*-- Calls.......: VDCURSOR.BIN
*-- Called by...: Any
*-- Usage.......: VidCol()
*-- Example.....: ?VidCol()
*-- Returns.....: Numeric COLUMN position for current Col on screen
*-- Parameters..: None
*-------------------------------------------------------------------------------

    private cX

    cX = space(2)             && define argument memvar
    load vdcursor             && load the .BIN file
    call vdcursor with cX     && call it with the memvar
    release module vdcursor   && release from memory

RETURN (asc(substr(cX,1))-1) && return the value of the absolute cursor position
*-- EoF: VidCol()

FUNCTION PwdMask
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer
*-- Date........: 01/29/1993
*-- Notes.......: Designed to display a mask on the screen when a user is
*--               entering a password, rather than a blank surface. Should
*--               handle backspaces to delete ... ASSUMES <cField> is a
*--               memvar.
*--               ***************************
*--               ** REQUIRES VDCURSOR.BIN **
*--               ***************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/29/1993 -- Original
*-- Calls.......: VidRow()             Function in SCREEN.PRG
*--               VidCol()             Function in SCREEN.PRG
*-- Called by...: Any
*-- Usage.......: PwdMask("<cField>"[,<nMaskChar>])
*-- Example.....: @5,10 get password when PwdMask("Password");
*--                      valid required .not. isblank(password);
*--                      error chr(7)+"Password cannot be blank)
*-- Returns.....: .T., and field will have password placed in it when done.
*-- Parameters..: cField    = name of the field
*--               nMaskChar = ASCII code for mask character. OPTIONAL parameter.
*--                           if not provided, will use asterisk. Suggested
*--                           characters include: 176,177,178,219,248,249,254
*--                                                ░   ▒   ▓   █   °   ∙   ■
*-------------------------------------------------------------------------------

    parameters cField, nMaskChar
    private nLength, nChar, nX

    *-- deal with mask character
    if type("NMASKCHAR") = "L"
        nMaskChar = 42               && *
    endif

    lCursor = set("CURSOR") = "ON"
    set cursor off             && rather than have the cursor in the way ...
    nLength = len(&cField.)    && get length of current field
    nChar = 0                  && input character
    nRow = vidrow()            && get absolute cursor location
    nCol = vidcol()            && ditto
    cTemp = ""                 && initialize temp memvar
    do while len(cTemp) < nLength .and. nChar # 13
                               && loop until we hit end of field
                               && or user presses <Enter>

        nChar = inkey(0)        && wait for user to enter something

        do case

            case nChar = 127                    && <BackSpace>
                if isblank(cTemp)                && if empty, don't delete anything
                    ?? chr(7)                     && instead, BEEP
                else
                    cTemp = left(cTemp,len(cTemp)-1)  && backup one
                endif

            case (nChar => 65 .and. nChar <= 90) .or.;
                 (nChar => 97 .and. nChar <= 122) && alphabetic input only
                cTemp = cTemp + chr(nChar)         && add character

            case nChar = 13                       && <Enter>
                exit

            otherwise
                ?? chr(7)                          && otherwise, BEEP
                loop
        endcase

        *-- create the current "mask", padding with spaces ...
        cMask = replicate(chr(nMaskChar),len(cTemp)) + space(nLength-len(cTemp))
        *-- display it in same color as the current "GET"
        @nRow,nCol get cMask
        clear gets
        *-- put password into current memvar
        store cTemp to &cField.

    enddo

    *-- turn cursor on if it was prior to this routine
    if lCursor
        set cursor on
    endif

    keyboard chr(13)   && send a final <Enter> to exit this GET

RETURN .T.
*-- EoF: PwdMask()

PROCEDURE MultiPick
*----------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (JPARSONS)
*-- Date........: 02/06/1993
*-- Notes.......: Permits selecting 0 or more elements of an array.
*--               The array must contain two columns, the first of which
*--               contains the prompt for the row and the second of which
*--               contains logical .T. if the row is selected by default,
*--               or .F.  Array may contain additional columns.
*--                     This is written for programmers, not end users.
*--               It assumes the active window and border style are set before
*--               it is called, and no error handling is provided for
*--               attempts to write outside the current window, impossible
*--               colors, truncation of prompts or other calling errors that
*--               should become evident on testing.
*--
*--               If array contains elements "Hydrangea",.T. and "Tulip",.F.,
*--               initial display after setting a window and calling will be
*--               something like this:
*--
*--                  [ √ ] Hydrangea
*--                  [   ] Tulip
*--
*--               This program will use the mouse if two conditions exist:
*--                   1) The variable nG_MusClic must exist and must hold the
*--               inkey() value of the character "keyboarded" for a click
*--               by the mouse-event handler.  Note that this is often, but
*--               need not be, the same as asc( <character> ).
*--                   2) The mouse must be made active and visible by a
*--               mouse-control .bin such as JPMOUSE.BIN and MUSCLICK.BIN
*--               must be loaded and installed.
*--               *******************************
*--               **** REQUIRES MUSCLICK.BIN ****
*--               ****          JPMOUSE.BIN  ****
*--               ****          VDCURSOR.BIN ****
*--               *******************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/16/93 - original procedure
*--               02/06/93 - revised to use cWnSize, etc.
*--               02/24/93 - parameters changed, functions called moved out
*--               02/28/93 - symbolic constants and support for tab added
*-- Calls.......: SMultPick                 Child procedure to paint screen
*--               Arrayrows()               Function in Array.prg
*--               MUSCLICK.BIN              Binary mouse-event handler
*--               CWnSize()                 Function to find window size
*--               CWnDecode()               Function to decode the above
*--               YnMouse()                 Yesno function for mouse
*--               NormColors()              Function to return normal colors
*--               HighColors()              Function to return highlight colors
*--               ForeColor()               Function to return foreground color
*--
*-- Called by...: Any
*-- Usage.......: DO Multipick WITH <cArray>,<nDown>,<nLast>,<nRows>,<nLength>
*--                                 [, <cColors> [, <cCheck> ] ]
*-- Example.....: DO Multipick WITH "Myarray",3,15,10,18,"RG+/G,N/W",chr(2)
*-- Parameters..: cArray      = Name of the array of selectable items.  See
*--                             Notes, above, for required structure.
*--               nDown       = first useable row of window
*--               nLast       = last useable row of window
*--               nRows       = number of items to show on screen at once
*--               nLength     = maximum length of prompts
*--               cColors     = optional, colors to use for noncurrent
*--                             and current items.  Default is NORMAL and
*--                             HIGHLIGHT colors for the current window.
*--                             Pass default as .F. if cCheck is included.
*--               cCheck      = optional, character to use to show selection.
*--                             Default is "√".  See "cBox" variables in the
*--                             procedure for bracketing characters.
*-- Also uses...: global numeric variable nG_MusClic, giving the inkey()
*--               value of the character "keyboarded" by a mouse click.
*--               If this variable does not exist, mouse support is absent.
*-- Side effects: On return, the values of the second column of the array
*--               are .T. or .F. in accordance with selections made.
*-- Special note: The CWnSize function called by this routine uses
*--               VDCURSOR.BIN, which must be available for this routine
*--               to work, and disables any ON ERROR trap.
*-------------------------------------------------------------------------------

        parameters cArray, nDown, nLast, nRows, nLength, cColors, cCheck
        private cChar, cCols, cNorm, cHigh, nAt, nTop, nKey, cBoxl, cBoxr
        private nElems, lGotMouse, nMTop, nMBot, nMLeft, nMRight, cCols
        private cMrow, cMcol, nMrow, nMcol, cEsc, cWin, nWinTop, nWinLeft
        private nWinBot, nWinRight, nK, cK, cTemp, nX, cQuit, nRo, lOnPicks
        private lOk

        *  These "symbolic constants" are C-style, just to avoid "magic
        *  numbers" scattered throughout the routine.  Of course, they
        *  may also slow it down absent a true compiler
        private NBOXLEN, NEXTRAROWS, NPADLEN, NTWOPADS
        NBOXLEN    =  6         && length of the "[ √ ] " structure
        NEXTRAROWS =  4         && blank row at top, 3 rows for quit pads
        NPADLEN    =  6         && length of the OK and Cancel pads
        NTWOPADS   = 13         && length of two pads and a space between

        * set escape
        cEsc = set("ESCAPE")
        set escape off

        * set delimiter chars
        cBoxl = "[ "
        cBoxr = " ] "

        * set colors if specified
        if type( "cColors" ) = "C"
          cCols = cColors
        else
          cCols = set( "ATTRIBUTES" )
          cCols = left( cCols, at( "&", cCols ) - 2 )
        endif
        cNorm = NormColors( cCols )
        cHigh = HighColors( cCols )
        * set up quit pad colors
        cQuit = cHigh

        * set checkmark char, default is "√" ( chr( 251 ) )
        cChar = iif( type( "cCheck" ) # "L", cCheck, "√" )

        * calculate array rows and set up temporary array for restoration
        nElems = arrayrows( cArray )
        declare cTemp[ nElems ]
        nX = 1
        do while nX <= nElems
          cTemp[ nX ] = &cArray[ nX, 2 ]
          nX = nX + 1
        enddo

        *  find borders of current window and determine centering offset
        cWin = cWnSize()
        if len( cWin ) > 0
          nWinTop   = cWnDecode( cWin, "T" )
          nWinLeft  = cWnDecode( cWin, "L" )
          nWinBot   = cWnDecode( cWin, "B" )
          nWinRight = cWnDecode( cWin, "R" )
        else
          activate screen
          ? "Can't find VDCURSOR.BIN - aborting"
          wait
          cancel
        endif
        nRight = int( ( nWinRight - nWinLeft - NBOXLEN - nLength ) / 2 )
        nCkCol = nRight + 2

        *  we need at least 13 columns for the quit pads, and enough for
        *  the checkbox table itself
        if nWinRight - nWinLeft < max( NTWOPADS, NBOXLEN + nLength )
          activate screen
          ? "Too few columns in this window - aborting"
          wait
          cancel
        endif

        *  determine rows to use if window is small
        nRo = min( nRows, min( nLast - nDown, nWinBot - nWinTop - NEXTRAROWS ) )
        if nRo < 1
          activate screen
          ? "Too few rows in this window - aborting"
          wait
          cancel
        endif

        * test for mouse support and set boundaries of active click area
        * nMx variables represent absolute screen positions of the edges
        * of the checkbox table
        lGotMouse = .F.
        if type( "nG_MusClick" ) = "N"
          lGotMouse = .T.
          nMTop   = nWinTop +  nDown - 1           && row above table
          nMLeft  = nWinLeft + nRight              && left edge of table
          nMBot   = nMTop + nRo + 1                && row below table
          nMRight = nMleft + NBOXLEN + nLength - 1 && right edge
        endif

        * position quit pads ( they are displayed by Smultpick )
        * nLpad and nRpad are column offsets within the active window
        * of the two pads, "  OK  " and "Cancel"
        if NPADLEN + nLength > NTWOPADS
          nLpad = nRight
        else
          nLpad = int( ( nWinRight - nWinLeft ) / 4 ) - ( NPADLEN / 2 )
        endif
        nRpad = nWinRight - nWinLeft - NPADLEN - nLpad

        * initialize display as if "Home" had been pressed
        * nTop is the index into the array of the element to be shown
        *   on the top row of the table
        * nHigh is the index into the array of the element to be shown
        *   highlighted ( the current element )
        * lOnPicks is the "focus"; .T. means we are in the pick table,
        *   not on the quit pads
        nTop = 1
        nHigh = nTop
        keyboard "{Home}"
        lOnPicks = .T.

        * commence main key-handling loop
        do while .T.
          nKey = inkey()
          if nKey = 0
            loop
          endif
          do case
            case nKey = 23      && Ctrl-End
              exit
            case nKey = 27      && Escape
              if YesQuit()
                exit
              endif
            case nKey = 79 .or. nKey = 111   && 'O' or 'o'
              exit
            case nKey = 67 .or. nKey = 99    && 'C' or 'c'
              if YesQuit()
                exit
              endif
            case nKey = 9                    && Tab
              if lOnPicks
                lOk = .T.                    && default tab is "OK"
                @ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
                    cChar, " " ) + cBoxr color &cNorm
                @ row(), col() say left( &cArray.[ nHigh, 1 ] ;
                     + space( nLength ), nLength ) color &cNorm
                @ nLast, nLpad + NPADLEN / 2 say ""
              else
                do SmultPick
              endif
              lOnPicks = .not. lOnPicks
            case lGotMouse .and. nKey = nG_MusClick      && mouse click
              store chr(255) to cMrow, cMcol
              call MUSCLICK with cMrow, cMcol
              nMrow = asc( cMrow )
              nMcol = asc( cMcol )
              if nMrow >= nMTop .and. nMrow <= nMBot .and. ;
                nMcol >= nMLeft .and. nMcol <= nMRight   && in active area
                nAt = nHigh - nTop + nMTop + 1
                do case
                  case nMrow = nAt
                    keyboard chr( 13 )
                  case nMrow = nMTop
                    keyboard "{PgUp}"
                  case nMrow = nMBot
                    keyboard "{PgDn}"
                  case nMrow > nAt
                    do while nAt < nMrow
                      keyboard "{DNARROW}"
                      nAt = nAt + 1
                    enddo
                  case nMrow < nAt
                    do while nAt > nMrow
                      keyboard "{UPARROW}"
                      nAt = nAt - 1
                    enddo
                endcase
              else
                * if it was on a pad
                if nMrow = nWinTop + nLast
                  if nMcol >= nWinLeft + nLpad .and. nMcol < nWinLeft + ;
                      nLpad + NPADLEN
                    keyboard "O"
                    loop
                  endif
                  if nMcol >= nWinLeft + nRpad .and. nMcol < nWinLeft + ;
                      nRpad + NPADLEN
                    keyboard "C"
                    loop
                  endif
                endif
                keyboard "{Esc}"
              endif
            otherwise
              if lOnPicks
                do case
                  case nKey = 26      && Home
                    nTop = 1
                    nHigh = nTop
                    do SMultPick
                  case nKey = 2       && End
                    nTop = nElems - nRo + 1
                    nHigh = nElems
                    do SMultPick
                  case nKey = 24        && down arrow
                    if nHigh = nTop + nRo - 1 .or. nHigh = nElems
                      keyboard "{PgDn}"
                    else
                      @ nHigh - nTop + nDown, nRight say ""
                      @ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
                         cChar, " " ) + cBoxr color &cNorm
                      @ row(), col() say left( &cArray.[ nHigh, 1 ] ;
                         + space( nLength ), nLength ) color &cNorm
                      nHigh = nHigh + 1
                      @ row() + 1, nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
                         cChar, " " ) +cBoxr color &cHigh
                      @ row(), col() say left( &cArray.[ nHigh, 1 ] ;
                         + space( nLength ), nLength ) color &cHigh
                      @ row(), nCkCol say ""
                    endif
                  case nKey = 5         && up arrow
                    if nHigh = nTop
                      keyboard "{PgUp}"
                    else
                      @ nHigh - nTop + nDown, nRight say ""
                      @ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
                         cChar, " " ) + cBoxr color &cNorm
                      @ row(), col() say left( &cArray.[ nHigh, 1 ] ;
                         + space( nLength ), nLength ) color &cNorm
                      nHigh = max( 1, nHigh - 1 )
                      @ row() - 1, nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
                         cChar, " " ) + cBoxr color &cHigh
                      @ row(), col() say left( &cArray.[ nHigh, 1 ] ;
                         + space( nLength ), nLength ) color &cHigh
                      @ row(), nCkCol say ""
                    endif
                  case nKey = 32 .or. nKey = 13  && space and enter are toggles
                    &cArray.[ nHigh, 2 ] = .not. &cArray[ nHigh, 2 ]
                    @ row(), nCkCol say iif( &cArray.[ nHigh, 2], cChar, " " ) ;
                       color &cHigh
                    @ row(), ncKCol say ""
                  case nKey = 3      && PgDn
                    if nHigh = nTop + nRo - 1 .or. nHigh = nElems
                      nTop = min( nHigh, nElems - nRows + 1 )
                      do SmultPick
                    else
                      @ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
                         cChar, " " ) + cBoxr color &cNorm
                      @ row(), col() say left( &cArray.[ nHigh, 1 ] ;
                         + space( nLength ), nLength ) color &cNorm
                      nHigh = nTop + nRo - 1
                      @ nDown + nRo - 1, nRight say ""
                      @ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
                         cChar, " " ) + cBoxr color &cHigh
                      @ row(), col() say left( &cArray.[ nHigh, 1 ] ;
                         + space( nLength ), nLength ) color &cHigh
                      @ row(), nCkCol say ""
                    endif
                  case nKey = 18      && PgUp
                    if nHigh = nTop
                      nTop = max( 1, nHigh - nRo + 1 )
                      do SmultPick
                    else
                      nHigh = nTop
                      @ nDown, nRight say ""
                      @ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
                         cChar, " " ) + cBoxr color &cHigh
                      @ row(), col() say left( &cArray.[ nHigh, 1 ] ;
                         + space( nLength ), nLength ) color &cHigh
                      @ row(), nCkCol say ""
                    endif
                endcase
              else
                do case
                  case nKey = 32 .or. nKey = 4 .or. nKey = 19  && space, r & l
                    lOk = .not. lOk
                    @ nLast, iif( lOk, nLpad, nRpad ) + NPADLEN / 2 say ""
                  case nKey = 13        && and enter quits
                    if lOK
                      keyboard "{CTRL-END}"
                    else
                      keyboard "{ESC}"
                    endif
                endcase
              endif
          endcase
        enddo

        if cEsc ="ON"
          set escape on
        endif
RETURN
*-- EoP: MultiPick

PROCEDURE SMultPick
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (JPARSONS)
*-- Date........: 01/16/1993
*-- Notes.......: Does screen display loop for Multipick procedure.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: Original function 01/16/1993.
*-- Calls.......: None
*-- Called by...: Multipick
*-- Usage.......: DO SMultpick
*-- Parameters..: None, but procedure uses various variables set by the
*--               parent Multipick procedure.
*-------------------------------------------------------------------------------

        private nThisOff, nThisRow, nThisElem, nHiRow, nR
        nThisOff = 0
        nR = min( nRo, nElems - nTop + 1 )
        do while nThisOff < nRo
          nThisRow = nDown + nThisOff
          nThisElem = nTop + nThisOff
          if nThisoff < nR
            if nThisElem = nHigh
              @ nThisRow, nRight say cBoxl + iif( &cArray.[ nThisElem, 2], ;
                cChar, " " ) + cBoxr color &cHigh
              @ nThisRow, col() say left( &cArray.[ nThisElem, 1 ] ;
                + space( nLength ), nLength ) color &cHigh
              nHiRow = nThisRow
            else
              @ nThisRow, nRight say cBoxl + iif( &cArray.[ nThisElem, 2], ;
                cChar, " " ) + cBoxr color &cNorm
              @ nThisRow, col() say left( &cArray.[ nThisElem, 1 ] ;
                + space( nLength ), nLength ) color &cNorm
            endif
          else
            @ nThisRow, nRight say space( nCkCol + len( cBoxr ) + nLength )
          endif
          nThisoff = nThisOff + 1
        enddo
        @ nLast, nLpad say " Done " color &cQuit
        @ nLast, nRpad say "Cancel" color &cQuit
        @ nHiRow, nCkCol say ""
RETURN
*-- EoP: SMultPick

FUNCTION YesQuit
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons       CIS 70160,340
*-- Date........: 02/24/1993
*-- Notes.......: Asks whether to quit and cancel changes; does so if yes.
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/.24/1993 -- Original Release
*-- Calls.......: YnMouse()            Function in SCREENS.PRG
*-- Called by...: Multipick
*-- Usage.......: YesQuit()
*-- Example.....: ? Yesquit()
*-- Parameters..: None
*-- Returns.....: Logical, .T. for "Yes" or .F. for "No"
*-- Side effects: If "Yes", restores cArray[ , 2 ] values from cTemp
*-------------------------------------------------------------------------------
        private nX, lRet
        lRet = YnMouse( "","Do you wish to restore", ;
                    "the original selection","and leave this routine?" )
        if lRet
          nX = 1
          do while nX <= nElems
            &cArray[ nX, 2 ] = cTemp[ nX ]
            nX = nX + 1
          enddo
        endif
RETURN lRet
*-- EoF: YesQuit()

FUNCTION YnMouse
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons       CIS 70160,340
*-- Date........: 02/28/1993
*-- Notes.......: Returns .T. or .F. answer to question without leaving
*--               mouse droppings.  Will not respond to left arrow properly
*--               unless set( "ESCAPE" ) is off.
*--               *******************************
*--               **** REQUIRES MUSCLICK.BIN ****
*--               *******************************
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/23/93 - original function
*--               02/28/93 - revised to support right and left arrows
*-- Calls.......: HighColors()          Function in COLOR.PRG
*--               Center                Procedure in PROC.PRG ( if centering )
*-- Called by...: Any
*-- Usage.......: YnMouse( <cColors>, <cP1> [, <cP2>...] [,<lYes>] )
*-- Example.....: ? YnMouse( "", "Are you sure?" )
*-- Parameters..: cColors   -   String, either blank or holding desired
*--                             colors as standard [ , enhanced [, border ] ]
*--               cP<n>     -   One or more strings of prompt characters.
*--                             < only 7 may be passed as literals using
*--                             dBASE IV 1.5 >.  They will be printed
*--                             one below the other.  There may not in
*--                             any event be more than the number of
*--                             useable screen rows less 6; the parameters
*--                             line will have to be changed to use more
*--                             than 20.
*--                             As furnished, the justification of the
*--                             prompt strings is flush left.  To center
*--                             them, see the commented lines in the code.
*--                             Centering uses the Center procedure in PROC.PRG.
*--               lYes      -   A logical .T. if the default answer is "Yes"
*--                             This must be the last parameter, but it may
*--                             follow any number of prompt lines.
*-- Returns.....: Logical, .T. for "Yes" or .F. for "No"
*-------------------------------------------------------------------------------

        parameters cColors, cP01, cP02, cP03, cP04, cP05, cP06, cP07, cP08,;
                cP09, cP10, cP11, cP12, cP13, cP14, cP15, cP16, cP17, cP18,;
                cP19, cP20, lYes

        private cYn, nX, lY, nParams, nRows, nCols, cWhich, nBot, nTop, nLeft
        private cColrs, cPads, nLpad, nRpad, lRet, nScr

        * obtain number of prompts, and default answer if provided
        nParams = pcount() - 1
        lY = .F.

        * if we have 22 parameters, last must be the default answer
        if nParams = 21
          lY = lYes
        * otherwise look at the last parameter's type--if it is logical
        * that's the default answer and not a prompt
        else
          cWhich = "cP" + right( str( 100 + nParams ), 2 )
          if type( cWhich ) = "L"
            lY = &cWhich
            nParams = nParams - 1
          endif
        endif

        * we need six rows for top and bottom borders, space before prompts,
        * space after prompts, yes/no pads and space after them
        nRows = nParams + 6
        nScr = iif( "43" $ set( "DISPLAY" ), 43, 25 )

        * don't overwrite messages, status or scoreboard
        nBot = nScr - 2
        nTop = 0
        if set( "STATUS" ) = "ON"
          nBot = nBot - 2
        else
          if set( "SCOREBOARD" ) = "ON"
            nTop = 1
          endif
        endif
        if nRows > nBot - nTop
          activate screen
          ? "Too many prompt lines for screen size - aborting"
          wait
          cancel
        endif

        * find longest prompt line and window width it requires including
        * a space at both ends
        nX = 1
        nCols = 13               && 11 spaces for the pads, 2 for border
        do while nX <= nParams
          cWhich = "cP" + right( str( 100 + nX ), 2 )
          nCols = max( nCols, len( trim( &cWhich ) ) + 2 )
          nX = nX + 1
        enddo

        * round up to even number of columns in order to center the window
        nCols = 2 * ceiling( nCols/ 2 )
        if nCols > 80
          activate screen
          ? "Prompts are too long for screen - aborting"
          wait
          cancel
        endif

        * calculate screen row of top and bottom of centered window
        nTop = max( nTop, int( ( nScr - nRows ) / 2 ) )
        nBot = nTop + nRows

        * and screen column of left edge
        nLeft = 39 - nCols / 2

        * obtain colors to use, using highlight for pads
        cColrs = iif( "" # cColors, cColors, set( "ATTRIBUTES" ) )
        if "&" $ cColrs
          cColrs = left( cColrs, at( "&", cColrs ) - 1  )
        endif
        cPads = HighColors( cColrs )

        * calculate column positions of yes/no pads
        nLpad = int( ( nCols - 2 ) / 4 ) - 2
        nRpad = nCols - nLpad - 6

        * now open the window and print prompts
        define window cYn from nTop, nLeft to nBot, nLeft + nCols color &cColrs
        activate window cYn
        nX = 1
        do while nX <= nParams
          cWhich = "cP" + right( str( 100 + nX ), 2 )
*  To change from flush left to centered justification of the prompts,
*  uncomment the next code line and comment out the one following.
*  You will then need the "Center" procedure in PROC.PRG.
*         do Center with nX, nCols, "", &cWhich
          @ nX, 1 say &cWhich
          nX = nX + 1
        enddo

        * print pads
        @ nX + 1, nLpad say " Yes " color &cPads
        @ nX + 1, nRpad say "  No " color &cPads
        @ nX + 1, iif( lY, nLpad, nRpad ) + 2 say ""

        * and begin a loop that may last forever
        clear typeahead
        do while .T.
          nk = inkey()
            if nk = 0
              loop
            endif
            do case
              case nk = 89 .or. nk = 121    && 'Y' or 'y'
                lRet = .T.
                exit
              case nK = 78 .or. nK = 110 .or. nK = 27   && 'N' or 'n' or Esc
                lRet = .F.
                exit
              case nK = 13 .or. nK = 23     && Enter or Ctrl-End
                lRet = lY
                exit
              case nK = 4 .or. nK = 19      && right or left arrow
                lY = .not. lY
                @ nX + 1, iif( lY, nLpad, nRpad ) + 2 say ""
              case type( "nG_MusClic" ) = "N" .and. nk = nG_MusClic
                store chr(255) to cMrow, cMcol
                call MUSCLICK with cMrow, cMcol
                nMrow = asc( cMrow )
                nMcol = asc( cMcol )
                if nMrow = nTop + nX + 2      && one more for border
                  if nMcol >= nLpad + nLeft .and. nMcol < nLpad + nLeft + 5
                    lRet = .T.
                    exit
                  endif
                  if nMcol >= nRpad + nLeft .and. nMcol <nRpad + nLeft + 5
                    lRet = .F.
                    exit
                  endif
                endif
            endcase
          enddo
          deactivate window cYn
          release window cYn

RETURN lRet
*-- EoF: YnMouse()

FUNCTION CWnDecode
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons       CIS 70160,340
*-- Date........: 02/06/1993
*-- Notes.......: Returns the numeric value of one of the four codes for
*--               edges of the window held in a string of the type returned
*--               by cWnSize.  These represent numbers of rows or columns.
*-- Written for.: dBASE IV, Versions 1.0 - 1.5.
*-- Rev. History: 02/06/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: cWnDecode( <cWnString>,<cEdge>|<nPos> )
*-- Example.....: cWinTop = cWnDecode( cWin, "T" )
*-- Parameters..: cWnString -   A string returned by CWnSize
*--               cEdge -       A character parameter beginning with one
*--                             of the four characters "T","L","B",or "R",
*--                             ( upper or lower case ), OR
*--               nPos  -       A number indicating the position in the
*--                             cWnString of the code for the edge.
*--                             These correspond to the following:
*--                             Window edge       cEdge       nPos
*--                               top              T           1
*--                               left             L           2
*--                               bottom           B           3
*--                               right            R           4
*--                             Either cEdge or nPos must be furnished,
*--                             not both.
*-- Returns.....: numeric value of the row or column; -1 for argument
*--               out of range or cWnString holds garbage or is empty.
*-------------------------------------------------------------------------------
        parameters cWnString, xEdge
        private nPos, nRet
        nRet = -1
        if type( "xEdge" ) = "C"
          nPos = at( upper( left( xEdge, 1 ) ), "TLBR" )
        else
          if type( "xEdge" ) = "N"
            nPos = xEdge
          endif
        endif
        if nPos > 0 .and. nPos < 5 .and. len( cWnString ) = 4
          nRet = asc( substr( cWnString, nPos, 1 ) ) - 1
        endif
        if nRet > iif( mod( nPos, 2 ) > 0, 43, 80 )
          nRet = -1
        endif
RETURN nRet
*-- EoF: CWnDecode

FUNCTION CWnSize
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons       CIS 70160,340
*-- Date........: 02/06/1993
*-- Notes.......: Returns a string of four characters which are chr()
*--               values of one more each than the top, left, bottom
*--               and right row and column numbers of the usable surface
*--               of the current window, or of the screen.  ( one more
*--               to avoid chr( 0 ) problems )
*--               Returns "" if unable to find VDCURSOR.BIN
*--               *******************************
*--               **** REQUIRES VDCURSOR.BIN ****
*--               *******************************
*-- Written for.: dBASE IV, Versions 1.0 - 1.5.
*-- Rev. History: 02/06/1993 -- Original Release
*-- Calls.......: nWBsrch()           function included
*-- Called by...: Any
*-- Usage.......: cWnSize()
*-- Example.....: cWin = cWnSize()
*--               WinBot = asc( substr( cWin, 3 1 ) )
*-- Parameters..: None
*-- Returns.....: character string of four chr() values, or "" if error
*-- Side effects: Called function nWBsrch disables any error trap
*-------------------------------------------------------------------------------
        private nHi, nLo, nL, cV

        cV = ""
        if file( "VDCURSOR.BIN" )
          load VDCURSOR
          @ 0,0 say ""
          cV = call( "VDCURSOR","  " )
          release module VDCURSOR
          * reverse bytes so row comes first
          cV = right( cV, 1 ) + left( cV, 1 )
          * this is the first row, and one more than maximum last
          nL = asc( cV ) - 1
          nLo = nL
          nHi = 44
          cV = cV + chr( nL + nWBsrch( nLo, nHi, "Down" ) + 1 )
          * first column and one more than last
          nL = asc( substr( cV, 2, 1 ) ) - 1
          nLo = nL
          nHi = 80
          cV = cV + chr( nL + nWBsrch( nLo, nHi, "Across" ) + 1 )
        endif

RETURN cV
*-- EoF: CWnSize()

FUNCTION nWBsrch
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons       CIS 70160,340
*-- Date........: 02/06/1993
*-- Notes.......: special binary search routine for window edges
*-- Written for.: dBASE IV, Versions 1.0 - 1.5.
*-- Rev. History: 02/06/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: cWnSize
*-- Usage.......: nWBsrch( < nLo >, < nHi >, < cDir > )
*-- Example.....: Lastrow = nWBsrch( 0, 44, "Down" )
*-- Parameters..: nLo           Number, top row or left column
*--               nHi           Number, bottom or right screen edge + 1
*--               cDir          char, direction - "Down" or "Across"
*-- Returns.....: number of highest row or column that may be written to.
*-- Side effects: Disables any ON ERROR trap
*-------------------------------------------------------------------------------
        parameters nLo, nHi, cDir
        private lToohigh, nTry, cD
        cD = upper( left( cDir, 1 ) )
        do while nHi > nLo + 1
          lTooHigh = .F.
          nTry = int( ( nHi + nLo ) / 2 )
          on error lTooHigh = .T.
          if cD $ "DB"
            @ nTry, 0 say ""
          else
            @ 0, nTry say ""
          endif
          if lToohigh
            nHi = nTry - 1
          else
            nLo = nTry
          endif
        enddo
        on error

RETURN nLo
*-- EoF(): nWBsrch

PROCEDURE SetBorder
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
*-- Date........: 03/22/1993
*-- Notes.......: This routine is designed as a front-end for the NEWBORDR
*--               routine. It's purpose is to display a sample of the specific
*--               border from a picklist, and allow the user to select
*--               one ...
*-- Written for.: dBASE IV, 2.0
*-- Rev. History: 03/22/1993
*-- Calls.......: NEWBORDR()           (Function in SCREEN.PRG)
*--               SHADOW               (Procedure in PROC.PRG)
*--               DRAWIT               (Procedure in SCREEN.PRG)
*-- Called by...: Any
*-- Usage.......: Do SetBordr with <cColor>
*-- Example.....: Do SetBordr with cWind1
*-- Returns.....: None
*-- Parameters..: cColor = colors for window ...
*-------------------------------------------------------------------------------

    parameters cColor
    private cWindow,cBorder,cHigh

    *-- start off with a few basics
    save screen to sBorder        && save screen so we can cleanup
    cWindow = window()            && save current window (if any)
    activate screen
    cBorder = set("BORDER")       && save current border setting, in
                                  && case user doesn't select one ...

    *-- define a window ... note that we're using the current default border
    define window wBorder from 5,5 to 15,70 color &cColor.
    do shadow with 5,5,15,70
    activate window wBorder

    cHigh = colorbrk(cColor,2)
    @0,40 fill to 8,60 color &cHigh.
    @0,40 to 8,60 color &cHigh.
    @4,45 say "Test Area" color &cHigh.

    *-- create the popup ...
    define popup pBorders from 0,0
    define bar  1 of pBorders prompt "A) Double"
    define bar  2 of pBorders prompt "B) Single"
    define bar  3 of pBorders prompt "C) Panel (Normal)"
    define bar  4 of pBorders prompt "D) None"
    define bar  5 of pBorders prompt "E) Double Top, Single Rest"
    define bar  6 of pBorders prompt "F) Single Top, Double Rest"
    define bar  7 of pBorders prompt "G) Single Bottom, Double Rest"
    define bar  8 of pBorders prompt "H) Double Bottom, Single Rest"
    define bar  9 of pBorders prompt "I) Double Top/Bottom, Single Rest"
    define bar 10 of pBorders prompt "J) Single Top/Bottom, Double Rest"
    define bar 11 of pBorders prompt "K) Single Top/Left, Double Rest"
    define bar 12 of pBorders prompt "L) Single Top/Right, Double Rest"
    define bar 13 of pBorders prompt "M) Double Top/Left, Single Rest"
    define bar 14 of pBorders prompt "N) Double Top/Right, Single Rest"
    define bar 15 of pBorders prompt "O) Single Left, Double Rest"
    define bar 16 of pBorders prompt "P) Single Right, Double Rest"
    define bar 17 of pBorders prompt "Q) Double Left, Single Rest"
    define bar 18 of pBorders prompt "R) Double Right, Single Rest"
    define bar 19 of pBorders prompt "S) Panel (Thin)"
    on popup pBorders do drawit
    on selection popup pBorders deactivate popup

    *-- Now to play inside the window
    activate popup pBorders

    *-- if user didn't select _anything_, then return to original ...
    if lastkey() = 27 .or. lastkey() = 4 .or. lastkey() = 19
      set border to &cBorder.
      c_Border = cBorder
    endif

    *-- cleanup
    release window wBorder
    release popup pBorders
    restore screen from sBorder
    release screens Border

RETURN
*-- EoP: SetBorder

PROCEDURE DrawIt
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
*-- Date........: 03/22/1993
*-- Notes.......: Used specifically with SETBORDER above, to display the current
*--               selection from the popup.
*-- Written for.: dBASE IV, 2.0
*-- Rev. History: 03/22/1993 -- Original
*-- Calls.......: NewBorder()          Function in SCREEN.PRG
*-- Called by...: SetBorder            Procedure in SCREEN.PRG
*-- Usage.......: Do DrawIt
*-- Example.....: Do DrawIt
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------

    cStyle = left(Prompt(),1)
    x = NewBorder(cStyle)
    if c_Border = "SINGLE"
        set border to single
  endif
    if c_Border = "NONE"
      @0,40 say space(21) color &cHigh.
      @8,40 say space(21) color &cHigh.
      nCounter = 0
      do while nCounter < 8
         nCounter = nCounter + 1
         @nCounter,40 say space(1) color &cHigh.
         @nCounter,60 say space(1) color &cHigh.
      enddo
    else
        @0,40 to 8,60 color &cHigh.
    endif

RETURN
*-- EoP: DrawIt

FUNCTION Wait4Key
*-------------------------------------------------------------------------------
*-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
*--               GeoApplications, Tucson, Arizona
*-- Date........: 03/24/1993
*-- Notes.......: Time-out option for a READ screen.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/24/1993 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: @x,y GET <fieldname> when Wait4Key(<nSeconds>)
*-- Example.....: @10,10 get m->cTest when Wait4Key(5)
*-- Returns.....: logical -- .t. if key pressed within nSeconds, .f. if not.
*-- Parameters..: nSeconds = how long to wait for time-out.
*-------------------------------------------------------------------------------

    parameters nSeconds
    private nDummy, lKeyPressd

    nDummy = inkey(nSeconds)
    if nDummy = 0                    && no keypress
        *-- abort the read
        keyboard chr(27)              && send an <Esc>
        lKeyPressd = .f.
    else
        *-- keyboard the character
        keyboard chr(nDummy)
        lKeyPressd = .t.
    endif

RETURN lKeyPressd
*-- EoF: Wait4Key()

*-------------------------------------------------------------------------------
*--       Library functions included for convenience
*-------------------------------------------------------------------------------

FUNCTION NormColors
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons       CIS 70160,340
*-- Date........: 02/23/1993
*-- Notes.......: Returns the "normal" portion of a color string
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/23/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: NormColors( <cColor> )
*-- Example.....: ? NormColors( "N/BG,BG+/N,W+/B" )
*-- Parameters..: cColor    -   String holding colors
*-- Returns.....: Character, normal color portion of string.
*-------------------------------------------------------------------------------
        parameters cColor
        private cRet
        cRet = cColor
        if "," $ cRet
          cRet = left( cRet, at( ",", cRet ) - 1 )
        endif
RETURN upper( ltrim( trim ( cRet ) ) )
*-- EoF: NormColors()

FUNCTION HighColors
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons       CIS 70160,340
*-- Date........: 02/23/1993
*-- Notes.......: Returns the "highlight" portion of a color string
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/23/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: HighColors( <cColor> )
*-- Example.....: ? HighColors( "N/BG,BG+/N,W+/B" )
*-- Parameters..: cColor    -   String holding colors
*-- Returns.....: Character, highlight color portion of string.
*--               Returns empty string if no such portion.
*-------------------------------------------------------------------------------
        parameters cColor
        private cRet
        cRet = ""
        if "," $ cColor
          cRet = substr( cColor, at( ",",cColor ) + 1 )
          if "," $ cRet
            cRet = left( cRet, at( ",", cRet ) - 1 )
          endif
        endif
RETURN upper( ltrim( trim( cRet ) ) )
*-- EoF: HighColors()

FUNCTION ForeColor
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons       CIS 70160,340
*-- Date........: 02/24/1993
*-- Notes.......: Returns foreground part of color string.
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/24/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ForeColor( <cColor> )
*-- Example.....: ? ForeColor( "N/BG" )
*-- Parameters..: cColor    -   String holding color foreground and background
*-- Returns.....: Character, string with foreground portion of the color
*-------------------------------------------------------------------------------
        parameters cColor
        private cRet
        cRet = upper( trim( ltrim( cColor ) ) )
        if "/" $ cRet
          cRet = left( cRet, at( "/", cRet ) - 1 )
        endif
        if "*" $ cColor
          cRet = cRet + "*"
        endif
        if "+" $ cColor
          cRet = cRet + "+"
        endif

RETURN cRet
*-- EoF: ForeColor()

PROCEDURE Center
*-------------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/24/1991
*-- Notes.......: Centers text on the screen with @says
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: This and all other procedures/functions listed in this
*--               file attributed to Miriam Liskin came from "Liskin's
*--               Programming dBASE IV Book". Very good, worth the money.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
*-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
*--                  Note that the color field may be blank: ""
*-- Returns.....: None
*-- Parameters..: nLine  = Line or Row for @/Say
*--               nWidth = Width of screen
*--               cColor = Colors to be used ("Forg/Back") (may be nul "", in
*--                           order to use the default colors of window/screen)
*--               cText  = Message to center on screen
*-------------------------------------------------------------------------------

    parameters nLine,nWidth,cColor,cText
    private nCol

    nCol = (nWidth - len(cText)) /2
    @nLine,nCol say cText color &cColor.

RETURN
*-- EoP: Center

FUNCTION ArrayRows
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (JPARSONS)
*-- Date........: 03/01/1992
*-- Notes.......: Number of Rows in an array
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ArrayRows("<aArray>")
*-- Example.....: n = ArrayRows("aTest")
*-- Returns.....: numeric
*-- Parameters..: aArray      = Name of array
*-------------------------------------------------------------------------------

    parameters aArray
    private nHi, nLo, nTrial, nDims
    nLo = 1
    nHi = 1170
    if type( "&aArray[ 1, 1 ]" ) = "U"
      nDims = 1
    else
     nDims = 2
    endif
    do while .T.
     nTrial = int( ( nHi + nLo ) / 2 )
      if nHi < nLo
        exit
      endif
     if nDims = 1 .and. type( "&aArray[ nTrial ]" ) = "U" .or. ;
       nDims = 2 .and. type( "&aArray[ nTrial, 1 ]" ) = "U"
        nHi = nTrial - 1
      else
        nLo = nTrial + 1
      endif
    enddo

RETURN nTrial
*-- EoF: ArrayRows()

PROCEDURE ReColor
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (Jparsons)
*-- Date........: 04/23/1992
*-- Notes.......: Restores colors to those held in a string of the form
*--               returned by set("ATTRIBUTE").
*-- Written for.: dBASE IV, Versions 1.0 - 1.5.
*-- Rev. History: 04/23/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DO ReColor WITH <cColors>
*-- Example.....: DO Recolor WITH OldColors
*-- Parameters..: cColors, a string in the form returned by set("ATTRIBUTE").
*-- Returns.....: None
*-- Side effects: Changes the screen colors.
*-------------------------------------------------------------------------------

  parameters cColors
  private cThis, cNext, nAt, cLeft, nX, cAreas
  cAreas = "   NORMHIGHBORDMESSTITLBOX INFOFIEL"
  cLeft = cColors + ", "
  nX = 0
  do while nX < 8
    nX = nX + 1
    cThis = substr( cAreas, 4 * nX, 4 )
    if nX = 3
      nAt = at( "&", cLeft )
      cNext = left( cLeft, nAt - 2 )
      cLeft = substr( cLeft, nAt + 3 )
      SET COLOR TO , , &cNext
    else
      nAt = at( ",", cLeft )
      cNext = left( cLeft, nAt - 1 )
      cLeft = substr( cLeft, nAt + 1 )
      SET COLOR OF &cThis TO &cNext
    endif
  enddo

RETURN
*-- EoP: ReColor

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