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

 
Output of file : WINDOWS.PRG contained in archive : JBV1_2.ZIP
* Program: WINDOWS.PRG *******************************************************
* Author.: Joseph D. Booth **
* Date...: 01/08/88 **
* Version: CLIPPER, Summer '87 **
* Purpose: A series of function calls to allow windowing. They are written **
* entirely in CLIPPER code. **
******************************************************************************
FUNCTION w_init
*
* Syntax.: w_init( maximum number , default window color )
*
* Returns: - .T. if initialized OK
* .F. if parameter error
*
* Purpose: To initialize the memory variables and arrays to hold the windows.
*
PARAMETER max_windows,window_color
PRIVATE returnval
returnval = .F.
IF pcount() > 0
IF TYPE("max_windows") <> "N"
max_windows = 15
ENDIF
PUBLIC w_count,w_max,w_color
PUBLIC w_param[max_windows],w_screen[max_windows]
w_count = 0
w_max = max_windows
IF TYPE("window_color") <> "C"
IF iscolor()
window_color = "G/N,GR+/N,,,GR/N"
ELSE
window_color = "W+/N,N/W,,,W/N"
ENDIF
ENDIF
returnval = .T.
w_color = window_color
ENDIF
RETURN returnval
* ---------------------------------------------------------------------------
FUNCTION w_make
*
* Syntax.: w_make( top row, top column, bottom row, bottom column, type ;
* [display] )
*
* Returns: - window number if OK
* 0 if no windows are available
*
* Purpose: To establish a window parameters, and optionally display it
*
PARAMETER topR,topC,botR,botC,wtype,w_show,opt_color,opt_title
PRIVATE returnval,k
returnval = 0
IF TYPE("w_show") = "U"
w_show = .F.
ENDIF
FOR k=1 TO w_count
IF LEFT(w_param[k],1) = "A"
returnval = k
k = w_count +1
ENDIF
NEXT
IF returnval = 0
IF w_count < w_max
w_count = w_count +1
returnval = w_count
ELSE
returnval = 0
ENDIF
ENDIF
IF returnval > 0
w_param[returnval]="C"+CHR(topR+100)+CHR(topC+100)+;
CHR(botR+100)+CHR(botC+100)+STR(wtype,1)
IF TYPE("opt_color") = "C"
w_param[returnval] = w_param[returnval]+;
LEFT( UPPER(opt_color)+SPACE(24),24 )
ENDIF
IF TYPE("opt_title") = "C"
w_param[returnval] = w_param[returnval]+opt_title
ENDIF
IF w_show
w_display(returnval)
ENDIF
ENDIF
RETURN returnval
* ---------------------------------------------------------------------------
FUNCTION w_display
*
* Syntax.: w_display( window number )
*
* Returns: - .T. if window displayed
* .F. if error
*
* Purpose: To display a predefined window on the screen
*
PARAMETER window
PRIVATE returnval,topR,topC,botR,botC,wtype,cur_color,diff_color
PRIVATE w_title

