home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / COLE.ZIP / ACH_WIN.PRG next >
Encoding:
Text File  |  1990-04-21  |  3.7 KB  |  106 lines
  1. **************************************************************************
  2. * Program Name: ach_win.prg                                              *
  3. * Author: Jonathan Cole                                                  *
  4. * Copyright (c) 1989 by American Management Systems, Inc.                *
  5. *------------------------------------------------------------------------*
  6. * Created: 6/30/1989 at 0:17                                             *
  7. * Revision: 1.0 Last Revised: 6/30/1989 at 0:35                          *
  8. * Description: Original Creation.                                        *
  9.  
  10. ***************************** ALL RIGHTS RESERVED ************************
  11.  
  12. FUNCTION ach_wndw( arr_ch, caption, mnutop, mnubtm, arr_avail, udf, frstch, winrow)
  13.  
  14.    * Purpose: create a drop shadowed window around an achoice()
  15.    * Syntax : ach_wndw( <array of choices>, <C caption>, <N top row>, <N bottom row>, <array of available options>, <C UDF name>, <N first choice>, <N window row> )
  16.    * Return : the return value from achoice
  17.    * Notes  : only the 1st parameter is necessary
  18.  
  19.    LOCAL mnuleft, mnuwidth, mnurght, oldcolor, J, oldscrn, u_choice
  20.    LOCAL num_els
  21.  
  22.    num_els   = LEN(arr_ch)              && number of elements in the array
  23.    oldcolor  = SETCOLOR(colchc)
  24.  
  25.    * ---check if optional parameters were passed. If not, set defaults. --- *
  26.    IF valtype( MNUTOP) != "N"
  27.       mnutop = 12                       && default top row
  28.    ENDIF
  29.  
  30.    IF valtype( MNUBTM) != "N"             && if it's not numeric either it wasn't passed or a dummy was passed (or an error)
  31.       mnubtm = IF( (mnutop + num_els - 1) < 21, mnutop + num_els - 1, 20 )
  32.    ELSE
  33.       mnubtm = IF( mnubtm < 21, mnubtm, 20 )
  34.    ENDIF
  35.  
  36.    IF valtype( ARR_AVAIL) == "U"
  37.       arr_avail = .T.                   && make everything available
  38.    ENDIF
  39.  
  40.    IF valtype( UDF) == "U"
  41.       udf = .F.                         && no key handling udf
  42.    ENDIF
  43.  
  44.    IF valtype( frstch) == "U"
  45.       frstch = .F.
  46.    ENDIF
  47.  
  48.    IF valtype( winrow) == "U"
  49.       winrow = .F.
  50.    ENDIF
  51.    *--------------------------------------*
  52.  
  53.    * determine how wide the window must be
  54.    mnuwidth = 0
  55.    FOR J = 1 TO num_els
  56.       IF LEN(arr_ch[j]) > mnuwidth
  57.          mnuwidth = LEN(arr_ch[j])
  58.       ENDIF
  59.    NEXT j
  60.  
  61.    IF valtype( CAPTION) == "C"
  62.       IF LEN(caption) > mnuwidth
  63.          mnuwidth = LEN(caption)
  64.       ENDIF
  65.    ENDIF
  66.  
  67.    * define the achoice() coordinates - the border of the box is outside of these.
  68.    mnuleft  = Center(SPACE(mnuwidth))
  69.    mnurght  = mnuleft + mnuwidth
  70.  
  71.    * save the screen area (including border & shadow) on which the box will appear
  72.    oldscrn  = SAVESCREEN( mnutop - 1, mnuleft-1, mnubtm + 2, mnurght + 2 )
  73.  
  74.    * shadow the box
  75.    shadow( mnutop-1, mnuleft-1, mnubtm+1, mnurght+1, maxrow() )
  76.  
  77.    * clear the box
  78.    @ mnutop - 1, mnuleft-1 CLEAR TO mnubtm + 1, mnuleft + mnuwidth + 1
  79.  
  80.    * draw frame around box
  81.    SETCOLOR(colchcx)
  82.    @ mnutop - 1, mnuleft - 1 TO mnubtm + 1, mnurght + 1 DOUBLE
  83.  
  84.    * if the entire array doesn't fit into the window, draw arrows
  85.    IF num_els > (mnubtm - mnutop + 1)
  86.       msg = "  "                      && up & down arrows
  87.       @ mnubtm+1, Center(msg) SAY msg
  88.    ENDIF
  89.  
  90.    * Put caption in top of frame if it exists
  91.    IF valtype( CAPTION) == "C"
  92.       @ mnutop - 1, Center(caption) SAY caption
  93.    ENDIF
  94.  
  95.    * Activate achoice menu function
  96.    SETCOLOR(colchc)
  97.    u_choice = Achoice(mnutop, mnuleft, mnubtm, mnurght, arr_ch, arr_avail, udf, frstch, winrow)
  98.  
  99.    * return screen to previous state
  100.    SETCOLOR(oldcolor)
  101.    Restscreen(  mnutop - 1, mnuleft-1, mnubtm + 2, mnurght + 2, oldscrn )
  102.  
  103. RETURN u_choice
  104. *------------------------------------------*
  105. * eof - ach_win.prg
  106.