* Program -- PROCFILE.PRG             07/20/1990
*            (c) 1990 BERNATH COMPUTER
* PROCFILE - SAMPLE PROCEDURES USING dBtools
*            You may use these procedures freely in your applications.
*            To activate, LOAD DBTOOLS, and SET PROCEDURE TO PROCFILE

* Uses global variables gFG and gBG to set colors of dithered screen
* background.


* --------------------------------------------------------------------
*     ERRMSG - Prints popup box with error message and pauses
*     Syntax:  DO ERRMSG WITH msg
* --------------------------------------------------------------------
PROCEDURE Errmsg
    PARAMETERS Msg
    MSGLEN = LEN(Msg)
    IF MSGLEN < 32
        MSGLEN = 32
    ENDIF
    ULC=40-(MSGLEN/2)-5
    LRC = 40+(MSGLEN/2)+5

    CALL DBTOOLS WITH "2"
    mWINDOW = "21,9,7,"+STR(ULC,2)+",10,"+STR(LRC,2)+",0,14,3,1"
    CALL DBTOOLS WITH mWINDOW
    mPARAM = "1,8,"+STR(ULC+5,2)+",0,14,0,"+TRIM(Msg)
    CALL DBTOOLS WITH mPARAM
    mPARAM="10,9,"+STR(ULC+5,2)+",0,14"
    CALL DBTOOLS WITH mPARAM
    CALL DBTOOLS WITH "19,9"
RETURN


* ---------------------------------------------------------------------
*   NOTAVAIL - Prints popup message if a menu option is not complete
*              (Good for systems under development)
*   Syntax:    DO NOTAVAIL
* ---------------------------------------------------------------------
PROCEDURE NOTAVAIL
    CALL DBTOOLS WITH "2"
    CALL DBTOOLS WITH "21,20,8,20,11,62,0,15,2,1"
    CALL DBTOOLS WITH "1,9,25,0,15,0,This option is not yet available"
    CALL DBTOOLS WITH "10,10,28,0,15"
    CALL DBTOOLS WITH "19,20"
RETURN

* ----------------------------------------------------------------
*   YESNO - prompts for a Y or N answer
*   Syntax:  mYN = " "
*            @ row,col SAY mYN
*            DO YESNO WITH mYN
: -----------------------------------------------------------------
PROCEDURE YESNO
PARAMETERS mYN
    OK = .F.
    mR = ROW()
    mC = COL()
    DO WHILE .NOT. OK
        SET CONFIRM OFF
        SET ESCAPE OFF
        @ mR,mC-1 GET mYN PICTURE "!"
        READ
        SET CONFIRM ON
        IF READKEY() = 12
           DO CLRSTAT WITH gFG,gBG
           CALL DBTOOLS WITH "1,24,0,15,3,0,Do you wish to exit (Y/N)?"
           mYN = " "
           @ 24,28 GET mYN PICTURE "!"
           READ
           IF mYN <> "N"
              EXITNOW = .T.
           ENDIF
           DO CLRSTAT WITH gFG,gBG
        ENDIF

        IF mYN $"YN" .OR. EXITNOW
            OK = .T.
        ELSE
            CALL DBTOOLS WITH "2"
        ENDIF
    ENDDO
    SET ESCAPE ON
    IF mYN=CHR(27)
        EXITNOW = .T.
    ENDIF
RETURN
* ---------------------------------------------------------------------
*  SCRHEAD - screen heading with subtitle
*  Syntax:  DO SCRHEAD WITH maintitle, subtitle, height, box BG
*           Uses global variables gFG and gBG for dither colors
*           and gPRT for name of printer definition file
* ---------------------------------------------------------------------
PROCEDURE SCRHEAD
PARAMETERS mMAINTITL,mSUBTITL,mHEIGHT,mBG
   SET COLOR TO +w/bg
   CALL DBTOOLS WITH "7,2,"+STR(gFG,2)+","+STR(gBG,2)+",0"
   CALL DBTOOLS WITH "3,1,0,"+STR(mHEIGHT+5,2)+",79,15,1,2,0,0"
   IF mHEIGHT > 2
       CALL DBTOOLS WITH "1,5,0,15,1,0,Ì"+REPLICATE("Í",78)+"¹"
   ENDIF
   mL = LEN(mMAINTITL)
   mTAB = 39-(mL/2)
   CALL DBTOOLS WITH "1,2,"+STR(mTAB,2)+",15,1,0,"+mMAINTITL
   mL = LEN(mSUBTITL)
   mTAB=39-(mL/2)
   CALL DBTOOLS WITH "1,S,3,"+STR(mTAB,2)+",15,4,0,"+mSUBTITL
