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

*---> Procedure File: Procs.prg
*---> Author: Chris K. Kaufman
*---< Last#Update: 18-Feb-91
*---> Purpose: Demonstration of useful procedures
*---> Called by: Main.prg
*--.0,Qsds: Menu.dbf, Menu.ndx, Sample.dbf, Sample.ndx

*---> This procedure file contains the following useful utilities
*---> menu Displays a popup menu window using parameters
*---> stored in menu.dbf, choices can be made by pressing
*---> the key corresponding to a menu item or by using
*---> the arrow keys to move the selection bar.
*---> errormsg Displays an error message on line 24 of the
*---> screen and waits for a key press.
*---> Title Displays a centered title on line 0 of the screen.
*---> blankmenu Blanks the last menu displayed.
*---> clrwindow Clears a window on the screen
*---> dispinst Displays instructions on line 23 of the screen
*---> in the same color as the last menu.
*---> picklist Displays a list of items from the currently selected
*---> database to choose from.

procedure menu
*---> Menu displays popup menu. Arrow keys allow selection bar to be scrolled,
*---> Pressing the first or key letter of any option moves selection bar to
*---> that option. Pressing Enter returns selection number to calling
*---> procedure. Other keystrokes are ignored.
*---> menuscrn is name of menu, used as index into menu database.
*---> selection is option command to return to calling procedure.
parameters mscrn, selection
*---> get menu information
select 9
seek mscrn
*---> check for menu system error
if found()
*---> menu found
*---> get menu colors
mcolormenu = menu->colormenu
mcolorbar = menu->colorbar
mcolorbord = menu->colorbord
*---> draw border
set color to &mcolorbord
@top-1,left-1 to top+numoptions,left+optwidth double
*---> display options
set color to &mcolormenu
selection = 0
do while selection < numoptions
textnorm = 'option'+ltrim(str(selection))
@top+selection,left say substr(&textnorm,1,optwidth)
selection = selection+1
enddo
*---> highlight first menu selection
set color to &mcolorbar
@top,left say substr(option0,1,optwidth)
*---> display first menu description
@23,0 say descr0
*---> initialize loop variables
response = 0
previous = 0
selection = 0
*---> top of loop
do while response <> 13
response = 0
*---> wait for keypress
do while response = 0
response = inkey()
enddo
*---> remember previous selection
previous = selection
*---> process keypress
do case
case response = 24
*---> down arrow
selection = mod(selection+1,numoptions)
case response = 5
*---> up arrow
selection = mod(selection+numoptions-1,numoptions)
case response >= 0
*---> not an arrow key, check for option letters
*---> convert to uppercase character
chrresp = upper(chr(response))
*---> find location in option string, location-1 is selection
selection = at(chrresp,optstring)-1
if (selection = -1) .or. (selection >= numoptions)
*---> selection not found, restore previous
selection = previous
endif
otherwise
*---> function keys return negative values
endcase
if selection <> previous
*---> move selection bar
*---> write previous menu selection in normal (menu) color
textnorm = 'option'+ltrim(str(previous))
set color to &mcolormenu
@top+previous,left say substr(&textnorm,1,optwidth)
*---> write new menu selection in highlighted (bar) color
texthigh = 'option'+ltrim(str(selection))
set color to &mcolorbar
@top+selection,left say substr(&texthigh,1,optwidth)
texthigh = 'descr'+ltrim(str(selection))
@23,0 say &texthigh
endif
enddo
else
*---> menu not found
do errormsg with 'Menu not available. Press any key to continue.'
*---> return -1 as menusel
menusel = -1
endif
*---> return to calling procedure.
select 1
return

procedure errormsg
*---> display error message on last line, wait for keypress.
*---> message is string to display
parameters message
*---> display message in yellow on red, centered, at bottom of screen
set color to gr+/r
@24,int(40-len(message)/2) say message
*---> wait for keypress
do while inkey() = 0
enddo
*---> blank error
set color to
@24,0 say space(80)
*---> return to calling procedure
return

procedure title
*---> display title at top of screen
parameters title
set color to gr+/n
@0,0 say space(80)
@0,40-int(len(title)/2) say title
return

procedure blankmenu
*---> blank the last menu displayed
do clrwindow with menu->top-1,menu->left-1,menu->top+menu->numoptions,menu->left+menu->optwidth
return

procedure clrwindow
*---> blank window
parameters top,left,bottom,right
set color to
blankline = space(right-left+1)
ptr = top
do while ptr <= bottom
@ ptr,left say blankline
ptr = ptr+1
enddo
return

procedure dispinst
parameters message
*---> set color to match menu bar
color = menu->colorbar
set color to &color
*---> blank old message, display new message
@23,0 say space(80)
@23,0 say message
return

