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

 
Output of file : TWOMENU2.PRG contained in archive : NN0305.ZIP
* Program: TwoMenu2.prg
* Author: Rick Spence
* Version: Clipper Summer '87
* Note(s): See Function Definition below.
*
* Copyright (c) 1989 Nantucket Corporation.

* Sample call for twodmenu() function.
* (Alternative Implementation.)
CLEAR

t = 10
l = 10
b = 20
r = 45

* We make this public as we redimension it if we insert an
* element. It is then clearer that you need to explicitly
* RELEASE it.

PUBLIC sel_list[7]

sel_list[1] = "Brauer, Doris"
sel_list[2] = "Brown, Laurell"
sel_list[3] = "Cummings-Knight, Philip"
sel_list[4] = "Gruen, Keith"
sel_list[5] = "Humbs, Ingrid"
sel_list[6] = "Muller, Dietmar"
sel_list[7] = "Spence, Rick"

PRIVATE commands[5]

commands[1] = "Select"
commands[2] = "Delete"
commands[3] = "Insert"
commands[4] = "Change"
commands[5] = "Exit"

PRIVATE funcs[5]

funcs[1] = "sel_func"
funcs[2] = "del_func"
funcs[3] = "ins_func"
funcs[4] = "change_func"
funcs[5] = "ex_func"

com_sel = 1
sel_no = twodmenu(t, l, b, r, sel_list, commands, @com_sel, funcs)

RELEASE sel_list


* Alternative Function Definition:
*
* NUMERIC twodmenu(t, l, b, r, sel_list, commands,;
* @com_selected, funcs)
*
* NUMERIC t, l, b, r - The box's coordinates.
*
* CHARACTER sel_list[] - The list of items from which to choose.
*
* CHARACTER commands[] - The list of commands.
*
* NUMERIC @com_selected - The number of the selected command.
* This must be passed by reference.
*
* CHARACTER funcs - Function to be called, corresponding to
* command elements.
*
* Function returns one of:
*
* 0 - Exit, with twodmenu() returning
* current values.
*
* 1 - Abort exit, with twodmenu()
* returning 0.
*
* 2 - Redisplay, which forces twodmenu()
* to redisplay the list. This is
* useful if an item has been deleted
* or inserted.
*
* The function is passed the currently
* selected item as a parameter.
*
* The function returns the element number of the sel_list array
* that the user chose. This is zero if the user escaped from the
* function with the escape key.


FUNCTION twodmenu
PARAM t, l, b, r, sel_list, commands, com_selected, funcs
PRIVATE selection, win_save, com_cols[LEN(commands)], i, tot_width
PRIVATE spaces_between, num_commands, cur_pos, start_chars
PRIVATE ac_mode, ac_rel, AC_REDRAW, AC_FINISHED

* Initialize required memory variable constants.
init_consts()

selection = 1
num_commands = LEN(commands)

win_save = SAVESCREEN(t, l, b, r)

* Draw interleaved boxes.
@ t, l TO b, r
@ b - 2, l, b, r BOX CHR(195) + CHR(196) + CHR(180) + CHR(179) + ;
CHR(217) + CHR(196) + CHR(192) + CHR(179)

* Figure out spacing for commands.
tot_width = 0
FOR i = 1 TO num_commands
tot_width = tot_width + LEN(commands[i])
NEXT

spaces_between = INT(((r - l - 1) - tot_width)/(num_commands + 1))

* Draw commands and build first characters string.
cur_pos = l + 1 + spaces_between
start_chars = ""

FOR i = 1 TO num_commands
com_cols[i] = cur_pos
@ b - 1, cur_pos SAY commands[i]
cur_pos = cur_pos + LEN(commands[i]) + spaces_between
start_chars = start_chars + UPPER(SUBSTR(commands[i], 1, 1))
NEXT

highlight_current()

ac_redraw = 0
ac_finished = 1

ac_mode = ac_redraw
ac_rel = 0
selection = 1

DO WHILE ac_mode = ac_redraw
ac_mode = ac_finished

* Clear the list area.
SCROLL(t + 1, l + 1, b - 3, r - 1, 0)

selection = ACHOICE(t + 1, l + 1, b - 3, r - 1, sel_list, ;
.T., "ac_func", selection, ac_rel)
ENDDO

