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

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

* Sample call for the twodmenu() function.
CLEAR

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

PRIVATE 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[4]

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

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

? sel_no, com_sel


* Function Definition:
*
* NUMERIC twodmenu(t, l, b, r, sel_list, commands, @com_selected)
*
* 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.
*
* 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
PRIVATE selection, win_save, com_cols[len(commands)], i, tot_width
PRIVATE spaces_between, num_commands, cur_pos, start_chars

* 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.
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()

* 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")
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

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
ret_val = ac_select
IF lkey != enter
dehighlight_current()
com_selected = at(UPPER(CHR(lkey)), start_chars)
highlight_current()
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
* Un-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
esc = 27
enter = 13

void = .T.

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

RETURN void

* EOF: TwoMenu1.prg


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