procedure picklist
*---> picklist displays a list of string expressions and allows the user to
*---> select one string to be returned. up and down arrows allow scrolling
*---> dbf used is in current select area
parameters strexpr, mcolormenu, mcolorbar, mcolorbord, top, left, numoptions
*---> draw border
set color to &mcolormenu
@ top-1,left-1 to top+numoptions,left+len(&strexpr) double
*---> initialize pointers
numsel = 0
offset = 0
*---> initialize loop variables
response = 0
previous = 0
selection = 0
*---> display options
do displist with selection
*---> top of loop
do while response <> 13 .and. response <> 27
response = 0
*---> wait for keypress
do while response = 0
response = inkey()
enddo
*---> process keypress

do case
case response = 3
*---> page down
if selection = numsel - 1
*---> at bottom of window
if numsel = numoptions
*---> window is full, scroll
offset = offset + numoptions - 1
selection = 0
endif
else
*---> move to bottom of window
selection = numsel - 1
endif
do displist with selection
case response = 5
*---> up arrow
do moveup
case response = 18
*---> page up
if selection = 0
if offset < numoptions - 1
offset = 0
selection = 0
else
offset = offset - numoptions + 1
endif
else
offset = offset + numsel - numoptions
selection = 0
endif
do displist with selection
case response = 24
*---> down arrow
do movedown
otherwise
*---> ignore key
endcase
enddo
if response = 27
*---> picklist terminated with ESC
*---> return eof()
if .not. eof()
go bottom
skip
endif
endif
*---> remove picklist
do clrwindow with top-1,left-1,top+numoptions,left+len(&strexpr)
*---> return to calling procedure.
return

procedure displist
*---> numsel is number of selections actually available
*---> point to string expression at record number offset.
parameters hisel
goto top
skip offset
numsel = 0
if eof()
*---> check for empty list
do errormsg with 'No options to display. Press any key to continue.'
else
*---> display string expressions until numoptions have been displayed
*---> or end of file is reached.
do while (numsel < numoptions) .and. (.not. eof())
if numsel = hisel
*---> highlight menu option
set color to &mcolorbar
else
*---> normal option
set color to &mcolormenu
endif
@top+numsel, left say &strexpr
*---> move pointer
skip
numsel = numsel + 1
enddo
*---> restore pointer to offset
skip hisel-numsel
*---> if end of list found blank remaining entries
if numsel < numoptions
set color to &mcolormenu
blankopt = space(len(&strexpr))
i = numsel
do while i < numoptions
@top+i,left say blankopt
i = i+1
enddo
endif
endif
return

procedure movedown
if selection < numsel-1
*---> display old selection in normal color
set color to &mcolormenu
@top+selection, left say &strexpr
*---> move pointers
selection = selection + 1
skip
*---> display new selection in highlit color
set color to &mcolorbar
@top+selection, left say &strexpr
else
*---> at bottom of window
*---> only scroll window if window is full
if numsel = numoptions
offset = offset+selection
selection = 0
do displist with selection
endif
endif
return

procedure moveup
if selection > 0
*---> display old selection in normal color
set color to &mcolormenu
@top+selection, left say &strexpr
*---> move pointers
selection = selection - 1
skip -1
*---> display new selection in highlit color
set color to &mcolorbar
@top+selection, left say &strexpr
else
*---> at top of window, scroll 1 page and leave bar at bottom of window
if offset < numoptions-1
*---> too close to top of file, can't scroll full page
selection = offset
offset = 0
else
*---> scroll full page
offset = offset-numoptions+1
selection = numoptions-1
endif
do displist with selection
endif
return

procedure disphelp
*---> display help information
set color to r/n
@ 14,9 to 22,70 double
set color to gr+/n
@ 16, 10 say 'Move the menu selection bar with the cursor up and down keys'
@ 17, 10 say 'or by pressing the first capitalized letter of an option. '
@ 18, 10 say 'Press the Enter key to activate the selection. The bottom '
@ 19, 10 say 'two lines of the screen display descriptions of menu options'
@ 20, 10 say 'and error messages. Each menu item displays help on the '
@ 21, 10 say 'corresponding procedure. '
do dispinst with 'Menu descriptions and instructions display here.'
do errormsg with 'Error messages display here. Press any key to continue.'
set color to
@14,0 clear
return

*---> The following procedures are called by Main.prg to explain/demonstrate
*---> procedures defined above.

procedure menuinf
*---> display information on menu
do dispinst with 'Menu procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The menu procedure is called with two parameters, the menu screen name and the
variable that the menu selection will be returned as. All other information
is stored in menu.dbf in select area 9. After a menu choice is made the select
area is set to one, and selection number 0..n is returned.
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display next bit of info.
set color to gr+/n
@15,0
text
The menu options that can be set in the menu.dbf file are the location of the
upper left hand corner of the menu, the colors of the menu, menu bar and menu
border, the number of options in the menu (1..20), the width of the menu
(1..20), the prompt for each menu choice, the description of each menu choice
that is displayed on line 23, and the characters that will be accepted to
select each of the menu items.
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display next bit of info.
set color to gr+/n
@15,0
text
The code for calling a menu is:
menusel = 0 >>> initialize parameter to be passed
do menu with 'menu name ',menusel >>> 'menu name ' is 10 character key
do case into menu.dbf
case menusel=0 >>> process menu options 0..n
...
endcase
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display next bit of info.
set color to gr+/n
@15,0
text
Notes: First menu option is 0, if you have 10 options they are 0..9
After calling a menu you are returned to select area 1
Window size is 2 greater than numoptions x optionwidth to allow
for border around window.
For best results use only 3 color for menu, menubar, and menuborder.
for example: C1/C2, C1/C3 & C3/C2 or C1/C2, C2/C3, & C3/C1
endtext
do errormsg with 'Press any key to display a sub-menu'
subsel = 0
do title with 'S U B M E N U - Select an option and press .'
do menu with 'sub menu 1', subsel
do blankmenu
do clrwindow with 15,0,22,79
return