*  If you don't want to deal with printer definition files, comment out
*  the following two lines:
   CALL DBTOOLS WITH "1,2,70,7,1,0,Printer:"
   CALL DBTOOLS WITH "1,3,70,7,1,0,"+TRIM(gPRT)
   RETURN

* ------------------------------------------------------------------------
*   MENUMSG - displays instructions for operating vertical menus
*   Syntax:  DO MENUMSG WITH type, foreground, background
*            where 'type' is 1=letter prompts  2=digit prompts
* ------------------------------------------------------------------------
PROCEDURE MENUMSG
PARAMETERS mT,mFG,mBG
   mPARM = "1,24,13,"+STR(mFG,2)+","+STR(mBG,2)+",0,"
   DO CASE mT
      CASE mT = 1
         mPARM = mPARM + "Press  and ÄÙ, or first letter to select, Esc to Exit"
      CASE mT = 2
         mPARM = mPARM + "Press  and ÄÙ, or first digit to select, Esc to Exit"
   ENDCASE
   CALL DBTOOLS WITH mPARM
RETURN

* ------------------------------------------------------------------------
*   KEYTRAP - Traps ESCAPE key for Exiting, sets variable EXITNOW to .T.
*             Use right after a READ to process ESC key.
*   Syntax:  DO KEYTRAP
*            IF EXITNOW
*               EXIT
*            ENDIF
* ------------------------------------------------------------------------
PROCEDURE KEYTRAP
   IF READKEY() = 12
       mChoice = " "
       DO CLRSTAT WITH gFG,gBG
       CALL DBTOOLS WITH "18"
       CALL DBTOOLS WITH "1,24,0,1,3,0,Do you wish to exit (Y/N)?"
       @ 24,28 SAY " "
       DO YESNO WITH mChoice
       DO CASE
           CASE mChoice = "Y"
               EXITNOW = .T.
           CASE mChoice = "N"
               EXITNOW = .F.
           OTHERWISE
               CALL DBTOOLS WITH "2"
       ENDCASE
       DO CLRSTAT WITH gFG,gBG
   ENDIF
RETURN


* ---------------------------------------------------------------------
*   VALIDKEY - get a key, check against a valid list
*   Syntax:  mKEY = " "
*            @ row, col SAY mKEY
*            DO VALIDKEY WITH mKEY, validkeys
* ---------------------------------------------------------------------
PROCEDURE VALIDKEY
PARAMETERS mVAR,mGOODKEYS
    GOOD = .F.
    mROW = ROW()
    mCOL = COL() - 1
    SET CONFIRM OFF
    DO WHILE .NOT. GOOD
        @ mROW, mCOL GET mVAR PICTURE "!"
        READ
        DO KEYTRAP
        IF EXITNOW
           EXIT
        ENDIF
        IF mVAR $ mGOODKEYS
            GOOD = .T.
        ELSE
            CALL DBTOOLS WITH "2"
        ENDIF
    ENDDO
    SET CONFIRM ON
RETURN

* -----------------------------------------------------------------------
*  PAGEHEAD: Page Heading Routine for Screen or Printer
*            mOUTPUT should be "S" or "P". If "S", fills a screen and
*            pauses, allows you to quit.
*  Syntax:   IF mLINES > mPGLEN
*            DO PAGEHEAD WITH title, report date, page number, output device
* -----------------------------------------------------------------------
PROCEDURE PAGEHEAD
    PARAMETERS mTITLE, mRPTDATE, mPGNUM, mOUTPUT
    mPGNUM = mPGNUM + 1
    mCONT = " "
    DO CASE mOUTPUT
        CASE mOUTPUT = "S"
            IF mPGNUM > 1
                @ 23,0
                WAIT "<Q> to Quit, any other key to continue...." TO mCONT
            ENDIF
            CLEAR
            mLINES = 0
            IF UPPER(mCONT)="Q"
                EXITNOW=.T.
                RETURN
            ENDIF
        CASE mOUTPUT = "P"
            IF mPGNUM >1
                EJECT
            ENDIF
            IF LEN(mTITLE)<37
                SPACEFILL = 37-LEN(mTITLE)
            ELSE
                SPACEFILL = 1
            ENDIF
            IF gWIDE
               mTLEN = 128
            ELSE
               mTLEN = 78
            ENDIF
            ? REPLICATE("Í",mTLEN)
            ?  "  Y O U R   S Y S T E M   T I T L E   G O E S   H E R E"
            ?  SPACE(2) + TRIM(mTITLE) + SPACE(SPACEFILL) + SPACE(10) + DTOC(mRPTDATE) + SPACE(5) + "Page " + STR(mPGNUM,2)
            ? REPLICATE("Í",mTLEN)
            ?
           mLINES = 7
    ENDCASE