RESTSCREEN(t, l, b, r, win_save)
RETURN selection


* ACHOICE() user function.
FUNCTION ac_func
PARAMETER mode, cur_elem, rel_pos
PRIVATE ret_val, lkey, fname, f_ret_val

ac_rel = rel_pos
ret_val = ac_continue
IF mode = ac_excep
lkey = LASTKEY()
DO CASE
CASE lkey = esc
ret_val = ac_abort

CASE lkey = enter .OR. UPPER(CHR(lkey)) $ start_chars
IF lkey != enter
dehighlight_current()
com_selected = at(UPPER(CHR(lkey)), start_chars)
highlight_current()
ENDIF

IF type("funcs[com_selected]") != "U"
* Call func.
fname = funcs[com_selected] + "(cur_elem)"
f_ret_val = &fname
DO CASE
CASE f_ret_val = 0
ret_val = ac_select

CASE f_ret_val = 1
ret_val = ac_abort

CASE f_ret_val = 2 && Redraw.
* Set global to force reentry
ac_mode = ac_redraw
ret_val = ac_select

CASE f_ret_val = 3
ret_val = ac_continue

OTHERWISE
ret_val = ac_select
ENDCASE
ELSE
ret_val = ac_select
ENDIF

CASE lkey = left_arrow
dehighlight_current()
IF com_selected = 1
com_selected = num_commands
ELSE
com_selected = com_selected - 1
ENDIF

highlight_current()
ret_val = ac_continue

CASE lkey = right_arrow
dehighlight_current()
IF com_selected = num_commands
com_selected = 1
ELSE
com_selected = com_selected + 1
ENDIF

highlight_current()
ret_val = ac_continue

ENDCASE
ENDIF
RETURN ret_val


FUNCTION highlight_current
* Highlight current command.
@ b - 1, com_cols[com_selected] GET commands[com_selected]
CLEAR GETS
RETURN void


FUNCTION dehighlight_current
* Highlight current command.
@ b - 1, com_cols[com_selected] SAY commands[com_selected]
RETURN void


FUNCTION init_consts

PUBLIC left_arrow, right_arrow, void, esc, enter
PUBLIC ac_continue, ac_select, ac_abort, ac_excep

left_arrow = 19
right_arrow = 4
void = .T.
esc = 27
enter = 13

ac_continue = 2
ac_select = 1
ac_abort = 0
ac_excep = 3

RETURN void


* Here are the sample functions I wrote to operate on the list.

* Select the current item and exit.

FUNCTION sel_func
PARAM cur_elem
RETURN 0 && Exit.


* Delete the current item.
FUNCTION del_func
PARAM cur_elem

* Get around ADEL() anomaly.
IF cur_elem = LEN(sel_list)
sel_list[cur_elem] = .T.
ELSE
ADEL(sel_list, cur_elem)
ENDIF
RETURN 2 && Redraw.


* Insert an element before the current item.
FUNCTION ins_func
PARAM cur_elem
PRIVATE new_list[LEN(sel_list) + 1]

* Insert element into new array.
ACOPY(sel_list, new_list, 1, cur_elem - 1, 1)
new_list[cur_elem] = space(r - l - 1)
ACOPY(sel_list, new_list, cur_elem, LEN(sel_list)-cur_elem + ;
1, cur_elem + 1)

* Redimension sel_list.
PUBLIC sel_list[LEN(new_list)]

* Now copy new list into it.
ACOPY(new_list, sel_list)

RETURN 2 && Redraw.


* Edit the current item.
FUNCTION change_func
PARAM cur_elem
SET CURSOR ON

* We must allow them to GET the width of the box.
sel_list[cur_elem] = SUBSTR(sel_list[cur_elem] + space(r-l-1), ;
1, r - l - 1)
@ t + rel_pos + 1, l + 1 GET sel_list[cur_elem]
READ

sel_list[cur_elem] = trim(sel_list[cur_elem])

SET CURSOR OFF

RETURN 2 && Redraw.


* Exit the process.
FUNCTION ex_func
PARAM cur_elem
RETURN 1 && Abort.

* EOF: TwoMenu2.prg


  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : NN0305.ZIP
Filename : TWOMENU2.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/