procedure errmsginf
*---> display information on errormsg procedure
do dispinst with 'Errormsg procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The errormsg procedure is called with one parameter, the error message to
display. The message is displayed centered on line 24 in yellow on red until a
key is pressed. For example:

do errormsg with 'Sample Error Message. Press any key to continue.'

will display as shown below.
endtext
do errormsg with 'Sample Error Message. Press any key to continue.'
do clrwindow with 15,0,22,79
return

procedure blmenuinf
*---> display information on blankmenu procedure
do dispinst with 'Blankmenu procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The blankmenu procedure blanks the previous menu (paints it black).
No parameters are passed. The syntax is:

do blankmenu
endtext
do errormsg with 'Press any key to blank the menu.'
do blankmenu
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
The menu has been blanked.
endtext
do errormsg with 'Press any key to return to the menu.'
do clrwindow with 15,0,22,79
return

procedure titleinf
*---> display information on title procedure
do dispinst with 'Title procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The title procedure is called with one parameter: the title to be displayed.
The title is displayed centerered on line 0 in yellow. An example follows:

do title with 'This is a new title line.'
endtext
do errormsg with 'Press any key to display the new title.'
do title with 'This is a new title line.'
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
The new title is displayed.
endtext
do errormsg with 'Press any key to return to the menu.'
do clrwindow with 15,0,22,79
return

procedure clrwininf
*---> display information on clrwindow procedure
do dispinst with 'Clrwindow procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The clrwindow procedure clears (paints black) a rectangular block of text.
The parameters passed are coordinates of the top left and bottom right
corners of the block. For example, to clear a block of text from 10,35 to
17,45 the command:
do clrwindow with 10,35,17,45
would be used.
endtext
do errormsg with 'Press any key to clear a window from 10,35 to 17,45.'
do clrwindow with 10,35,17,45
*---> display the next bit of info.
do dispinst with 'The window has been cleared.'
do errormsg with 'Press any key to return to the menu.'
do clrwindow with 15,0,22,79
return

procedure dinstinf
*---> display information on dispinst procedure
do dispinst with 'Dispinst procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The dispinst procedure displays instructions on line 24 in the current menubar
colors. One parameter is passed: the message to be displayed.
the format is:
do dispinst with 'dispinst display information on this line.'
endtext
do errormsg with 'Press any key to display the above message.'
do dispinst with 'dispinst display information on this line.'
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
The new instruction line has been displayed.
endtext
do errormsg with 'Press any key to return to the menu.'
do clrwindow with 15,0,22,79
return

procedure plistinf
*---> display information on picklist procedure
do dispinst with 'Picklist procedure information.'
*---> display first bit of info.
set color to gr+/n
@15,0
text
The picklist procedure allows the user to pick a record out of a database. A
window is displayed with a field or an expression involving one or more fields.
The user can scroll up and down through the list using the up/down cursor keys
and the page up/page down keys. A record in the database is chosen by pressing
enter when the desired information is highlighted in the window. The procedure
returns with the selected record current. If ESC is pressed the procedure
returns EOF().
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
When the procedure is called the parameters passed are the string expression to
display, the colors to use, the location of the top left corner of the window,
and the number of selections to display in the window. The database must be in
the current selected area. Filters and indexes may be active.
IMPORTANT: The string expression must be of constant length.
endtext
do errormsg with 'Press any key to continue...'
do clrwindow with 15,0,22,79
*---> display the next bit of info.
set color to gr+/n
@15,0
text
Sample code for using a picklist follows:

use sample index sample
do picklist with 'last_name+", "+first_name+" "+middl_init+"."',
'w+/b', 'w+/r', 'r/b', 7, 1, 7

NOTE: The previous line was split to fit on the display.
endtext
do errormsg with 'Press any key to display picklist.'
do clrwindow with 15,0,22,79
use sample index sample
do picklist with 'last_name+", "+first_name+" "+middl_init+"."', 'w+/b', 'w+/r', 'r/b', 7, 1, 7
if eof()
do dispinst with 'You pressed ESC to leave the pick list.'
else
do dispinst with 'You selected '+trim(first_name)+' '+middl_init+'. '+last_name
endif
use
do errormsg with 'Press any key to return to the main menu.'
return