Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : BROWZE.ZIP
Filename : BROWZE.PRG

 
Output of file : BROWZE.PRG contained in archive : BROWZE.ZIP
*:**************************************************************
*: Program: browze.PRG
*: System: Browse Pick List Sample
* Original concept and design by:
*: Author: Y. Alan Griver
*: Copyright (c) 1990, Flash Creative Management, Inc.
* Major enhancements by Yisroel Goodman
* Copyright (c) 1991, Complete Computer Services, Inc.
* changes include:
* using indexed and non-indexed files
* using numeric, date or character search fields
* instructions
* ability to trap ESC and add records
* numeric searches from left (7 will find 7,70-79,700-799)
* tracks search key field length and allows change in search value
* variable number of fields browsed, multiple databases
* display of search key and active field being located
* locate on any field in the active database
* optional display of calculated values during browse
* multiple records selected with one call to browze
*:**************************************************************
*
PARAMETERS TITL,FEELDS,selrec
* titl is title of browse window
* feelds is the list of fields to browse and headings
* below parameters are checked and defaults set
if type("selrec")="U" && when selecting multiple records
store .f. to selrec && a .t. is passed as 3rd parameter
else
if selrec
store feelds+",sel=iif(selected,'û',' ') :h='û'" to feelds
endif
endif
store "" to theloc && .t. if there is a locate scope active
if type("srchkey")="U"
* .t. if limiting records to a key field with a specific value.
* For example, if browsing invoices belonging to a specific account.
store .f. to srchkey
endif
if srchkey=.f.
store .t. to multfld
* if the record shown in the browse are not limited to those with a
* specific key value, any field can be located. Otherwise, only the
* first field can be located (multfld=.f.).
store "" to keyfld && this would be the key field value
else
store .f. to multfld
endif
do_key = .F.
DEFINE WINDOW INSTRUCT FROM 1,1 TO 4,78 TITLE "INSTRUCTIONS" COLOR SCHEME 1
* Sometimes when the user presses ESC during the browse routine, he wants
* to add a record rather than select an existing one. This occurs during
* programs where it is logical to want to do this, such as when browsing
* clients in order to select one for invoicing (the user may want to add a
* new client). If such is the case, initialize a variable called addrecrd
* to .t. in the calling program. The default is .f., because most of the
* time the user is only reviewing existing information.
IF TYPE("ADDRECRD")<>"L"
store .f. to addrecrd
endif
* Most of the time, the first field of the browsed file is a key to an
* indexed file, so we set indx to .t. If the file is not being used
* with an index, initialize this variable to .f. in the calling program.
if type("indx") <> "L"
store .t. to indx
endif
if type("clrset")="U"
store 17 to clrset && each new browze screen should have a new color
endif
store fld1 to thefld && thefld contains the name of the active field
DO INSTRUCT && place instructions on the screen before starting
* The program should know the length of the search key. If the user
* enters 6 characters for a 5-character field, the program assumes
* that the user changed his mind and that the 6th character is the
* first of a new search value. The program uses a default of 6 for
* numeric field lengths. Fld1 is the first browse field. We can use
* the LEN function to find its length if it is character.
if type(fld1)="C"
store len(&fld1) to fldlen
else
if type(fld1)="D"
store 8 to fldlen
else
if type("fldlen")<>"N"
store 6 to fldlen
endif
endif
endif
store fldlen to thelen && this is the length of the active field
* Searches should match on close approximations.
set near on
store "" to theseek
DEFINE WINDOW LBM FROM 24,2 TO 24,78 NONE COLOR SCHEME 7
if .not. wexist("browpop")
* the program can be called with the browse window already defined
define window browpop from 5,1 to 21,78 title titl system nozoom ;
nogrow nofloat SHADOW color scheme clrset
STORE CLRSET+1 TO CLRSET
IF CLRSET > 23
STORE 17 TO CLRSET
ENDIF
endif
DO Bbrow && initializes the keys which can be used in the browse
do lbm
Do_key = .T. && toggles keys on
if srchkey && browse should be limited to specific index value
browse fields &feelds key keyfld window browpop nomodify
else
BROWSE FIELDS &FEELDS window browpop NOMODIFY
endif
ON KEY && turns keys off
set near off && future searches must be exact
CLEAR windows
store .f. to srchkey, selrec && reset for future calls to browze
RETURN

