Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive : FPICKER.ZIP
Filename : PICKLIST.PRG
Output of file : PICKLIST.PRG contained in archive : FPICKER.ZIP
* º º
* º 02/12/92 PICKLIST.PRG 10:38:54 º
* º º
* ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ
* º º
* º Scott D. Grabo º
* º º
* º Copyright (c) 1992 º
* º Administrative Office of the U.S. Courts º
* º 1726 M Street NW º
* º Washington, DC 20544 º
* º º
* º Description: º
* º This program was automatically generated by GENSCRN. º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º PICKLIST Setup Code - SECTION 1 º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
#REGION 1
PARAMETER src_array, tgt_array, win_title, keepit, sourcename, ;
targetname, sort_order
PUSH MENU _MSYSMENU
*
* Needed to supress project build errors only
EXTERNAL ARRAY tgt_array, src_array
IF NOT TYPE("m.win_title") = "C" OR EMPTY("m.win_title")
*
* Default dialog box title
STORE "" TO m.win_title
ELSE
STORE " " + m.win_title + " " TO m.win_title
ENDIF
IF NOT TYPE("m.sourcename") = "C" OR EMPTY("m.sourcename")
STORE "Available" TO m.sourcename
ENDIF
IF NOT TYPE("m.targetname") = "C" OR EMPTY("m.targetname")
STORE "Selected" TO m.targetname
ENDIF
IF NOT TYPE("m.sort_order") = "N" OR m.sort_order = 0
STORE 1 TO m.sort_order
ENDIF
#REGION 0
REGIONAL m.currarea, m.talkstat, m.compstat
IF SET("TALK") = "ON"
SET TALK OFF
m.talkstat = "ON"
ELSE
m.talkstat = "OFF"
ENDIF
m.compstat = SET("COMPATIBLE")
SET COMPATIBLE FOXPLUS
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º Window definitions º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
IF NOT WEXIST("picklist")
DEFINE WINDOW picklist ;
FROM INT((SROW()-23)/2),INT((SCOL()-76)/2) ;
TO INT((SROW()-23)/2)+22,INT((SCOL()-76)/2)+75 ;
TITLE win_title ;
FLOAT ;
NOCLOSE ;
SHADOW ;
DOUBLE ;
COLOR SCHEME 5
ENDIF
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º PICKLIST Setup Code - SECTION 2 º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
#REGION 1
*
* The number of items in the source array
STORE ALEN(src_array, 1) TO src_arrctr
STORE ALEN(src_array, 2) TO src_width
*
* The initial/current position of bar in source box
STORE 1 TO src_value
*
* BAR index counter for the target POPUP; it never decrements
* since the POPUP is relative
STORE 0 TO tgt_barctr
*
* Counter for the target array
STORE 0 TO tgt_arrctr
*
* The initial/current position of bar in target box
STORE 1 TO tgt_value
*
* tgt_popup is defined as relative so that ;
* moving/adding/deleting will work
DEFINE POPUP tgt_popup;
RELATIVE ;
SCROLL ;
MARGIN ;
MOVER
*
* The array "behind" the POPUP must exist, and must have the
* same width (number of columns) as the source array
IF TYPE("m.tgt_array") = "L"
STORE "temp_array" TO m.tgt_array
STORE m.src_width + 1 TO m.tgt_width
DIMENSION &tgt_array[01, m.tgt_width]
STORE 0 TO tgt_length
ELSE
STORE ALEN(&tgt_array, 1) TO tgt_length
STORE ALEN(&tgt_array, 2) TO tgt_width
FOR m.tgt_arrctr = 1 TO m.tgt_length
*
* barctr is relative, so it never decrements
STORE tgt_barctr + 1 TO m.tgt_barctr
*
* DEFINE a new BAR with the PROMPT from the source box
DEFINE BAR (m.tgt_barctr) ;
OF tgt_popup ;
PROMPT &tgt_array[m.tgt_arrctr, 01]
STORE m.tgt_barctr TO &tgt_array[m.tgt_arrctr, m.tgt_width]
ENDFOR
STORE m.tgt_arrctr - 1 TO m.tgt_arrctr
ENDIF
STORE "" TO ok_cancel
STORE .T. TO was_changd
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º PICKLIST Screen Layout º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
#REGION 1
IF WVISIBLE("picklist")
ACTIVATE WINDOW picklist SAME
ELSE
ACTIVATE WINDOW picklist NOSHOW
ENDIF
@ 0,1 TO 9,72
@ 1,2 SAY m.sourcename ;
SIZE 1,39
@ 2,3 GET src_value ;
PICTURE "@&N" ;
FROM src_array ;
RANGE 1, src_arrctr ;
SIZE 7,68 ;
DEFAULT 1 ;
WHEN _q330mtqgp() ;
VALID add_one(src_value) ;
COLOR SCHEME 6
@ 10,2 GET m.select_one ;
PICTURE "@*HN \ SIZE 1,14,3 ;
DEFAULT 1 ;
VALID add_one(m.src_value)
@ 12,2 GET m.remove_one ;
PICTURE "@*HN \\ \
DEFAULT 1 ;
VALID delete_one(m.tgt_value)
@ 13,1 TO 20,72
@ 14,2 SAY m.targetname ;
SIZE 1,39
@ 15,3 GET tgt_value ;
PICTURE "@&N" ;
POPUP tgt_popup ;
SIZE 5,68 ;
DEFAULT " " ;
WHEN _q330mtqqc() ;
VALID delete_one(tgt_value) ;
COLOR SCHEME 6
@ 11,18 GET m.ok_cancel ;
PICTURE "@*HN \\\!O\
DEFAULT 1 ;
VALID _q330mtqwa()
IF NOT WVISIBLE("picklist")
ACTIVATE WINDOW picklist
ENDIF
READ CYCLE MODAL ;
WHEN _q330mtr5l() ;
SHOW _q330mtr5p()
RELEASE WINDOW picklist
#REGION 0
IF m.talkstat = "ON"
SET TALK ON
ENDIF
IF m.compstat = "ON"
SET COMPATIBLE ON
ENDIF
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º PICKLIST Cleanup Code º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
#REGION 1
POP MENU _MSYSMENU
RETURN m.was_changd
************************************************************
* Selects an item from source array and builds it into the
* target array and POPUP
FUNCTION add_one
PARAMETER curr_obj
*
* Increase the target array counter
STORE m.tgt_arrctr + 1 TO m.tgt_arrctr
*
* Redimension target array to new length
DIMENSION &tgt_array[m.tgt_arrctr, m.tgt_width]
*
* Make target array row equal to the row of the source; in
* other words, carry over the prompt and any other elements
* from the source array
FOR counter = 1 TO m.tgt_width - 1
STORE src_array[m.curr_obj, m.counter] ;
TO &tgt_array[m.tgt_arrctr, m.counter]
ENDFOR
*
* BAR counter is relative, so it never decrements
STORE tgt_barctr + 1 TO m.tgt_barctr
*
* Set the current position of the BAR in target to
* last item in list
STORE m.tgt_arrctr TO m.tgt_value
*
* DEFINE a new BAR with the PROMPT of the source item being
* added
DEFINE BAR (m.tgt_barctr) ;
OF tgt_popup ;
PROMPT &tgt_array[m.tgt_arrctr, 01]
STORE m.tgt_arrctr TO &tgt_array[m.tgt_arrctr, m.tgt_width]
*
* If not keep_it, remove this item from the source array
IF NOT m.keepit
*
* If it's the last object, make last object - 1 the current
* target BAR
IF m.curr_obj = m.src_arrctr
STORE m.src_arrctr - 1 TO m.src_value
ENDIF
STORE m.src_arrctr - 1 TO m.src_arrctr
*
* Delete the chosen source item from the source array,
* and reDIMENSION the source array. It will re-sort
* automatically
=ADEL(src_array, m.curr_obj)
DIMENSION src_array[m.src_arrctr, m.src_width]
ENDIF
SHOW GETS
RETURN .F.
*****************************************************************
* Un-selects an item, and returns it to the source array
* to be selected again
FUNCTION delete_one
PARAMETER curr_obj
*
* Since using the MOVER option will initiate the VALID clause,
* check to make sure this BAR wasn't just MOVEd.
IF was_moved(m.curr_obj)
*
* A 1 must be returned; for some reason returning .F. causes
* the highlited BAR to return to its original position and
* the valid is executed a second time
RETURN 1
ENDIF
*
* Find the array element (row) that corresponds to the
* information being displayed in the BAR
PRIVATE counter
FOR m.counter = 1 TO m.tgt_arrctr
IF &tgt_array[m.counter, m.tgt_width] = m.tgt_value
STORE m.counter TO this_elemt
EXIT
ENDIF
ENDFOR
*
* If not keep_it, move the item back into source box (since
* it was removed from the source box originally)
IF NOT m.keepit
*
* ReDIMENSION the source array to accept another item
STORE m.src_arrctr + 1 TO m.src_arrctr
DIMENSION src_array[m.src_arrctr, m.src_width]
*
* Make the source array row equal to the row of the target; in
* other words, carry over the PROMPT and any other elements
* from the target array
FOR counter = 1 TO m.tgt_width - 1
STORE &tgt_array[m.this_elemt, m.counter] ;
TO src_array[m.src_arrctr, m.counter]
ENDFOR
*
* Place the new item in the proper order
= ASORT(src_array, m.sort_order)
*
* Make the item being moved the new current item in the
* source array
STORE MAX(ASUBSCRIPT( ;
src_array, ASCAN(src_array, &tgt_array[m.this_elemt, 02]), ;
1), 1) ;
TO m.src_value
ENDIF
*
* Decrement the target counter
STORE m.tgt_arrctr - 1 TO m.tgt_arrctr
*
* Make last item in target array the current item
STORE m.tgt_arrctr TO m.tgt_value
*
* Remove the item from the target POPUP and array
RELEASE BAR (GETBAR("tgt_popup", m.curr_obj)) OF tgt_popup
=ADEL(&tgt_array, m.this_elemt)
*
* If necessary, reDIMENSION the target array
IF m.tgt_arrctr > 0
DIMENSION &tgt_array[MAX(m.tgt_arrctr, 1), m.tgt_width]
= was_moved("X")
ELSE
SHOW GET m.remove_one DISABLE
ENDIF
SHOW GETS
RETURN .F.
**************************************************************
* Checks to see if the BAR was MOVEd, or if the VALID clause
* should in fact be executed
FUNCTION was_moved
PARAMETER this_object
IF TYPE("m.this_object") = "N"
*
* Store the array number of the BAR in question
STORE PRMBAR("tgt_popup", GETBAR("tgt_popup", this_object)) ;
TO this_prompt
STORE ASUBSCRIPT(&tgt_array, ASCAN(&tgt_array, m.this_prompt), 1) ;
TO m.this_bar
*
* Since &tgt_array[
* kept up-to-date with the number (tgt_value) corresponding
* to its place in the POPUP (as opposed to its GETBAR()
* value), the item will not match if MOVEd, only if
* selected (double-click, enter, etc.).
IF m.this_object = &tgt_array[m.this_bar, m.tgt_width]
*
* Target item was selected, not MOVEd; execute VALID
* by returning a .F.
RETURN .F.
ENDIF
ENDIF
*
* Since the target item was MOVEd, we need to rewrite the
* target array's internal bar counter (the last column)
PRIVATE counter
FOR m.counter = 1 TO CNTBAR("tgt_popup")
STORE PRMBAR("tgt_popup", GETBAR("tgt_popup", m.counter)) ;
TO m.this_prompt
STORE ASUBSCRIPT(&tgt_array, ASCAN(&tgt_array, m.this_prompt), 1) ;
TO &tgt_array[m.counter, m.tgt_width]
ENDFOR
RETURN .T.
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º _Q330MTQGP src_value WHEN º
* º º
* º Function Origin: º
* º º
* º From Screen: PICKLIST, Record Number: 4 º
* º Variable: src_value º
* º Called By: WHEN Clause º
* º Object Type: List º
* º Snippet Number: 1 º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
FUNCTION _q330mtqgp && src_value WHEN
#REGION 1
*
* Disable the tgt_value-specific buttons
SHOW GET m.select_one ENABLE
SHOW GET m.remove_one DISABLE
SHOW GET m.ok_cancel, 3 DISABLE
SHOW GET m.ok_cancel, 4 ENABLE
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º _Q330MTQQC tgt_value WHEN º
* º º
* º Function Origin: º
* º º
* º From Screen: PICKLIST, Record Number: 9 º
* º Variable: tgt_value º
* º Called By: WHEN Clause º
* º Object Type: List º
* º Snippet Number: 2 º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
FUNCTION _q330mtqqc && tgt_value WHEN
#REGION 1
*
* Disable the src_value-specific buttons
SHOW GET m.select_one DISABLE
SHOW GET m.remove_one ENABLE
SHOW GET m.ok_cancel, 3 ENABLE
SHOW GET m.ok_cancel, 4 DISABLE
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º _Q330MTQWA m.ok_cancel VALID º
* º º
* º Function Origin: º
* º º
* º From Screen: PICKLIST, Record Number: 10 º
* º Variable: m.ok_cancel º
* º Called By: VALID Clause º
* º Object Type: Push Button º
* º Snippet Number: 3 º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
FUNCTION _q330mtqwa && m.ok_cancel VALID
#REGION 1
DO pickcase.prg WITH ok_cancel
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º _Q330MTR5L Read Level When º
* º º
* º Function Origin: º
* º º
* º From Screen: PICKLIST º
* º Called By: READ Statement º
* º Snippet Number: 4 º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
FUNCTION _q330mtr5l && Read Level When
*
* When Code from screen: PICKLIST
*
#REGION 1
*
* Calls the corresponding menu
*DO picklist.mpr
* ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ·
* º º
* º _Q330MTR5P Read Level Show º
* º º
* º Function Origin: º
* º º
* º From Screen: PICKLIST º
* º Called By: READ Statement º
* º Snippet Number: 5 º
* º º
* ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĽ
*
FUNCTION _q330mtr5p && Read Level Show
PRIVATE currwind
STORE WOUTPUT() TO currwind
*
* Show Code from screen: PICKLIST
*
#REGION 1
*
* Make the <
* one item has been selected
IF m.tgt_arrctr > 0
SHOW GET m.tgt_value ENABLE
SHOW GET m.ok_cancel, 1 ENABLE
ELSE
SHOW GET m.tgt_value DISABLE
SHOW GET m.ok_cancel, 1 DISABLE
ENDIF
WAIT CLEAR
IF NOT EMPTY(currwind)
ACTIVATE WINDOW (currwind) SAME
ENDIF
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/