returnval = .F.
IF window <= w_count
IF LEFT( w_param[window],1 ) = "C"
topR = ASC(SUBSTR(w_param[window],2,1)) -100
topC = ASC(SUBSTR(w_param[window],3,1)) -100
botR = ASC(SUBSTR(w_param[window],4,1)) -100
botC = ASC(SUBSTR(w_param[window],5,1)) -100
wtype = VAL(SUBSTR(w_param[window],6,1))
diff_color = TRIM(SUBSTR(w_param[window]+" ",7))
w_screen[window] = w__save(topR,topC,botR,botC)
IF LEN(TRIM(diff_color)) > 0
cur_color = setcolor(diff_color)
ELSE
cur_color = setcolor(w_color)
ENDIF
DO CASE
CASE wtype = 1
@ topR,topC,botR,botC BOX "ÚÄ¿³ÙÄÀ³ "
CASE wtype = 2
@ topR,topC,botR,botC BOX "ÉÍ»º¼ÍȺ "
CASE wtype = 3
@ topR,topC,botR,botC BOX "Õ͸³¾ÍÔ³ "
CASE wtype = 4
@ topR,topC,botR,botC BOX "ÖÄ·º½ÄÓº "
CASE wtype = 5
@ topR,topC,botR,botC BOX "ÞßÝÝÝÜÞÞ "
CASE wtype = 6
setcolor("+W/N")
@ topR+1,topC+2,botR,botC BOX "±±±±±±±±±"
setcolor(w_color)
@ topR,topC,botR-1,botC-1 BOX "ÞßÝÝÝÜÞÞ "
OTHERWISE
@ topR+1,topC+1 CLEAR TO botR-1,botC-1
ENDCASE
w_param[window] = STUFF(w_param[window],1,1,"O")
IF LEN(w_param[window]) > 30
w_title = SUBS(w_param[window],31)
@ topR,topC+2 SAY ' '+TRIM(w_title)+' '
ENDIF
setcolor(cur_color)
returnval = .T.
ENDIF
ENDIF
RETURN returnval
* ---------------------------------------------------------------------------
FUNCTION w_close
*
* Syntax.: w_close( window number )
*
* Returns: - .T. if window close OK
* .F. if error
*
* Purpose: To close a window and restore the screen
*
PARAMETER window
PRIVATE returnval
returnval = .F.
IF window <= w_count
IF w_open(window)
w__rest(window)
w_param[window] = STUFF(w_param[window],1,1,"C")
ENDIF
returnval = .T.
ENDIF
RETURN returnval
* ---------------------------------------------------------------------------
FUNCTION w_release
*
* Syntax.: w_release( window number )
*
* Returns: - .T. if release OK
* .F. if error
*
* Purpose: To release a window from the system
*
PARAMETER window
PRIVATE returnval
returnval = .F.
IF window <= w_count
IF w_open(window)
w_close(window)
ENDIF
w_param[window]="A00000"
returnval = .T.
ENDIF
RETURN returnval
* ---------------------------------------------------------------------------
FUNCTION w_pick
* Purpose: Pick an option from a windowed list
* Syntax.: ,, [,]
*
* Where..: expN1 - window number
* expN2 - maximum number of choices
* expC1 - array containing menu options
* expC2 - optional heading
*
PARAMETER window,howmany,choices,opthead
PRIVATE w_return,topR,topC,botR,botC,k,tsize,olng,curcolor
DECLARE bd[5]
bd[1]="ÃÄ´"
bd[2]="ÇĶ"
bd[3]="ÃÄ´"
bd[4]="ÇĶ"
bd[5]="ßßß"
IF TYPE("opthead") <> "C"
opthead = ""
ENDIF
DECLARE tarray[howmany]
IF TYPE("choices") = "A"
acopy(choices,tarray,1,howmany)
ELSE
tsize = LEN(choices) / howmany
FOR k=1 TO howmany
tarray[k]=SUBS(choices,(k-1)*tsize+1,tsize)
NEXT
ENDIF
w_return = 0
IF window <= w_count
IF w_open(window)
w_clear(window)
ELSE
w_display(window)
ENDIF
topR = ASC(SUBSTR(w_param[window],2,1)) -99
topC = ASC(SUBSTR(w_param[window],3,1)) -99
botR = ASC(SUBSTR(w_param[window],4,1)) -101
botC = ASC(SUBSTR(w_param[window],5,1)) -101
wtype = VAL(SUBSTR(w_param[window],6,1))
IF LEN(TRIM(opthead)) > 0
curcolor = setcolor()
SET COLOR TO &w_color
@ topR,topC + 1 SAY opthead
@ topR+1,topC-1 SAY LEFT(bd[wtype],1)+;
REPL(SUBS(bd[wtype],2,1),1+(botC-topC))+RIGHT(bd[wtype],1)
topR = topR +2
IF botC-topC > 24
@ botR,topC+1 SAY CHR(24)+","+CHR(25)+" to move,"+CHR(17)+"Ù to select"
botR = botR -1
ENDIF
setcolor(curcolor)
ENDIF
w_return = achoice(topR,topC,botR,botC,tarray)
ENDIF
RETURN w_return
* ---------------------------------------------------------------------------