RETURN


*------------------------------------------------------------------
* CLRSTAT - blanks the bottom portion of screen to dithered background
* Syntax:  DO CLRSTAT WITH FG, BG
*------------------------------------------------------------------
PROCEDURE CLRSTAT
PARAMETERS mFG,mBG
   mP = STR(mFG,2)+","+STR(mBG,2)+",0,"+REPLICATE("±",80)
   CALL DBTOOLS WITH "1,22,0,"+mP
   CALL DBTOOLS WITH "1,23,0,"+mP
   CALL DBTOOLS WITH "1,24,0,"+mP
RETURN

*--------------------------------------------------------------------
*  ACQ - accept, change, quit horizontal bar menu prompt
*  Syntax:  DO ACQ WITH mCHOICE
*--------------------------------------------------------------------
PROCEDURE ACQ
   PARAMETERS mOPT
   mOPT = 1
   mMENUSTR = "9,"+STR(mOPT,2)+",24,25,15,0,1,3,A)ccept,C)hange,Q)uit,@"
   CALL DBTOOLS WITH mMENUSTR
   mOPT = VAL(mMENUSTR)
   DO CLRSTAT WITH gFG,gBG
RETURN

*-----------------------------------------------------------------------
*  WORDWRAP - allows you to wordwrap on text strings whose field length
*             is greater than the print area. An alternative to using
*             memo fields.
*  Syntax:    DO WORDWRAP WITH mLONGSTR, mLEFTMARG, mRIGHTMARG, mNUMLINES
*             mLONGSTR = the long text string (dBASE can have strings up
*                                              to 255 characters)
*             mLEFTMARG and mRIGHTMARG = the two margins you wish to print
*                                        the text between
*             mNUMLINES = a variable in which will be returned the number
*                         of lines required to print the whole text string.
*-----------------------------------------------------------------------
PROCEDURE WORDWRAP
PARAMETERS mLONGSTR,mLMARGIN,mRMARGIN,mNUMLINES

   PRIVATE mTEMP
   mTEMP = mLONGSTR
   mSTRLEN = LEN(TRIM(mTEMP))
   DO WHILE mSTRLEN > mRMARGIN-mLMARGIN
      mPLACE = mRMARGIN - mLMARGIN
      DO WHILE SUBSTR(mTEMP,mPLACE,1) <> " "
         mPLACE = mPLACE - 1
      ENDDO
      ? SPACE(mLMARGIN)+LTRIM(LEFT(mTEMP,mPLACE-1))
      mTEMP = SUBSTR(mTEMP,mPLACE+1,mSTRLEN-mPLACE)
      mSTRLEN = LEN(TRIM(mTEMP))
      mNUMLINES = mNUMLINES + 1
   ENDDO
   ? SPACE(mLMARGIN) + LTRIM(mTEMP)
   mNUMLINES = mNUMLINES + 1
RETURN

*-------------------------------------------------------------------
*  SELPRT -
*-------------------------------------------------------------------
PROCEDURE SELPRT
PARAMETERS mRESET,mPRT
         OKPRINT = .F.
         DO WHILE .NOT. OKPRINT
            CALL DBTOOLS WITH "7,0,0,3,0"
            mSPEC = gPATH+"*.PRT"
            CALL DBTOOLS WITH "1,S,4,5,15,1,0,Select a file compatible with your printer, or ESC"
            CALL DBTOOLS WITH "1,6,5,0,3,0,(Do not include extension. .PRT assumed.)"
            set color to n/bg,+bg/n,,bg
            @ 6,0
            DIR &mSPEC
            OKPRINT = .F.
            mL=LEN(TRIM(gPRT))
            IF mL<=7
               mPRT = mPRT + SPACE(8-mL)
            ENDIF
            @ 4,57 get mPRT PICTURE "@!"
            READ
            DO KEYTRAP
            IF EXITNOW
               EXIT
            ENDIF
            mPRTFILE = gPATH+TRIM(mPRT)+".PRT"
            IF FILE(mPRTFILE)
               OKPRINT = .T.
               IF mRESET
                  mPARM = "11,0,0,"+mPRTFILE
                  CALL DBTOOLS WITH mPARM
                  IF SUBSTR(mPARM,1) = "0"
                     OKPRINT = .F.
                     CALL DBTOOLS WITH "2"
                  ENDIF
                  gPRT = mPRT
                  gPRTFILE = gPATH+TRIM(gPRT)+".PRT"
               ENDIF
            ELSE
               DO ERRMSG WITH "Printer file does not exist."
            ENDIF
         ENDDO
         IF mRESET
         mNUMCMDS = 0
         mPRTYPE = 0
         mPRNAME = SPACE(36)
         mTYPEDESC = SPACE(20)
         DO GETPRINFO WITH mNUMCMDS,mPRTYPE,mPRNAME,mTYPEDESC
         @ 6,0 CLEAR
         @ 7,10 SAY mPRNAME
         @ 8,10 SAY "Number of commands: "+STR(mNUMCMDS,2)
         @ 9,10 SAY "Printer type: "+mTYPEDESC
         @ 10,10
         WAIT
         ENDIF