PROCEDURE Bbrow
*) Reconfigure the keyboard for a POPUP Window using Browse
if selrec && multiple records can be selected
ON KEY LABEL F2 do gettheke with "F2"
endif
ON KEY LABEL F5 do gettheke with "F5"
ON KEY LABEL F10 DO CANCELKEY && routine to recover from error
ON KEY LABEL Enter DO Gettheke WITH 'Enter'
ON KEY LABEL Rightmouse DO Gettheke WITH 'Enter'
ON KEY LABEL Leftmouse do gettheke with 'Enter'
ON KEY LABEL Home DO Gettheke WITH 'Home'
ON KEY LABEL END DO Gettheke WITH 'End'
ON KEY LABEL Backspace DO Gettheke WITH 'Backspace'
ON KEY LABEL Spacebar DO Gettheke WITH ' '
ON KEY LABEL ',' DO Gettheke WITH ','
ON KEY LABEL '.' DO Gettheke WITH '.'
ON KEY LABEL A DO Gettheke WITH 'A'
ON KEY LABEL B DO Gettheke WITH 'B'
ON KEY LABEL C DO Gettheke WITH 'C'
ON KEY LABEL D DO Gettheke WITH 'D'
ON KEY LABEL E DO Gettheke WITH 'E'
ON KEY LABEL F DO Gettheke WITH 'F'
ON KEY LABEL G DO Gettheke WITH 'G'
ON KEY LABEL H DO Gettheke WITH 'H'
ON KEY LABEL I DO Gettheke WITH 'I'
ON KEY LABEL J DO Gettheke WITH 'J'
ON KEY LABEL K DO Gettheke WITH 'K'
ON KEY LABEL L DO Gettheke WITH 'L'
ON KEY LABEL M DO Gettheke WITH 'M'
ON KEY LABEL N DO Gettheke WITH 'N'
ON KEY LABEL O DO Gettheke WITH 'O'
ON KEY LABEL P DO Gettheke WITH 'P'
ON KEY LABEL Q DO Gettheke WITH 'Q'
ON KEY LABEL R DO Gettheke WITH 'R'
ON KEY LABEL S DO Gettheke WITH 'S'
ON KEY LABEL T DO Gettheke WITH 'T'
ON KEY LABEL U DO Gettheke WITH 'U'
ON KEY LABEL V DO Gettheke WITH 'V'
ON KEY LABEL W DO Gettheke WITH 'W'
ON KEY LABEL X DO Gettheke WITH 'X'
ON KEY LABEL Y DO Gettheke WITH 'Y'
ON KEY LABEL Z DO Gettheke WITH 'Z'
on key label - do gettheke with "-"
ON key label 1 do gettheke with '1'
on key label 2 do gettheke with '2'
on key label 3 do gettheke with '3'
on key label 4 do gettheke with '4'
on key label 5 do gettheke with '5'
on key label 6 do gettheke with '6'
on key label 7 do gettheke with '7'
on key label 8 do gettheke with '8'
on key label 9 do gettheke with '9'
on key label 0 do gettheke with '0'
RETURN && return to calling program

PROCEDURE GETTHEKE
PARAMETERS Thekey
IF Do_key
Do_key = .F. && disable keys while entry is being evaluated
DO Bldseek WITH Thekey
ENDIF (Do_key)
Do_key = .T. && enable keys
RETURN

