Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : DB4LESS3.ZIP
Filename : CUSTOMER.PRG
* Program......: CUSTOMER
* Author.......: Bruce Troutman
* Date.........: 12-04-88
* Notice.......: Type information here or greetings to your users.
* dBASE Ver....: See Application menu to use as sign-on banner.
* Generated by.: APGEN version 1.0
* Description..: Customer Names and Addresses Manager
* Notes........:
********************************************************************************
SET CONSOLE OFF
IF TYPE("gn_apgen") = "U" && We were not called from another APGEN program
CLEAR ALL
CLEAR WINDOW
CLOSE ALL
gn_apgen = 1
ELSE
gn_apgen = gn_apgen + 1
PRIVATE gc_bell, gc_carry, gc_clock, gc_century, gc_confirm, gc_deli,;
gc_escape, gc_instruc, gc_safety, gc_status, gc_score, gc_talk
ENDIF
*-- Window for pause message box (ON ERROR)
DEFINE WINDOW Pause FROM 15,00 TO 19,79 DOUBLE
ON ERROR DO PAUSE WITH [Error occurred on line ]+LTRIM(STR(LINE())) +[ of procedure ]+Program()
ON KEY LABEL F1 DO quickhlp
*-- Store initial SETs to variables
gc_bell =SET("BELL")
gc_carry =SET("CARRY")
gc_clock =SET("CLOCK")
gc_century=SET("CENTURY")
gc_confirm=SET("CONFIRM")
gc_deli =SET("DELIMITERS")
gc_escape =SET("ESCAPE")
gc_instruc=SET("INSTRUCT")
gc_safety =SET("SAFETY")
gc_status =SET("STATUS")
gc_score =SET("SCOREBOARD")
gc_talk =SET("TALK")
SET CLOCK OFF
SET COLOR TO
CLEAR
SET CONSOLE ON
*-- Sets for application
SET BELL ON
SET CARRY OFF
SET CENTURY OFF
SET CONFIRM OFF
SET DELIMITERS TO ""
SET DELIMITER OFF
SET ESCAPE ON
***SET INSTRUCT OFF ** remove for RunTime
SET SAFETY ON
SET SCOREBOARD OFF
SET STATUS OFF
SET TALK OFF
*-- Set global variables
gn_barv = 0 && Initialize bar value variable
gn_error = 0 && Variable to store error() number
gn_send = 0 && Return variable from popup
gc_brdr = "2" && Border style for menu box - See Procedure
lc_heading = "Customer File Manager" && Menu heading string
ll_color = ISCOLOR()
CLEAR
SET ESCAPE ON
SET STATUS ON
*-- Set colors
IF ll_color
SET COLOR OF NORMAL TO w+/b
SET COLOR OF MESSAGES TO w+/n
SET COLOR OF TITLES TO w/b
SET COLOR OF HIGHLIGHT TO b/w
SET COLOR OF BOX TO b/w
SET COLOR OF INFORMATION TO b/w
SET COLOR OF FIELDS TO b/w
ENDIF
USE CUSTOMER INDEX CUSTOMER
SET ORDER TO CUSTNAME
*-- Define the main popup menu for Quickapp
SET BORDER TO DOUBLE
DEFINE POPUP quick FROM 7,27
DEFINE BAR 1 OF quick PROMPT " Add Information" MESSAGE "Add records to database CUSTOMER"
DEFINE BAR 2 OF quick PROMPT " Change Information" MESSAGE "Edit records in database CUSTOMER"
DEFINE BAR 3 OF quick PROMPT " Browse Information" MESSAGE "Browse database CUSTOMER"
DEFINE BAR 4 OF quick PROMPT " Discard Marked Records " MESSAGE "Purge deleted records in database CUSTOMER"
DEFINE BAR 5 OF quick PROMPT " Print Report" MESSAGE "Run report form CUSTOMER"
DEFINE BAR 6 OF quick PROMPT " Mailing Labels" MESSAGE "Run label form CUSTOMER"
DEFINE BAR 7 OF quick PROMPT " Reindex Database" MESSAGE "Reindex database CUSTOMER"
DEFINE BAR 8 OF quick PROMPT " Exit From Customer" MESSAGE "Exit program to dBASE"
ON SELECTION POPUP quick DO Action WITH BAR()
*-- Define the popup menu for print redirection
DEFINE POPUP prntchk FROM 10,55
DEFINE BAR 1 OF prntchk PROMPT " Send to..." SKIP
DEFINE BAR 2 OF prntchk PROMPT REPLICATE(CHR(196),14) SKIP
DEFINE BAR 3 OF prntchk PROMPT " Screen " MESSAGE "Screen only"
DEFINE BAR 4 OF prntchk PROMPT " Printer " MESSAGE "Printer LPT1:"
DEFINE BAR 5 OF prntchk PROMPT " Label Sample " MESSAGE "Printer LPT1: with Sample label" SKIP FOR gn_barv <> 6
DEFINE BAR 6 OF prntchk PROMPT " Return" MESSAGE "Return to Main Menu"
ON SELECTION POPUP prntchk DO get_sele
*-- Window to cover work surface during edit, append, etc.
DEFINE WINDOW work FROM 0,0 TO 21,79 NONE
*-- Window for area below menu heading & for running reports/labels in
DEFINE WINDOW desktop FROM 4,0 TO 21,79 NONE
DEFINE WINDOW printemp FROM 10,25 TO 15,56
*-- Display heading centered on the screen.
DO menubox WITH lc_heading
*-- Show the menu so we don't get a flash if the user hits arrow keys or ESC
SHOW POPUP quick
SAVE SCREEN TO quick
*-- Display Quickapp menu centered on the screen.
DO WHILE gn_barv <> 8 && Prevent user from exiting with arrow keys or ESC
ACTIVATE POPUP quick
ENDDO
* Restore SET environment the best we can
SET BELL &gc_bell.
SET CARRY &gc_carry.
SET CLOCK TO
SET CLOCK &gc_clock.
SET CENTURY &gc_century.
SET CONFIRM &gc_confirm.
SET DELIMITERS &gc_deli.
SET ESCAPE &gc_escape.
*** SET INSTRUCT &gc_instruc. ** Remove for RunTime
SET STATUS &gc_status.
SET SAFETY &gc_safety.
SET SCORE &gc_score.
SET TALK &gc_talk.
SET FORMAT TO
IF gn_apgen = 1 && We were not called from another APGEN program
CLEAR WINDOW
CLEAR POPUP
CLEAR ALL
CLOSE ALL
ELSE
RELEASE WINDOWS work, desktop
RELEASE SCREEN quick
RELEASE POPUP quick
gn_apgen = gn_apgen - 1
ENDIF
ON ERROR
ON KEY LABEL F1
RETURN
* EOP: CUSTOMER.PRG
********************************************************************************
* Procedures...: CUSTOMER.Prc
* Author.......: Bruce Troutman
* Date.........: 12-04-88
* Notice.......: Type information here or greetings to your users.
* dBASE Ver....: See Application menu to use as sign-on banner.
* Generated by.: APGEN version 1.0
* Description..: Customer Names and Addresses Manager
* Notes........:
********************************************************************************
*-- Here is a sample procedure file to show the power of procdures.
*-- This example - Menubox displays a menu heading box with a centered heading.
PROCEDURE MenuBox
PARAMETER lc_m_name
*-- Parameter lc_m_name - is the title variable for the menu
SET CLOCK OFF
@ 1,0 FILL TO 2,79 COLOR n/n
DO CASE
CASE gc_brdr = "0"
@ 1,0 CLEAR TO 3,79
CASE gc_brdr = "1"
@ 1,0 TO 3,79
CASE gc_brdr = "2"
lc_color = IIF(ISCOLOR(),"b/w", "W+/N")
@ 1,0 TO 3,79 DOUBLE COLOR &lc_color.
ENDCASE
SET CLOCK TO 2,68
@ 2,1 SAY SUBSTR(CDOW(DATE()),1,3)+'. '+DTOC(DATE())+' '
@ 2,41 - (LEN(lc_m_name)/2) SAY lc_m_name
lc_color = IIF(ISCOLOR(),"w+/b", "W+/N")
@ 2,1 FILL TO 2,78 COLOR &lc_color.
RETURN
PROCEDURE get_sele
*-- Get the user selection & store BAR into variable
gn_send = BAR() && Variable for print testing
DEACTIVATE POPUP
RETURN
PROCEDURE Action
PARAMETERS bar
*-- Get the user selection & store BAR into variable
gn_barv = bar
SET MESSAGE TO
IF LTRIM( STR( gn_barv)) $ "123"
*-- Set format file CUSTOMER for edit/append/browse
SET FORMAT TO CUSTOMER
ENDIF
DO CASE
CASE gn_barv = 1
*-- Add information
SET MESSAGE TO 'Appending records to file CUSTOMER'
APPEND
CASE gn_barv = 2
*-- Change information
SET MESSAGE TO 'Editing file CUSTOMER'
EDIT
CASE gn_barv = 3
*-- Browse information
SET MESSAGE TO 'Browsing file CUSTOMER'
BROWSE FORMAT
CASE gn_barv = 4
*-- Remove information (Pack file customer)
ACTIVATE WINDOW desktop
@ 2,0 SAY "Packing database CUSTOMER to REMOVE records marked for deletion..."
@ 3,0
SET TALK ON
PACK
GO TOP
?
WAIT
SET TALK OFF
DEACTIVATE WINDOW desktop
CASE gn_barv = 5
*-- Run report form customer
SET MESSAGE TO 'Pick an option to locate a record or
ACTIVATE WINDOW work
gn_recno = RECNO()
DO position
DEACTIVATE WINDOW work
lc_toprnt = IIF(gn_recno <> recno(),'REST ','')
STORE 0 TO gn_send, gn_pkey
ACTIVATE POPUP prntchk
IF gn_send = 4
lc_toprnt = 'TO PRINT'
ON ERROR DO prntrtry
ENDIF
IF .NOT. gn_send = 6
SET MESSAGE TO 'Printing report CUSTOMER'
ACTIVATE WINDOW desktop
SET ESCAPE ON
REPORT FORM CUSTOMER &lc_toprnt.
IF gn_pkey <> 27
WAIT
ENDIF
SET ESCAPE ON
DEACTIVATE WINDOW desktop
ENDIF
GOTO gn_recno
ON ERROR DO PAUSE WITH [Error occurred on line ]+LTRIM(STR(LINE())) +[ of procedure ]+Program()
CASE gn_barv = 6
*-- Run label form customer
SET MESSAGE TO 'Pick an option to locate a record or
ACTIVATE WINDOW work
gn_recno = RECNO()
DO position
DEACTIVATE WINDOW work
STORE 0 TO gn_send, gn_pkey
lc_toprnt = IIF(gn_recno <> recno(),'REST ','')
ACTIVATE POPUP prntchk
DO CASE
CASE gn_send = 4
lc_toprnt = 'TO PRINT'
CASE gn_send = 5
lc_toprnt = 'TO PRINT SAMPLE'
ENDCASE
IF .NOT. gn_send = 6
SET MESSAGE TO 'Printing labels'
ACTIVATE WINDOW desktop
SET ESCAPE ON
ON ERROR DO prntrtry
LABEL FORM CUSTOMER &lc_toprnt.
IF gn_pkey <> 27
WAIT
ENDIF
SET ESCAPE ON
DEACTIVATE WINDOW desktop
ENDIF
GOTO gn_recno
ON ERROR DO PAUSE WITH [Error occurred on line ]+LTRIM(STR(LINE())) +[ of procedure ]+Program()
CASE gn_barv = 7
*-- Reindex customer
ACTIVATE WINDOW desktop
@ 3,0 SAY "Reindexing database CUSTOMER..."
@ 4,0
SET TALK ON
REINDEX
GO TOP
?
WAIT
SET TALK OFF
DEACTIVATE WINDOW desktop
CASE gn_barv = 8
DEACTIVATE POPUP
ENDCASE
SET MESSAGE TO
IF gc_status = "OFF"
SET STATUS ON
ENDIF
SET FORMAT TO
RESTORE SCREEN FROM quick
RETURN
PROCEDURE Pause
PARAMETER lc_msg
*-- Parameters : lc_msg = message line
IF TYPE("lc_message")="U"
gn_error=ERROR()
ENDIF
lc_msg = lc_msg
lc_option='0'
ACTIVATE WINDOW Pause
IF gn_error > 0
IF TYPE("lc_message")="U"
@ 0,1 SAY [An error has occurred !! - Error message: ]+MESSAGE()
ELSE
@ 0,1 SAY [Error # ]+lc_message
ENDIF
ENDIF
@ 1,1 SAY lc_msg
WAIT " Press any key to continue..."
DEACTIVATE WINDOW Pause
RETURN
PROCEDURE quickhlp
*-- If you want to include help for a quickapp uncomment the lines below and
*-- put your help @ say's into the case statements
*ACTIVATE WINDOW desktop
*CLEAR
DO CASE
CASE BAR() = 1
CASE BAR() = 2
CASE BAR() = 3
CASE BAR() = 4
CASE BAR() = 5
CASE BAR() = 6
CASE BAR() = 7
CASE BAR() = 8
ENDCASE
*WAIT
*DEACTIVATE WINDOW desktop
RETURN
PROCEDURE Position
IF LEN(DBF()) = 0
DO Pause WITH "Database not in use. "
RETURN
ENDIF
SET SPACE ON
SET DELIMITERS OFF
ln_type=0 && sublevel selection
ln_rkey=READKEY() && test for ESC or Return
ln_rec=RECNO() && DBF record number
ln_num=0 && for input of a number
ld_date=DATE() && for input of a date
lc_option='0' && main option ie. Seek, Goto and Locate
*-- Scope ie. ALL, REST, NEXT
STORE SPACE(10) TO lc_scp
*-- 1 = Character SEEK, 2 = For clause, 3 = While clause
STORE SPACE(40) TO lc_ln1, lc_ln2, lc_ln3
lc_temp=""
@ 0,00 SAY "Index order: "+IIF(""=ORDER(),"Database is in natural order",ORDER())
@ 1,00 SAY "Listed below are the first 16 fields."
lc_temp=REPLICATE(CHR(196),19)
@ 2,0 SAY CHR(218)+lc_temp+CHR(194)+lc_temp+CHR(194)+lc_temp+CHR(194)+lc_temp
ln_num=240
DO WHILE ln_num < 560
lc_temp=FIELD( (ln_num-240)/20 +1)
@ (ln_num/80),MOD(ln_num,80) SAY CHR(179)+;
lc_temp+SPACE(11-LEN(lc_temp))+;
SUBSTR("= Char = Date = Logic = Num = Float = Memo ",;
AT(TYPE(lc_temp),"CDLNFMU")*8-7,8)
ln_num=ln_num+20
ENDDO
ln_num=1
DEFINE POPUP Posit1 FROM 8,30
DEFINE BAR 1 OF Posit1 PROMPT " Position by " SKIP
DEFINE BAR 2 OF Posit1 PROMPT REPLICATE(CHR(196),15) SKIP
DEFINE BAR 3 OF Posit1 PROMPT " SEEK Record" MESSAGE "Search on index key" SKIP FOR ""=ORDER()
DEFINE BAR 4 OF Posit1 PROMPT " GOTO Record" MESSAGE "Position to specific record"
DEFINE BAR 5 OF Posit1 PROMPT " LOCATE Record " MESSAGE "Locate record for condition"
DEFINE BAR 6 OF Posit1 PROMPT " Return" MESSAGE "Return without positioning"
ON SELECTION POPUP Posit1 DO get_sele
SET CONFIRM ON
DO WHILE lc_option='0'
ACTIVATE POPUP Posit1
lc_option = ltrim(str(gn_send)) && for popup
IF LASTKEY() = 27 .OR. lc_option="6"
GOTO ln_rec
EXIT
ENDIF
DO CASE
CASE lc_option='3'
*-- Seek
IF LEN(NDX(1))=0 .AND. LEN(MDX(1))=0
DO Pause WITH "Can't use this option - No index files are open."
LOOP
ENDIF
ln_type=1
lc_ln1=SPACE(40)
DEFINE WINDOW Posit2 FROM 8,19 TO 15,62 DOUBLE
ACTIVATE WINDOW Posit2
@ 1,1 SAY "Enter the type of expression:" GET ln_type PICT "#" RANGE 1,3
@ 2,1 SAY "(1=character, 2=numeric and 3=date.)"
READ
IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
SET CONFIRM ON
@ 3,1 SAY "Enter the key expression to search for:"
IF ln_type=3
@ 4,1 GET ld_date PICT "@D"
ELSE
IF ln_type=2
@ 4,1 GET ln_num PICT "##########"
ELSE
@ 4,1 GET lc_ln1
ENDIF
ENDIF
READ
SET CONFIRM OFF
IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
lc_temp=IIF(ln_type=1,"TRIM(lc_ln1)",IIF(ln_type=2,"ln_num","ld_date"))
SEEK &lc_temp.
ENDIF
ENDIF
RELEASE WINDOWS Posit2
CASE lc_option='4'
*-- Goto
ln_type=1
DEFINE POPUP Posit2 FROM 8,30
DEFINE BAR 1 OF Posit2 PROMPT " GOTO:" SKIP
DEFINE BAR 2 OF Posit2 PROMPT REPLICATE(CHR(196),10) SKIP
DEFINE BAR 3 OF Posit2 PROMPT " TOP" MESSAGE "GOTO Top of File"
DEFINE BAR 4 OF Posit2 PROMPT " BOTTOM" MESSAGE "GOTO Bottom of File"
DEFINE BAR 5 OF Posit2 PROMPT " Record # " MESSAGE "GOTO A Specific Record"
ON SELECTION POPUP Posit2 DO get_sele
ACTIVATE POPUP posit2
ln_type = gn_send
IF LASTKEY() <> 27
IF ln_type=5
DEFINE WINDOW Posit2 FROM 8,26 TO 13,50 DOUBLE
ACTIVATE WINDOW Posit2
ln_num=0
@ 3,1 SAY "Max. Record # = "+LTRIM(STR(RECCOUNT()))
@ 1,1 SAY "Record to GOTO" GET ln_num PICT "######" RANGE 1,RECCOUNT()
READ
IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
GOTO ln_num
ENDIF
RELEASE WINDOWS Posit2
ELSE
lc_temp=IIF(ln_type=3,"TOP","BOTTOM")
GOTO &lc_temp.
ENDIF
ENDIF
CASE lc_option='5'
*-- Locate
DEFINE WINDOW Posit2 FROM 8,16 TO 14,66 DOUBLE
ACTIVATE WINDOW Posit2
@ 1,19 SAY "ie. ALL, NEXT
@ 1,01 SAY "Scope:" GET lc_scp
@ 2,01 SAY "For: " GET lc_ln2
@ 3,01 SAY "While:" GET lc_ln3
READ
IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
lc_temp=TRIM(lc_scp)
lc_temp=lc_temp + IIF(LEN(TRIM(lc_ln2)) > 0," FOR "+TRIM(lc_ln2),"")
lc_temp=lc_temp + IIF(LEN(TRIM(lc_ln3)) > 0," WHILE "+TRIM(lc_ln3),"")
IF LEN(lc_temp) > 0
LOCATE &lc_temp.
ELSE
DO Pause WITH "All fields were blank."
ENDIF
ENDIF
RELEASE WINDOW Posit2
ENDCASE
IF EOF()
DO Pause WITH "Record not found."
GOTO ln_rec
ENDIF
IF READKEY()=12 .OR. READKEY()= 268 .OR. LASTKEY()=27 && Esc was hit
lc_option='0'
ENDIF
ENDDO
SET DELIMITERS &gc_deli.
SET CONFIRM OFF
RETURN
PROC prntrtry
PRIVATE lc_escape
lc_escape = SET("ESCAPE")
IF .NOT. PRINTSTATUS()
IF lc_escape = "ON"
SET ESCAPE OFF
ENDIF
gn_pkey = 0
ACTIVATE WINDOW printemp
@ 1,0 SAY "Please ready your printer or"
@ 2,0 SAY " press ESC to cancel"
DO WHILE ( .NOT. PRINTSTATUS()) .AND. gn_pkey <> 27
gn_pkey = INKEY()
ENDDO
DEACTIVATE WINDOW printemp
SET ESCAPE &lc_escape
IF gn_pkey <> 27
RETRY
ENDIF
ENDIF
RETURN
* EOF: CUSTOMER.PRG
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/