FUNCTION w_view
* Purpose: Pick an record from a view database
* Syntax.: ,,
*
* Where..: expN1 - window number
* expC1 - database to view
* expC2 - string of fields to extract
*
* Returns: 0 - no record was selected
* expN - record number in database
* --------------------------------------------------------------------------
PARAMETER window,the_file,the_string
PRIVATE w_return,topR,topC,botR,botC,k,wtype
DECLARE the_str[1]
the_str[1] = the_string
w_return = 0
DO CASE
CASE TYPE("the_file") = "C"
SELECT &the_file
CASE TYPE("the_file") = "N"
SELECT (the_file)
ENDCASE
IF window <= w_count
IF w_open(window)
w_clear(window)
ELSE

w_display(window)
ENDIF
topR = ASC(SUBSTR(w_param[window],2,1)) -99
topC = ASC(SUBSTR(w_param[window],3,1)) -99
botR = ASC(SUBSTR(w_param[window],4,1)) -101
botC = ASC(SUBSTR(w_param[window],5,1)) -101
wtype = VAL(SUBSTR(w_param[window],6,1))
k = dbedit(topR,topC,botR,botC,the_str,"","","","","","","")
w_return = iif(k,recno(),0)
ENDIF
RETURN w_return

* ---------------------------------------------------------------------------

FUNCTION w_open
*
* Syntax.: w_open( window number )
*
* Returns: - .T. if window is open
* .F. otherwise
*
* Purpose: To test whether a window is open or not
*
PARAMETER window
PRIVATE retval
retval = .F.
IF window >0 .AND. window <= w_count
retval = ( left(w_param[window],1)="O" )
ENDIF
RETURN retval
* ---------------------------------------------------------------------------
FUNCTION w_clear
*
* Syntax.: w_clear( window number )
*
* Returns: - .T. if window is cleared
* .F. if error
*
* Purpose: To clear a window
*
PARAMETER window
PRIVATE returnval,topR,topC,botR,botC
returnval = .F.
IF window <= w_count
IF w_open(window)
topR = ASC(SUBSTR(w_param[window],2,1)) -100
topC = ASC(SUBSTR(w_param[window],3,1)) -100
botR = ASC(SUBSTR(w_param[window],4,1)) -100
botC = ASC(SUBSTR(w_param[window],5,1)) -100
@ topR+1,topC+1 CLEAR TO botR-1,botC-1
returnval = .T.
ENDIF
ENDIF
RETURN returnval
* ---------------------------------------------------------------------------
FUNCTION w_print
*
* Syntax.: w_print( window number,row,col,text )
*
* Returns: - .T. if text print ok
* .F. if error
*
* Purpose: To print text within a window
*
PARAMETER window,w_row,w_col,w_text
PRIVATE returnval,topR,topC,botR,botC
returnval = .F.
IF window <= w_count
IF w_open(window)
topR = ASC(SUBSTR(w_param[window],2,1)) -100
topC = ASC(SUBSTR(w_param[window],3,1)) -100
@ topR+w_row,topC+w_col SAY w_text
returnval = .T.
ENDIF
ENDIF
RETURN returnval
* ---------------------------------------------------------------------------
FUNCTION w__save
PARAMETERS topR,topC,botR,botC
RETURN savescreen(topR,topC,botR,botC)
* ---------------------------------------------------------------------------
FUNCTION w__rest
PARAMETER window
PRIVATE returnval,topR,topC,botR,botC
returnval = .F.
IF window <= w_count
IF w_open(window)
topR = ASC(SUBSTR(w_param[window],2,1)) -100
topC = ASC(SUBSTR(w_param[window],3,1)) -100
botR = ASC(SUBSTR(w_param[window],4,1)) -100
botC = ASC(SUBSTR(w_param[window],5,1)) -100
restscreen(topR,topC,botR,botC,w_screen[window])
returnval = .T.
ENDIF
ENDIF
RETURN returnval
* ---------------------------------------------------------------------------


  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : JBV1_2.ZIP
Filename : WINDOWS.PRG
”

  1. Daniel says:
    January 27, 2013 at 3:59 pm

    Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. Joshie says:
    March 18, 2014 at 4:57 pm

    This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. DiskingRound says:
    January 14, 2015 at 10:57 pm

    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/