PROCEDURE BLDSEEK
* acts on the key hit during a popup browse window
PARAMETERS Kkey && The key hit
* if the active field has changed, multiple fields can be used
* in the browse and the new field is from the active database,
* then we switch to the new field and deactivate the locate scope
if upper(varread())<>upper(thefld) .and. multfld .and. type(varread())<>"U"
store "" to theloc,theseek && deactivate locate scope
store upper(varread()) to thefld
if upper(thefld)=upper(fld1)
store fldlen to thelen
else
if type(varread())="C"
store len(varread()) to thelen
else
if type(varread())="D"
store 8 to thelen
else
store 6 to thelen
endif (date field)
endif (character field)
endif (field = first field)
endif (field changed since last locate)
DO CASE
case kkey = "F5"
if len(theloc) > 0 && a locate scope is active
store recno() to rn
cont
if eof() && no match found
goto rn && go to previous record
store "" to theloc && deactivate locate scope
endif
endif
do lbm
return
CASE Kkey = 'End' && End Key
store "" to theloc
Theseek = SPACE(0) && reinitialize seek key
theloc = space(0) && reinitialize locate
GO BOTTOM && go to the last record
CASE Kkey = 'Enter'
if selrec && multiple records can be selected
if selected && record already selected
replace selected with .f. && unselect record
else
replace selected with .t. && Select the record
endif
skip
if eof()
skip -1
endif
else
keyboard chr(23) && force ctrl-w to end
endif
theseek="" && clear key for next seek
case kkey = "F2" && F2 was pressed on multiple select
keyboard chr(23) && force ctrl-w to end
CASE Kkey = 'Home'
Theseek = SPACE(0)
theloc = space(0)
GO TOP
CASE Kkey = 'Backspace'
store space(0) to theloc
if right(theseek,1)="/" && for date fields
theseek=left(theseek,len(theseek)-1)
endif
if len(theseek) > 0
Theseek = LEFT(Theseek,LEN(Theseek)-1) && decrement string
endif
GO TOP
do findrec
OTHERWISE && Any alphanumeric key
store "" to theloc
if len(theseek) < thelen
theseek=theseek+kkey
else
theseek=kkey
endif
do findrec
ENDCASE
CLEAR
IF EOF() && If there was no "near-match"
store "" to theloc
* if no match found go to bottom of file unless user backspaced and
* erased ALL keys hit, in which case we return to top of file.
if lastkey()=8
* at this point user backspaced. since no match was found, this
* means that user erased all keys hit, so we go to top of browse
GO TOP
else
go bottom
endif
ENDIF EOF()
if bof()
store "" to theloc
go top
endif
do lbm
return

proc findrec
* if search string is longer than the size of the field being searched,
* we reset the search key to the most recent key hit. For example,
* if the user entered six characters while searching for a 5 character
* account code, we assume that after entering the first code, he
* changed his mind and the keys now hit are a search for a different code.
if type(thefld)="C"
if indx .and. thefld=fld1
SEEK keyfld+Theseek && and search again
else
store theseek to theloc
locate for UPPER(&thefld)=theloc
endif
else
if type(thefld)="N"
if indx .and. len(theseek)=thelen .and. fld1=thefld
* if file is indexed on this numeric key and the whole key
* has been entered, we can SEEK
seek val(theseek)
else
* you can not do a partial search on a numeric key. If user entered
* 7, a seek will find the record CLOSEST to 7. User will want a value
* BEGINNING with 7 (such as 7, 70-79, 700-799, etc.). So if the file
* is indexed and the length of the search key is identical to the length
* of the search field, a seek is done to find the exact record desired.
* If the file is not indexed or the length of the search key is not yet
* equal to the search field, a locate is done to position the pointer
* to the first record that starts with the characters entered.
store theseek to theloc
locate for ltrim(str(&thefld))=theloc
endif
else
if type(thefld)="D"
if len(theseek)=2 .or. len(theseek)=5
theseek=theseek+"/"
endif
if len(theseek)=8 .and. indx .and. thefld=fld1
seek ctod(theseek)
else
store theseek to theloc
locate for dtoc(&thefld)=theloc
endif
endif
endif
endif
return

proc lbm
ACTIVATE WINDOW LBM && display the search key and active field
@ 0,1 SAY "SEARCH: "
@ 0,9 say THESEEK+space(24-len(theseek))
@ 0,35 say "FIELD:"
@ 0,42 say upper(thefld)+" "
if len(theloc) > 0
@ 0,55 say "F5: Locate: "+theloc+" "
else
@ 0,55 say " "
endif
SHOW WINDOW LBM BOTTOM
if "*" $ feelds
DEFINE WINDOW LBM2 FROM 23,2 TO 23,78 NONE COLOR SCHEME 7
activate window lbm2
@ 0,23 say "* you can not search on this field"
show window lbm2 bottom
endif
DO INSTRUCT && redisplay instructions which vanish during browse
RETURN

PROC INSTRUCT
ACTIVATE WINDOW INSTRUCT
@0,3 say "Arrows, PgUp, PgDn, Home, End or enter a value to highlight a record."
if selrec
@1,3 say "Enter: select the record, ESC: cancel, F2: end selection process."
else
if addrecrd
@1,3 say "Press Enter to select the record, ESC to cancel or ADD a record."
else
@1,3 say "Press Enter to select the record, ESC to cancel selection."
endif
endif
SHOW WINDOW INSTRUCT BOTTOM
return

PROC CANCELKEY
* this routine is included in case of an error during the browse.
* since all the keys are defined with on key labels, an error at
* this point can really screw things up while debugging. So press
* F10 to complete cancel the labels and the whole routine.
ON KEY
clear windows
CANCEL
return

  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : BROWZE.ZIP
Filename : BROWZE.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

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