home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / DATABASE / DBT123S.ZIP / PROCFILE.PRG < prev    next >
Text File  |  1990-07-20  |  15KB  |  438 lines
  1. * Program -- PROCFILE.PRG             07/20/1990
  2. *            (c) 1990 BERNATH COMPUTER
  3. * PROCFILE - SAMPLE PROCEDURES USING dBtools
  4. *            You may use these procedures freely in your applications.
  5. *            To activate, LOAD DBTOOLS, and SET PROCEDURE TO PROCFILE
  6.  
  7. * Uses global variables gFG and gBG to set colors of dithered screen
  8. * background.
  9.  
  10.  
  11. * --------------------------------------------------------------------
  12. *     ERRMSG - Prints popup box with error message and pauses
  13. *     Syntax:  DO ERRMSG WITH msg
  14. * --------------------------------------------------------------------
  15. PROCEDURE Errmsg
  16.     PARAMETERS Msg
  17.     MSGLEN = LEN(Msg)
  18.     IF MSGLEN < 32
  19.         MSGLEN = 32
  20.     ENDIF
  21.     ULC=40-(MSGLEN/2)-5
  22.     LRC = 40+(MSGLEN/2)+5
  23.  
  24.     CALL DBTOOLS WITH "2"
  25.     mWINDOW = "21,9,7,"+STR(ULC,2)+",10,"+STR(LRC,2)+",0,14,3,1"
  26.     CALL DBTOOLS WITH mWINDOW
  27.     mPARAM = "1,8,"+STR(ULC+5,2)+",0,14,0,"+TRIM(Msg)
  28.     CALL DBTOOLS WITH mPARAM
  29.     mPARAM="10,9,"+STR(ULC+5,2)+",0,14"
  30.     CALL DBTOOLS WITH mPARAM
  31.     CALL DBTOOLS WITH "19,9"
  32. RETURN
  33.  
  34.  
  35. * ---------------------------------------------------------------------
  36. *   NOTAVAIL - Prints popup message if a menu option is not complete
  37. *              (Good for systems under development)
  38. *   Syntax:    DO NOTAVAIL
  39. * ---------------------------------------------------------------------
  40. PROCEDURE NOTAVAIL
  41.     CALL DBTOOLS WITH "2"
  42.     CALL DBTOOLS WITH "21,20,8,20,11,62,0,15,2,1"
  43.     CALL DBTOOLS WITH "1,9,25,0,15,0,This option is not yet available"
  44.     CALL DBTOOLS WITH "10,10,28,0,15"
  45.     CALL DBTOOLS WITH "19,20"
  46. RETURN
  47.  
  48. * ----------------------------------------------------------------
  49. *   YESNO - prompts for a Y or N answer
  50. *   Syntax:  mYN = " "
  51. *            @ row,col SAY mYN
  52. *            DO YESNO WITH mYN
  53. : -----------------------------------------------------------------
  54. PROCEDURE YESNO
  55. PARAMETERS mYN
  56.     OK = .F.
  57.     mR = ROW()
  58.     mC = COL()
  59.     DO WHILE .NOT. OK
  60.         SET CONFIRM OFF
  61.         SET ESCAPE OFF
  62.         @ mR,mC-1 GET mYN PICTURE "!"
  63.         READ
  64.         SET CONFIRM ON
  65.         IF READKEY() = 12
  66.            DO CLRSTAT WITH gFG,gBG
  67.            CALL DBTOOLS WITH "1,24,0,15,3,0,Do you wish to exit (Y/N)?"
  68.            mYN = " "
  69.            @ 24,28 GET mYN PICTURE "!"
  70.            READ
  71.            IF mYN <> "N"
  72.               EXITNOW = .T.
  73.            ENDIF
  74.            DO CLRSTAT WITH gFG,gBG
  75.         ENDIF
  76.  
  77.         IF mYN $"YN" .OR. EXITNOW
  78.             OK = .T.
  79.         ELSE
  80.             CALL DBTOOLS WITH "2"
  81.         ENDIF
  82.     ENDDO
  83.     SET ESCAPE ON
  84.     IF mYN=CHR(27)
  85.         EXITNOW = .T.
  86.     ENDIF
  87. RETURN
  88. * ---------------------------------------------------------------------
  89. *  SCRHEAD - screen heading with subtitle
  90. *  Syntax:  DO SCRHEAD WITH maintitle, subtitle, height, box BG
  91. *           Uses global variables gFG and gBG for dither colors
  92. *           and gPRT for name of printer definition file
  93. * ---------------------------------------------------------------------
  94. PROCEDURE SCRHEAD
  95. PARAMETERS mMAINTITL,mSUBTITL,mHEIGHT,mBG
  96.    SET COLOR TO +w/bg
  97.    CALL DBTOOLS WITH "7,2,"+STR(gFG,2)+","+STR(gBG,2)+",0"
  98.    CALL DBTOOLS WITH "3,1,0,"+STR(mHEIGHT+5,2)+",79,15,1,2,0,0"
  99.    IF mHEIGHT > 2
  100.        CALL DBTOOLS WITH "1,5,0,15,1,0,╠"+REPLICATE("═",78)+"╣"
  101.    ENDIF
  102.    mL = LEN(mMAINTITL)
  103.    mTAB = 39-(mL/2)
  104.    CALL DBTOOLS WITH "1,2,"+STR(mTAB,2)+",15,1,0,"+mMAINTITL
  105.    mL = LEN(mSUBTITL)
  106.    mTAB=39-(mL/2)
  107.    CALL DBTOOLS WITH "1,S,3,"+STR(mTAB,2)+",15,4,0,"+mSUBTITL
  108. *  If you don't want to deal with printer definition files, comment out
  109. *  the following two lines:
  110.    CALL DBTOOLS WITH "1,2,70,7,1,0,Printer:"
  111.    CALL DBTOOLS WITH "1,3,70,7,1,0,"+TRIM(gPRT)
  112.    RETURN
  113.  
  114. * ------------------------------------------------------------------------
  115. *   MENUMSG - displays instructions for operating vertical menus
  116. *   Syntax:  DO MENUMSG WITH type, foreground, background
  117. *            where 'type' is 1=letter prompts  2=digit prompts
  118. * ------------------------------------------------------------------------
  119. PROCEDURE MENUMSG
  120. PARAMETERS mT,mFG,mBG
  121.    mPARM = "1,24,13,"+STR(mFG,2)+","+STR(mBG,2)+",0,"
  122.    DO CASE mT
  123.       CASE mT = 1
  124.          mPARM = mPARM + "Press  and ─┘, or first letter to select, Esc to Exit"
  125.       CASE mT = 2
  126.          mPARM = mPARM + "Press  and ─┘, or first digit to select, Esc to Exit"
  127.    ENDCASE
  128.    CALL DBTOOLS WITH mPARM
  129. RETURN
  130.  
  131. * ------------------------------------------------------------------------
  132. *   KEYTRAP - Traps ESCAPE key for Exiting, sets variable EXITNOW to .T.
  133. *             Use right after a READ to process ESC key.
  134. *   Syntax:  DO KEYTRAP
  135. *            IF EXITNOW
  136. *               EXIT
  137. *            ENDIF
  138. * ------------------------------------------------------------------------
  139. PROCEDURE KEYTRAP
  140.    IF READKEY() = 12
  141.        mChoice = " "
  142.        DO CLRSTAT WITH gFG,gBG
  143.        CALL DBTOOLS WITH "18"
  144.        CALL DBTOOLS WITH "1,24,0,1,3,0,Do you wish to exit (Y/N)?"
  145.        @ 24,28 SAY " "
  146.        DO YESNO WITH mChoice
  147.        DO CASE
  148.            CASE mChoice = "Y"
  149.                EXITNOW = .T.
  150.            CASE mChoice = "N"
  151.                EXITNOW = .F.
  152.            OTHERWISE
  153.                CALL DBTOOLS WITH "2"
  154.        ENDCASE
  155.        DO CLRSTAT WITH gFG,gBG
  156.    ENDIF
  157. RETURN
  158.  
  159.  
  160. * ---------------------------------------------------------------------
  161. *   VALIDKEY - get a key, check against a valid list
  162. *   Syntax:  mKEY = " "
  163. *            @ row, col SAY mKEY
  164. *            DO VALIDKEY WITH mKEY, validkeys
  165. * ---------------------------------------------------------------------
  166. PROCEDURE VALIDKEY
  167. PARAMETERS mVAR,mGOODKEYS
  168.     GOOD = .F.
  169.     mROW = ROW()
  170.     mCOL = COL() - 1
  171.     SET CONFIRM OFF
  172.     DO WHILE .NOT. GOOD
  173.         @ mROW, mCOL GET mVAR PICTURE "!"
  174.         READ
  175.         DO KEYTRAP
  176.         IF EXITNOW
  177.            EXIT
  178.         ENDIF
  179.         IF mVAR $ mGOODKEYS
  180.             GOOD = .T.
  181.         ELSE
  182.             CALL DBTOOLS WITH "2"
  183.         ENDIF
  184.     ENDDO
  185.     SET CONFIRM ON
  186. RETURN
  187.  
  188. * -----------------------------------------------------------------------
  189. *  PAGEHEAD: Page Heading Routine for Screen or Printer
  190. *            mOUTPUT should be "S" or "P". If "S", fills a screen and
  191. *            pauses, allows you to quit.
  192. *  Syntax:   IF mLINES > mPGLEN
  193. *            DO PAGEHEAD WITH title, report date, page number, output device
  194. * -----------------------------------------------------------------------
  195. PROCEDURE PAGEHEAD
  196.     PARAMETERS mTITLE, mRPTDATE, mPGNUM, mOUTPUT
  197.     mPGNUM = mPGNUM + 1
  198.     mCONT = " "
  199.     DO CASE mOUTPUT
  200.         CASE mOUTPUT = "S"
  201.             IF mPGNUM > 1
  202.                 @ 23,0
  203.                 WAIT "<Q> to Quit, any other key to continue...." TO mCONT
  204.             ENDIF
  205.             CLEAR
  206.             mLINES = 0
  207.             IF UPPER(mCONT)="Q"
  208.                 EXITNOW=.T.
  209.                 RETURN
  210.             ENDIF
  211.         CASE mOUTPUT = "P"
  212.             IF mPGNUM >1
  213.                 EJECT
  214.             ENDIF
  215.             IF LEN(mTITLE)<37
  216.                 SPACEFILL = 37-LEN(mTITLE)
  217.             ELSE
  218.                 SPACEFILL = 1
  219.             ENDIF
  220.             IF gWIDE
  221.                mTLEN = 128
  222.             ELSE
  223.                mTLEN = 78
  224.             ENDIF
  225.             ? REPLICATE("═",mTLEN)
  226.             ?  "  Y O U R   S Y S T E M   T I T L E   G O E S   H E R E"
  227.             ?  SPACE(2) + TRIM(mTITLE) + SPACE(SPACEFILL) + SPACE(10) + DTOC(mRPTDATE) + SPACE(5) + "Page " + STR(mPGNUM,2)
  228.             ? REPLICATE("═",mTLEN)
  229.             ?
  230.            mLINES = 7
  231.     ENDCASE
  232. RETURN
  233.  
  234.  
  235. *------------------------------------------------------------------
  236. * CLRSTAT - blanks the bottom portion of screen to dithered background
  237. * Syntax:  DO CLRSTAT WITH FG, BG
  238. *------------------------------------------------------------------
  239. PROCEDURE CLRSTAT
  240. PARAMETERS mFG,mBG
  241.    mP = STR(mFG,2)+","+STR(mBG,2)+",0,"+REPLICATE("▒",80)
  242.    CALL DBTOOLS WITH "1,22,0,"+mP
  243.    CALL DBTOOLS WITH "1,23,0,"+mP
  244.    CALL DBTOOLS WITH "1,24,0,"+mP
  245. RETURN
  246.  
  247. *--------------------------------------------------------------------
  248. *  ACQ - accept, change, quit horizontal bar menu prompt
  249. *  Syntax:  DO ACQ WITH mCHOICE
  250. *--------------------------------------------------------------------
  251. PROCEDURE ACQ
  252.    PARAMETERS mOPT
  253.    mOPT = 1
  254.    mMENUSTR = "9,"+STR(mOPT,2)+",24,25,15,0,1,3,A)ccept,C)hange,Q)uit,@"
  255.    CALL DBTOOLS WITH mMENUSTR
  256.    mOPT = VAL(mMENUSTR)
  257.    DO CLRSTAT WITH gFG,gBG
  258. RETURN
  259.  
  260. *-----------------------------------------------------------------------
  261. *  WORDWRAP - allows you to wordwrap on text strings whose field length
  262. *             is greater than the print area. An alternative to using
  263. *             memo fields.
  264. *  Syntax:    DO WORDWRAP WITH mLONGSTR, mLEFTMARG, mRIGHTMARG, mNUMLINES
  265. *             mLONGSTR = the long text string (dBASE can have strings up
  266. *                                              to 255 characters)
  267. *             mLEFTMARG and mRIGHTMARG = the two margins you wish to print
  268. *                                        the text between
  269. *             mNUMLINES = a variable in which will be returned the number
  270. *                         of lines required to print the whole text string.
  271. *-----------------------------------------------------------------------
  272. PROCEDURE WORDWRAP
  273. PARAMETERS mLONGSTR,mLMARGIN,mRMARGIN,mNUMLINES
  274.  
  275.    PRIVATE mTEMP
  276.    mTEMP = mLONGSTR
  277.    mSTRLEN = LEN(TRIM(mTEMP))
  278.    DO WHILE mSTRLEN > mRMARGIN-mLMARGIN
  279.       mPLACE = mRMARGIN - mLMARGIN
  280.       DO WHILE SUBSTR(mTEMP,mPLACE,1) <> " "
  281.          mPLACE = mPLACE - 1
  282.       ENDDO
  283.       ? SPACE(mLMARGIN)+LTRIM(LEFT(mTEMP,mPLACE-1))
  284.       mTEMP = SUBSTR(mTEMP,mPLACE+1,mSTRLEN-mPLACE)
  285.       mSTRLEN = LEN(TRIM(mTEMP))
  286.       mNUMLINES = mNUMLINES + 1
  287.    ENDDO
  288.    ? SPACE(mLMARGIN) + LTRIM(mTEMP)
  289.    mNUMLINES = mNUMLINES + 1
  290. RETURN
  291.  
  292. *-------------------------------------------------------------------
  293. *  SELPRT -
  294. *-------------------------------------------------------------------
  295. PROCEDURE SELPRT
  296. PARAMETERS mRESET,mPRT
  297.          OKPRINT = .F.
  298.          DO WHILE .NOT. OKPRINT
  299.             CALL DBTOOLS WITH "7,0,0,3,0"
  300.             mSPEC = gPATH+"*.PRT"
  301.             CALL DBTOOLS WITH "1,S,4,5,15,1,0,Select a file compatible with your printer, or ESC"
  302.             CALL DBTOOLS WITH "1,6,5,0,3,0,(Do not include extension. .PRT assumed.)"
  303.             set color to n/bg,+bg/n,,bg
  304.             @ 6,0
  305.             DIR &mSPEC
  306.             OKPRINT = .F.
  307.             mL=LEN(TRIM(gPRT))
  308.             IF mL<=7
  309.                mPRT = mPRT + SPACE(8-mL)
  310.             ENDIF
  311.             @ 4,57 get mPRT PICTURE "@!"
  312.             READ
  313.             DO KEYTRAP
  314.             IF EXITNOW
  315.                EXIT
  316.             ENDIF
  317.             mPRTFILE = gPATH+TRIM(mPRT)+".PRT"
  318.             IF FILE(mPRTFILE)
  319.                OKPRINT = .T.
  320.                IF mRESET
  321.                   mPARM = "11,0,0,"+mPRTFILE
  322.                   CALL DBTOOLS WITH mPARM
  323.                   IF SUBSTR(mPARM,1) = "0"
  324.                      OKPRINT = .F.
  325.                      CALL DBTOOLS WITH "2"
  326.                   ENDIF
  327.                   gPRT = mPRT
  328.                   gPRTFILE = gPATH+TRIM(gPRT)+".PRT"
  329.                ENDIF
  330.             ELSE
  331.                DO ERRMSG WITH "Printer file does not exist."
  332.             ENDIF
  333.          ENDDO
  334.          IF mRESET
  335.          mNUMCMDS = 0
  336.          mPRTYPE = 0
  337.          mPRNAME = SPACE(36)
  338.          mTYPEDESC = SPACE(20)
  339.          DO GETPRINFO WITH mNUMCMDS,mPRTYPE,mPRNAME,mTYPEDESC
  340.          @ 6,0 CLEAR
  341.          @ 7,10 SAY mPRNAME
  342.          @ 8,10 SAY "Number of commands: "+STR(mNUMCMDS,2)
  343.          @ 9,10 SAY "Printer type: "+mTYPEDESC
  344.          @ 10,10
  345.          WAIT
  346.          ENDIF
  347. RETURN
  348.  
  349. *------------------------------------------------------------------
  350. *   GETPRINFO - get printer information
  351. *------------------------------------------------------------------
  352. PROCEDURE GETPRINFO
  353. PARAMETERS mNUMCMDS,mPRTYPE,mPRNAME,mTYPEDESC
  354.    mPARM="11,0,1,"+SPACE(31)
  355.    CALL DBTOOLS WITH mPARM
  356.    mNUMCMDS=ASC(SUBSTR(mPARM,1,1))
  357.    mPRTYPE=ASC(SUBSTR(mPARM,2,1))
  358.    mPRNAME=SUBSTR(mPARM,3,36)
  359.          DO CASE mPRTYPE
  360.             CASE mPRTYPE = 0
  361.                mTYPEDESC = "Nonprogrammable"
  362.             CASE mPRTYPE = 1
  363.                mTYPEDESC = "80 col dot matrix"
  364.             CASE mPRTYPE = 2
  365.                mTYPEDESC = "132 col do matrix"
  366.             CASE mPRTYPE = 3
  367.                mTYPEDESC = "Laser/Inkjet"
  368.          ENDCASE
  369. RETURN
  370.  
  371.  
  372.  
  373. *    THE FOLLOWING PROCEDURES ARE FOR THE SAMPLE DATA ENTRY PRGS:
  374. *--------------------------------------------------------------
  375. *  VERACCT - verify account number
  376. *            assumes area B has USE ACCOUNTS INDEX ACCOUNTS
  377. *--------------------------------------------------------------
  378. PROCEDURE VERACCT
  379. PARAMETERS mACCT,mGOODACT
  380.    SELECT B
  381.    SEEK mACCT
  382.    IF FOUND()
  383.       mGOODACT = .T.
  384.    ELSE
  385.       IF mGOODACT
  386.          CALL DBTOOLS WITH "21,20,9,25,13,65,10,0,3,1"
  387.          CALL DBTOOLS WITH "2"
  388.          CALL DBTOOLS WITH "1,10,27,14,0,0,Account "+mACCT+" not found."
  389.          CALL DBTOOLS WITH "1,12,27,10,0,0,Do wish to set it up (Y/N)?"
  390.          mYN = " "
  391.          set color to +g/n,n/g,,n
  392.          @ 12,56 SAY mYN
  393.          DO YESNO WITH mYN
  394.          CALL DBTOOLS WITH "19,20"
  395.          IF mYN = "Y"
  396.             DO SETACCT WITH mACCT,mGOODACT
  397.          ELSE
  398.             mGOODACT = .F.
  399.          ENDIF
  400.       ENDIF
  401.    ENDIF
  402.    set color to n/g,+gr/n,,g
  403. RETURN
  404.  
  405. *-------------------------------------------------------------------
  406. *  GETACTYPE
  407. *-------------------------------------------------------------------
  408. PROCEDURE GETACTYPE
  409. PARAMETERS mANUM,mATYPE
  410. DO CASE SUBSTR(mANUM,1,1)
  411.    CASE SUBSTR(mANUM,1,1) = "1"
  412.       mATYPE = "A"
  413.    CASE SUBSTR(mANUM,1,1) = "2"
  414.       mATYPE = "L"
  415.    CASE SUBSTR(mANUM,1,1) = "3"
  416.       mATYPE = "C"
  417.    CASE SUBSTR(mANUM,1,1) = "4"
  418.       mATYPE = "I"
  419.    CASE SUBSTR(mANUM,1,1) = "5"
  420.       mATYPE = "E"
  421. ENDCASE
  422. RETURN
  423. *---------------------------------------------------------------------
  424. *  HELPSCR
  425. *----------------------------------------------------------------------
  426. PROCEDURE HELPSCR
  427. DUMMY = INKEY()
  428. ? DUMMY
  429. SUSP
  430. IF DUMMY()<> 0
  431.    RETURN
  432. ENDIF
  433. CALL DBTOOLS WITH "21,10,3,5,20,74,15,1,3,1"
  434. CALL DBTOOLS WITH "1,S,4,25,15,4,0,HELP for Accounts Data Entry:"
  435. CALL DBTOOLS WITH "10,19,25,15,1"
  436. CALL DBTOOLS WITH "19,10"
  437. RETURN
  438.