Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : DBT123S.ZIP
Filename : PROCDEMO.PRG
* PROCDEMO.PRG - demo for PROCFILE procedures using dBTOOLS
* (c) 1990 BERNATH COMPUTER
* 07/20/1990
* =====================================================================
SET BELL OFF
SET STATUS OFF
SET TALK OFF
SET ECHO OFF
SET COLOR TO W/N,N/W,,N
PUBLIC gFG,gBG,gPATH,gNUMOPT,gSYSTITL,gPRT
* Extract environment information
gPATH = GETENV("DBTOOLS")
IF LEN(gPATH) = 0
gPATH = SPACE(48)
CLEAR
@ 5,0 SAY "Path for PROCFILE demo files and DBTOOLS.BIN: "
@ 6,0 GET gPATH PICTURE "@!"
READ
gPATH = TRIM(gPATH)
ENDIF
SET PATH TO &gPATH
mEXP = gPATH+"\DBTOOLS" && Load dBTools
LOAD &mEXP
CALL DBTOOLS WITH "23,0" && blink off
CALL DBTOOLS WITH "24,1,6/38" && brown-->orange
mEXP = gPATH+"\PROCFILE"
SET PROCEDURE TO &mEXP && Load procedure file
gPRT = GETENV("DBTPRT")
gSYSTITL = "d B T o o l s P R O C E D U R E D E M O"
EXITNOW = .F.
ABORT = .F.
gFG = 0
gBG = 7
m_CHOICE = 1
DO WHILE .T.
DO SCRHEAD WITH gSYSTITL,"Main Menu",12,1
DO MENUMSG WITH 1,0,7
mMENUSTR="20,Y,"+STR(m_CHOICE,2)+",0,7,20,14,55,0,3,1,1,11,0,2,"
mMENUSTR=mMENUSTR+"Error Message,Not Available,Data Entry Example,Fun with Boxes,YesNo and Getkey,Quit,@"
CALL DBTOOLS WITH mMENUSTR
m_CHOICE = VAL(mMENUSTR)
DO CASE
CASE m_CHOICE = 1
DO ERRMSG WITH "This is an example error message."
CASE m_CHOICE = 2
DO NOTAVAIL
CASE m_CHOICE = 3
DO SCRHEAD WITH "SAMPLE DATA ENTRY PROGRAM","Introduction",0,1
CALL DBTOOLS WITH "3,6,5,19,73,14,2,2,0,1"
CALL DBTOOLS WITH "1,S,7,23,10,1,0,Accounting Data Entry Example"
SET COLOR TO N/G
@ 9,8 SAY "This is some sample code from part of an accounting application"
@ 10,8 say "I wrote. This particular module maintains the Chart of Accounts."
@ 12,8 say "Trying printing the Chart of Accounts first, and then edit a few"
@ 13,8 say "of the existing accounts. Note how a validation is done on the"
@ 14,8 say "Parent account (ie, it must already exist). Add a few accounts."
@ 15,8 say "Take a look at the code, and see how dBTools can turn your dBASE"
@ 16,8 say "applications from drab to flashy!"
m_VAR = "10,Y,18,20,14,2,ESC to exit, any other key to continue..."
CALL DBTOOLS WITH m_VAR
IF ASC(m_VAR)-1 <> 27 && extract scancode
DO ACCTMENU
ENDIF
CASE m_CHOICE = 4 && Box fun
CALL DBTOOLS WITH "15,1"
CALL DBTOOLS WITH "13,0,0,24,79,8,0"
mKEY = 0
mULR=8
mULC=25
DO WHILE mKEY<>27 && end loop on ESC
* setup window
mPARM="21,9,"+STR(mULR,2)+","+STR(mULC,2)+","+STR(mULR+5,2)+","+STR(mULC+40,2)+",15,4,1,1"
CALL DBTOOLS WITH mPARM
* print message
CALL DBTOOLS WITH "1,"+STR(mULR+1,2)+","+STR(mULC+2,2)+",7,4,0,Move the box with the arrow keys"
* use PAUSE to trap direction keys
m_VAR="10,Y,"+STR(mULR+4,2)+","+STR(mULC+2,2)+",15,4,Press <--> Home End PgUp PgDn ESC"
CALL DBTOOLS WITH m_VAR
mKEY = ASC(m_VAR)-1
mSCAN= ASC(SUBSTR(m_VAR,2,1))-1
DO CASE
CASE mSCAN = 75 && west
mULC = mULC - 1
IF mULC < 0
? CHR(7)
mULC = 0
ENDIF
CASE mSCAN = 77 && east
mULC = mULC + 1
IF mULC > 39
? CHR(7)
mULC = 39
ENDIF
CASE mSCAN = 80 && south
mULR = mULR + 1
IF mULR > 18
? CHR(7)
mULR = 18
ENDIF
CASE mSCAN = 72 && north
mULR = mULR - 1
IF mULR < 0
? CHR(7)
mULR = 0
ENDIF
CASE mSCAN = 71 && home
mULR = 0
mULC = 0
CASE mSCAN = 79 && end
mULC = 39
mULR = 18
CASE mSCAN = 73 && PgUp
mULR = 0
CASE mSCAN = 81 && PgDn
mULR = 18
OTHERWISE
?? CHR(7)
ENDCASE
CALL DBTOOLS WITH "19,9" && unpop window
ENDDO && loop back
CASE m_CHOICE = 5
CALL DBTOOLS WITH "13,0,0,24,79,8,0"
CALL DBTOOLS WITH "3,9,22,17,65,14,6,5,0,0"
CALL DBTOOLS WITH "1,10,33,14,6,0,YesNo and Validkey example"
CALL DBTOOLS WITH "1,11,38,14,6,0,(ESC to quit)"
CALL DBTOOLS WITH "1,12,25,15,6,0,You're monitor is about to turn into"
CALL DBTOOLS WITH "1,13,25,15,6,0,a heap of molten slag."
CALL DBTOOLS WITH "1,14,30,14,6,0,Do you wish to continue (Y/N)?"
mYN = " "
@ 14,61 SAY mYN
DO YESNO WITH mYN
CALL DBTOOLS WITH "5,12,23,14,64,6"
CALL DBTOOLS WITH "1,12,25,15,6,0,LEGAL KEYS: D B T O L S"
CALL DBTOOLS WITH "1,14,25,14,6,0,Press a key:"
DO WHILE mYN<>"Q"
mYN = " "
gFG=8
gBG=0
@ 14,39 SAY mYN
DO VALIDKEY WITH mYN,"DBTOLS"
IF EXITNOW .OR. mYN = "Q"
EXIT
ELSE
CALL DBTOOLS WITH "1,15,39,0,6,0,"+mYN+" Valid"
ENDIF
ENDDO
gFG = 0
gBG = 7
CASE m_CHOICE = 6 .OR. m_CHOICE = 0
ABORT = .T.
CASE m_CHOICE = 99
mKEY = ASC(SUBSTR(mMENUSTR,4,1))-1
mSCAN = ASC(SUBSTR(mMENUSTR,5,1))-1
m_CHOICE = ASC(SUBSTR(mMENUSTR,6,1))
ENDCASE
IF ABORT
EXIT
ENDIF
ENDDO
CALL DBTOOLS WITH "23,1"
QUIT
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/