RETURN

*------------------------------------------------------------------
*   GETPRINFO - get printer information
*------------------------------------------------------------------
PROCEDURE GETPRINFO
PARAMETERS mNUMCMDS,mPRTYPE,mPRNAME,mTYPEDESC
   mPARM="11,0,1,"+SPACE(31)
   CALL DBTOOLS WITH mPARM
   mNUMCMDS=ASC(SUBSTR(mPARM,1,1))
   mPRTYPE=ASC(SUBSTR(mPARM,2,1))
   mPRNAME=SUBSTR(mPARM,3,36)
         DO CASE mPRTYPE
            CASE mPRTYPE = 0
               mTYPEDESC = "Nonprogrammable"
            CASE mPRTYPE = 1
               mTYPEDESC = "80 col dot matrix"
            CASE mPRTYPE = 2
               mTYPEDESC = "132 col do matrix"
            CASE mPRTYPE = 3
               mTYPEDESC = "Laser/Inkjet"
         ENDCASE
RETURN



*    THE FOLLOWING PROCEDURES ARE FOR THE SAMPLE DATA ENTRY PRGS:
*--------------------------------------------------------------
*  VERACCT - verify account number
*            assumes area B has USE ACCOUNTS INDEX ACCOUNTS
*--------------------------------------------------------------
PROCEDURE VERACCT
PARAMETERS mACCT,mGOODACT
   SELECT B
   SEEK mACCT
   IF FOUND()
      mGOODACT = .T.
   ELSE
      IF mGOODACT
         CALL DBTOOLS WITH "21,20,9,25,13,65,10,0,3,1"
         CALL DBTOOLS WITH "2"
         CALL DBTOOLS WITH "1,10,27,14,0,0,Account "+mACCT+" not found."
         CALL DBTOOLS WITH "1,12,27,10,0,0,Do wish to set it up (Y/N)?"
         mYN = " "
         set color to +g/n,n/g,,n
         @ 12,56 SAY mYN
         DO YESNO WITH mYN
         CALL DBTOOLS WITH "19,20"
         IF mYN = "Y"
            DO SETACCT WITH mACCT,mGOODACT
         ELSE
            mGOODACT = .F.
         ENDIF
      ENDIF
   ENDIF
   set color to n/g,+gr/n,,g
RETURN

*-------------------------------------------------------------------
*  GETACTYPE
*-------------------------------------------------------------------
PROCEDURE GETACTYPE
PARAMETERS mANUM,mATYPE
DO CASE SUBSTR(mANUM,1,1)
   CASE SUBSTR(mANUM,1,1) = "1"
      mATYPE = "A"
   CASE SUBSTR(mANUM,1,1) = "2"
      mATYPE = "L"
   CASE SUBSTR(mANUM,1,1) = "3"
      mATYPE = "C"
   CASE SUBSTR(mANUM,1,1) = "4"
      mATYPE = "I"
   CASE SUBSTR(mANUM,1,1) = "5"
      mATYPE = "E"
ENDCASE
RETURN
*---------------------------------------------------------------------
*  HELPSCR
*----------------------------------------------------------------------
PROCEDURE HELPSCR
DUMMY = INKEY()
? DUMMY
SUSP
IF DUMMY()<> 0
   RETURN
ENDIF
CALL DBTOOLS WITH "21,10,3,5,20,74,15,1,3,1"
CALL DBTOOLS WITH "1,S,4,25,15,4,0,HELP for Accounts Data Entry:"
CALL DBTOOLS WITH "10,19,25,15,1"
CALL DBTOOLS WITH "19,10"
RETURN