home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
xbase
/
library
/
clipper
/
window
/
clipwndw
/
cwindow.prg
< prev
Wrap
Text File
|
1990-05-08
|
20KB
|
604 lines
***********************************************************************
*
* These are a group of functions that I wrote for Clipper. They
* enable me to use a very SIMPLE windowing system to approach the
* user. I am letting anyone use this, just mention me in your program.
* I should warn you that the following code is pure Clipper and needs to
* be extended.
*
* Use, enhance and develop, then buy a good 'C' compiler and do
* your databasing in that. spelled 'see code base 4'.
* You can define GOOD.
*
*
* If you need help or just have a question you can contact me at
*
*
* Robert Innes
* (701) 293-8739 Home after 6
* innes @ plains internet address
* rinnes @ extnet.plains.edu
*
*
* If I am not there.
* Please note the date and remember people do move on. ENJOY !!
***************************************************************************
*:**********************************************************************:
*: Program: CWINDOW.PRG
*:
*: System: Window Library for Clipper
*: Author: Robert Innes
*: Last modified: 06/08/89 10:12
*:
*: Procs & Fncts: WCOLOR() - set the colors for a window
*: : MAKE_WINDOW() - build and show a window
*: : WTITLE() - title a window
*: : WSAYAT() - put a string, with clipping in a window
*: : WMENU() - display a windowed' achoice
*: : REMOVE_WINDOW() - delete a window, restore if needed
*: : HOME_CURSOR - set the cursor to home
*: : WTRUNC_STR() - internal string truncation
*: : INRANGE() - see if coords are valid internal
*: : WGOTOXY - got to a point in a window
*: : WMESSAGE - pop up a message, various levels
*:
*:*********************************************************************
* Window Library For Clipper
*
* DECLARE a Public STRING ARRAY
*
* window[1] - Top of Window
* window[2] - Left of Window
* window[3] - Bottom of Window
* window[4] - Right of Window
* window[5] - ForeGround Color of Window
* window[6] - Background Color of Window
* window[7] - Title of Window
* window[8] - Does it Have a Shadow ?
* window[9] - Current Row of Cursor
* window[10]- Current Column of Cursor
* window[11]- Old Row of Cursor
* window[12]- Old Column of Cursor
* window[13]- Save contents under window ?
* window[14] - Window Save Buffer
*
*
* Public Defines for window Routines
*
* YES, virginia, you need these.
*
PUBLIC shadow, noshadow, shadow_color, saveit, notsave, choic
shadow = 1
noshadow = 0
shadow_color = '+/W'
saveit = 1
notsave = 0
*
* Currently all windows have double borders 'cause I was to lazy
* to do any others.
*
DOUBLE = CHR(201) + CHR(205) + CHR(187) + CHR(186) + CHR(188) + CHR(205) +;
CHR(200) + CHR(186) + CHR(32)
******************************************************
*
* The following code is the test procedure. This can
* be taken out when you get the hang of it.
*
* or use the preprocessor you have when you bought
* that GOOD 'C' compiler. ;-)
******************************************************
PUBLIC win1[14], menu1[20], menuv[20] && DEFINE PUBLIC VARIABLES
menu1[1] = 'Number 1' && wpop menu
menu1[2] = 'Number 2' && wpop menu
menu1[3] = 'Number 3' && wpop menu
menu1[4] = 'Number 4' && wpop menu
menu1[5] = 'Number 5' && wpop menu
menu1[6] = 'Number 6' && wpop menu
menu1[7] = 'Number 7' && wpop menu
menu1[8] = 'Number 8' && wpop menu
menu1[9] = 'Number 9' && wpop menu
menu1[10] = 'Number 10' && wpop menu
menu1[11] = 'Number 11' && wpop menu
menu1[12] = 'Number 12' && wpop menu
menu1[13] = 'Number 13' && wpop menu
menu1[14] = 'Number 14' && wpop menu
menu1[15] = 'Number 15' && wpop menu
menu1[16] = 'Number 16' && wpop menu
menu1[17] = 'Number 17' && wpop menu
menu1[18] = 'Number 18' && wpop menu
menu1[19] = 'Number 19' && wpop menu
menu1[20] = 'Number 20' && wpop menu
*
* If an option is set to false then it is displayed but not
* selectable. See achoice in the clipper manual.
*
menuv[1] = .T. && wpop menu
menuv[2] = .T. && wpop menu
menuv[3] = .T. && wpop menu
menuv[4] = .T. && wpop menu
menuv[5] = .F. && wpop menu
menuv[6] = .T. && wpop menu
menuv[7] = .F. && wpop menu
menuv[8] = .T. && wpop menu
menuv[9] = .T. && wpop menu
menuv[10] = .T. && wpop menu
menuv[11] = .T. && wpop menu
menuv[12] = .T. && wpop menu
menuv[13] = .T. && wpop menu
menuv[14] = .T. && wpop menu
menuv[15] = .T. && wpop menu
menuv[16] = .T. && wpop menu
menuv[17] = .T. && wpop menu
menuv[18] = .T. && wpop menu
menuv[19] = .T. && wpop menu
menuv[20] = .T. && wpop menu
win1[1] = STR(5)
win1[2] = STR(5)
win1[3] = STR(20)
win1[4] = STR(40)
win1[8] = STR(shadow)
win1[13]= STR(saveit)
wcolor( win1, 'BG', ' ')
win1[14] = make_window( win1 )
wtitle(win1, 'This is window Number 1')
wsayat( win1, 5, 5, 'A String')
wsayat( win1, 6, 5, 'A Very Very Long String That Should Not Print Far' )
wmessage(10, 10, 'Just a Note', 1)
wmessage(10, 10, 'Just a Warning, Improper Input', 2)
wmessage(10, 10, 'Error has Occured', 3)
wmessage(10, 10, 'Everything is OK', 9)
choic = wpop_menu( 5, 5, 'Choices', 20, menu1, menuv )
wsayat( win1, 7, 5, 'Choice = ' + LTRIM(STR(choic) ) )
INKEY(0)
remove_window( win1 )
RETURN && return to calling program
*!*********************************************************************
*!
*! Function: MAKE_WINDOW()
*!
*! Called by: CWINDOW.PRG
*! : WMENU() (function in CWINDOW.PRG)
*! : WMESSAGE (procedure in CWINDOW.PRG)
*!
*! Calls: HOME_CURSOR (procedure in CWINDOW.PRG)
*!
*!*********************************************************************
FUNCTION make_window
PARAMETERS WINDOW
PRIVATE wtop, wright, wbot, wleft, Buffer, shadow_bot, shadow_right, old_color && DEFINE PRIVATE VARIABLES
PRIVATE wcolor && DEFINE PRIVATE VARIABLES
PRIVATE TOP, RIGHT, bot, LEFT && DEFINE PRIVATE VARIABLES
*
* Convert window values to integer
*
TOP = VAL(WINDOW[1])
LEFT = VAL(WINDOW[2])
bot = VAL(WINDOW[3])
RIGHT = VAL(WINDOW[4])
*
* Set up actual window; inside minus border
*
wtop = VAL(WINDOW[1]) + 1
wleft = VAL(WINDOW[2]) + 1
wbot = VAL(WINDOW[3]) - 1
wright = VAL(WINDOW[4]) - 1
*
* Save the Window underneath
*
IF VAL(WINDOW[13]) == saveit
IF VAL(WINDOW[8]) == noshadow
Buffer = Savescreen( TOP, LEFT, bot, RIGHT )
ELSE && otherwise...
Buffer = Savescreen( TOP, LEFT, bot+1, RIGHT+2 )
ENDIF
ELSE && otherwise...
Buffer = ""
ENDIF
*
* Make the window
*
@ TOP, LEFT, bot, RIGHT BOX DOUBLE
IF VAL(WINDOW[8]) == shadow
cnt = TOP + 2
old_color = Setcolor()
Setcolor(shadow_color)
@ bot + 1, LEFT + 3 SAY SPACE( (RIGHT - (LEFT + 1)) )
DO WHILE cnt <= bot + 1
@ cnt, RIGHT + 1 SAY SPACE( 2 )
cnt = cnt + 1
END while
Setcolor(old_color)
ENDIF
wcolor = WINDOW[5] + '/' + WINDOW[6]
Setcolor(wcolor)
WINDOW[11] = STR( ROW() )
WINDOW[12] = STR( COL() )
home_cursor( WINDOW )
RETURN Buffer && RETURN TO CALLING PROGRAM
*!*********************************************************************
*!
*! Function: REMOVE_WINDOW()
*!
*! Called by: CWINDOW.PRG
*! : WMENU() (function in CWINDOW.PRG)
*! : WMESSAGE (procedure in CWINDOW.PRG)
*!
*!*********************************************************************
PROCEDURE remove_window
PARAMETER WINDOW
PRIVATE TOP, RIGHT, bot, LEFT, crow, ccol && DEFINE PRIVATE VARIABLES
IF VAL( WINDOW[13] ) == saveit
*
* Convert window values to integer
*
TOP = VAL(WINDOW[1])
LEFT = VAL(WINDOW[2])
bot = VAL(WINDOW[3])
RIGHT = VAL(WINDOW[4])
*
* Restore the area under the window
*
IF VAL( WINDOW[8] ) == noshadow
Restscreen( TOP, LEFT, bot, RIGHT, WINDOW[14] )
ELSE && otherwise...
Restscreen( TOP, LEFT, bot+1, RIGHT+2, WINDOW[14] )
ENDIF
ENDIF
*
* Reposition the cursor
*
crow = VAL( WINDOW[11] )
ccol = VAL( WINDOW[12] )
@ crow, ccol SAY ""
RETURN && return to calling program
*!*********************************************************************
*!
*! Function: WTITLE()
*!
*! Called by: CWINDOW.PRG
*! : WMENU() (function in CWINDOW.PRG)
*! : WMESSAGE (procedure in CWINDOW.PRG)
*!
*! Calls: HOME_CURSOR (procedure in CWINDOW.PRG)
*!
*!*********************************************************************
PROCEDURE wtitle
PARAMETER WINDOW, TITLE
PRIVATE TOP, RIGHT, bot, LEFT && DEFINE PRIVATE VARIABLES
*
* Convert window values to integer
*
TOP = VAL(WINDOW[1])
LEFT = VAL(WINDOW[2])
bot = VAL(WINDOW[3])
RIGHT = VAL(WINDOW[4])
WINDOW[7] = '[' + TITLE + ']'
*
* Title the window in the upper left corner
*
@ TOP, LEFT + 1 SAY WINDOW[7]
home_cursor( WINDOW )
RETURN && return to calling program
*!*********************************************************************
*!
*! Procedure: HOME_CURSOR
*!
*! Called by: MAKE_WINDOW() (function in CWINDOW.PRG)
*! : WTITLE() (function in CWINDOW.PRG)
*!
*!*********************************************************************
PROCEDURE home_cursor
PARAMETER WINDOW
PRIVATE wtop, wleft && DEFINE PRIVATE VARIABLES
wtop = VAL(WINDOW[1]) + 1
wleft = VAL(WINDOW[2]) + 1
WINDOW[9] = STR(wtop)
WINDOW[10] = STR(wleft)
@ wtop, wleft SAY ""
RETURN && return to calling program
*!*********************************************************************
*!
*! Function: WTRUNC_STR()
*!
*! Called by: WSAYAT() (function in CWINDOW.PRG)
*!
*!*********************************************************************
FUNCTION wtrunc_str
PARAMETERS WINDOW, string, X
PRIVATE substring, wleft && DEFINE PRIVATE VARIABLES
wright = VAL(WINDOW[4]) + 1
IF (X + LEN(string)) > wright
substring = LEFT( string, wright - X )
string = substring
ENDIF
RETURN string && RETURN TO CALLING PROGRAM
*!*********************************************************************
*!
*! Function: INRANGE()
*!
*! Called by: WSAYAT() (function in CWINDOW.PRG)
*! : WGOTOXY (procedure in CWINDOW.PRG)
*!
*!*********************************************************************
FUNCTION inrange
PARAMETERS WINDOW, X, y
IF X > VAL(WINDOW[1]) .AND. X < VAL(WINDOW[3])
IF y > VAL(WINDOW[2]) .AND. y < VAL(WINDOW[4])
RETURN .T. && RETURN TO CALLING PROGRAM
ELSE && otherwise...
RETURN .F. && RETURN TO CALLING PROGRAM
ENDIF
ENDIF
RETURN .F. && RETURN TO CALLING PROGRAM
*!*********************************************************************
*!
*! Procedure: WGOTOXY
*!
*! Calls: INRANGE() (function in CWINDOW.PRG)
*!
*!*********************************************************************
PROCEDURE wgotoxy
PARAMETERS WINDOW, X, y
PRIVATE wtop, wleft && DEFINE PRIVATE VARIABLES
wtop = VAL(WINDOW[1]) + 1
wleft = VAL(WINDOW[2]) + 1
X = wtop + X
y = wleft + X
IF inrange( WINDOW, X, y )
WINDOW[9] = STR(X)
WINDOW[10] = STR(y)
@ X, y SAY ""
ENDIF
RETURN && return to calling program
*!*********************************************************************
*!
*! Function: WSAYAT()
*!
*! Called by: CWINDOW.PRG
*! : WMESSAGE (procedure in CWINDOW.PRG)
*!
*! Calls: INRANGE() (function in CWINDOW.PRG)
*! : WTRUNC_STR() (function in CWINDOW.PRG)
*!
*!*********************************************************************
PROCEDURE wsayat
PARAMETERS WINDOW, X, y, string
PRIVATE wtop, wleft, substring && DEFINE PRIVATE VARIABLES
wtop = VAL(WINDOW[1]) + 1
wleft = VAL(WINDOW[2]) + 1
X = wtop + X
y = wleft + y
IF inrange( WINDOW, X, y )
WINDOW[9] = STR(X)
WINDOW[10] = STR(y)
substring = wtrunc_str( WINDOW, string, X)
@ X, y SAY substring
ENDIF
RETURN && return to calling program
*!*********************************************************************
*!
*! Function: WCOLOR()
*!
*! Called by: CWINDOW.PRG
*! : WMENU() (function in CWINDOW.PRG)
*! : WMESSAGE (procedure in CWINDOW.PRG)
*!
*!*********************************************************************
PROCEDURE wcolor
PARAMETERS WINDOW, fcolor, bcolor
PRIVATE COLOR && DEFINE PRIVATE VARIABLES
WINDOW[5] = fcolor
WINDOW[6] = bcolor
COLOR = fcolor + '/' + bcolor
Setcolor(COLOR)
RETURN && return to calling program
***********************************************
*
* Wow, an undocumenetd function. 8-) (* GRIN *)
*
***********************************************
Procedure hline
Parameters x, y, val, len, fcolor, bcolor
Private color, width, str && DEFINE PRIVATE VARIABLES
color = setcolor()
width = len - x
str = REPLICATE( val, width)
setcolor(fcolor, bcolor)
@ x, y SAY str
setcolor(color)
RETURN && return to calling program
*!*********************************************************************
*!
*! Procedure: WMESSAGE
*!
*! Calls: WCOLOR() (function in CWINDOW.PRG)
*! : MAKE_WINDOW() (function in CWINDOW.PRG)
*! : WTITLE() (function in CWINDOW.PRG)
*! : WSAYAT() (function in CWINDOW.PRG)
*! : REMOVE_WINDOW()(function in CWINDOW.PRG)
*!
*!*********************************************************************
PROCEDURE wmessage
PARAMETERS X, y, MESSAGE, level
PRIVATE wtop, wleft, wbot, wright, mwindow[14], wait_msg && DEFINE PRIVATE VARIABLES
wait_msg = "Press any Key ..." && wait for one character
mwindow[1] = STR(X)
mwindow[2] = STR(y)
mwindow[3] = STR(X + 2)
IF LEN( MESSAGE ) > (79 - y)
MESSAGE = LEFT( MESSAGE, 3 )
ENDIF
IF LEN( MESSAGE ) > LEN( wait_msg )
mwindow[4] = STR( X + LEN(MESSAGE) + 3)
ELSE && otherwise...
mwindow[4] = STR( X + LEN( wait_msg) + 3)
ENDIF
mwindow[8] = STR(noshadow)
mwindow[13]= STR(saveit)
DO CASE
CASE level = 1 && Informational Message
wcolor(mwindow,'N','G')
mwindow[14] = make_window( mwindow )
wtitle( mwindow, wait_msg)
wsayat(mwindow, 0, 0, MESSAGE)
INKEY(0)
remove_window( mwindow )
CASE level = 2 && Warning Message
wcolor(mwindow,'N','GR+')
mwindow[14] = make_window( mwindow )
wtitle( mwindow, wait_msg)
wsayat(mwindow, 0, 0, MESSAGE)
INKEY(0)
remove_window( mwindow )
CASE level = 3 && Error Message
wcolor(mwindow,'N','R')
mwindow[14] = make_window( mwindow )
wtitle( mwindow, wait_msg)
wsayat(mwindow, 0, 0, MESSAGE)
INKEY(0)
remove_window( mwindow )
OTHERWISE && Anything Else
wcolor(mwindow,'N','I')
mwindow[14] = make_window( mwindow )
wtitle( mwindow, wait_msg)
wsayat(mwindow, 0, 0, MESSAGE)
INKEY(0)
remove_window( mwindow )
ENDCASE
RETURN && return to calling program
*!*********************************************************************
*!
*! Function: WMENU()
*!
*! Called by: CWINDOW.PRG
*!
*! Calls: WCOLOR() (function in CWINDOW.PRG)
*! : MAKE_WINDOW() (function in CWINDOW.PRG)
*! : WTITLE() (function in CWINDOW.PRG)
*! : REMOVE_WINDOW()(function in CWINDOW.PRG)
*!
*!*********************************************************************
FUNCTION wpop_menu
PARAMETERS X, y, TITLE, num_choice, choices, choice_selectable
PRIVATE wtop, wleft, wbot, wright, cwindow[14], cnt, LEN, curlen, VAL, oldcolor && DEFINE PRIVATE VARIABLES
cnt = 1
LEN = 1
DO WHILE cnt <= num_choice
curlen = LEN( choices[cnt])
LEN = IIF( curlen > LEN, curlen, LEN )
cnt = cnt + 1
ENDDO && loop back again
cwindow[1] = STR(X)
cwindow[2] = STR(y)
cwindow[3] = STR( IIF( X + num_choice + 2 > 24, 24, X + num_choice + 1) )
cwindow[4] = STR( IIF( y + LEN + 2 > 79, 79, y + LEN + 1 ) )
cwindow[8] = STR(noshadow)
cwindow[13]= STR(saveit)
oldcolor = Setcolor()
wcolor( cwindow, 'N', 'BG')
cwindow[14] = make_window( cwindow )
wtitle( cwindow, TITLE)
wtop = VAL(cwindow[1]) + 1
wleft = VAL(cwindow[2]) + 1
wbot = VAL(cwindow[3]) - 1
wright = VAL(cwindow[4]) - 1
VAL = Achoice(wtop, wleft, wbot, wright, choices, choice_selectable)
remove_window( cwindow )
Setcolor(oldcolor)
RETURN VAL && RETURN TO CALLING PROGRAM
*: EOF: CWINDOW.PRG