home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
basic
/
library
/
tb
/
tbwindow
/
tbwindo.inc
< prev
Wrap
Text File
|
1987-09-29
|
7KB
|
243 lines
defint a-z ' This affects entire program
mw = 30
ScrnArray = 8000
dim wrow(mw),wrows(mw),wcol(mw),wcols(mw),wattr(mw),wbrdr(mw)
dim wshdw(mw),scrn(ScrnArray),wptr(mw)
sub MakeWindow(Row,Col,Rows,Cols,Attr,BrdrSel,Shadow,Zoom) static
shared wrow(),wrows(),wcol(),wcols(),wattr(),wbrdr(),wshdw(),scrn(),wptr(),LI
local r1,r2,c1,c2,colratio,wsize
select case shadow
Rem Left
case = 1
c1=col-2 : c2=cols+2 : r2=rows+1
Rem Right
case = 2
c1=col : c2=cols+2 : r2=rows+1
case else
c1=col : c2=cols : r2=rows
end select
wsize = (r2 * c2) * 2
LI = LI + 1
Wptr(LI+1) = Wptr(LI)+WSize+1
WRow(LI) = Row
WCol(LI) = Col
WRows(LI) = Rows
WCols(LI) = Cols
Wattr(LI) = Attr
WBrdr(LI) = BrdrSel
WShdw(LI) = Shadow
Call Qsave(Row,c1,r2,c2,scrn(Wptr(LI)))
if zoom = 1 then
r1 = row + (rows\2)
r2 = row + rows-(rows\2)
c1 = col + (cols\2)
c2 = col + cols-(cols\2)
colratio = (cols \ rows)+1
if colratio > 4 then colratio=4
do
if r1>row then r1=r1-1
if r2<(row+rows) then r2=r2+1
if c1>col then c1=c1-colratio
if c1<col then c1=col
if c2<(col+cols) then c2=c2+colratio
if c2>(col+cols) then c2=col+cols
call Qbox(r1,c1,r2-r1,c2-c1,attr,brdrsel)
loop until c1=col and c2=col+cols and r1=row and r2=row+rows
else
call Qbox(row,col,rows,cols,attr,brdrsel)
end if
select case shadow
rem Left
case = 1
call qfill(row+1 ,col-2 ,rows-1,2 ,asc(" "),0)
call qfill(row+rows,col-2 ,1 ,cols,asc(" "),0)
rem Right
case = 2
call qfill(row+1 ,col+cols,rows-1,2 ,asc(" "),0)
call qfill(row+rows,col+2 ,1 ,cols,asc(" "),0)
case else
end select
end sub
sub TitleWindow(dir,title$) static
shared wrow(),wcol(),wrows(),wcols(),wattr(),LI
select case dir
rem UpperLeft
case = 1
call qprint(wrow(LI),wcol(LI)+2,title$,wattr(LI))
rem UpperCenter
case = 2
call qprintc(wrow(LI),wcol(LI),wcol(LI)+wcols(LI)-1,title$,wattr(LI))
rem UpperRight
case = 3
call qprint(wrow(LI),wcol(LI)+wcols(LI)-len(title$)-2,title$,wattr(LI))
rem LowerLeft
case = 4
call qprint(wrow(LI)+wrows(LI)-1,wcol(LI)+2,title$,wattr(LI))
rem LowerCenter
case = 5
call qprintc(wrow(LI)+wrows(LI)-1,wcol(LI),wcol(LI)+wcols(LI)-1,title$,wattr(LI))
rem LowerRight
case = 6
call qprint(wrow(LI)+wrows(LI)-1,wcol(LI)+wcols(LI)-len(title$)-2,title$,wattr(LI))
case else
end select
end sub
sub RemoveWindow static
shared Wrow(),WCol(),WRows(),Wcols(),Wattr(),WShdw(),Scrn(),Wptr(),LI
if LI = 0 then
print "NO WINDOW TO REMOVE"
else
select case WShdw(LI)
case = 1
call qrest(Wrow(LI),WCol(LI)-2,WRows(LI)+1,WCols(LI)+2,Scrn(Wptr(LI)))
case = 2
call qrest(WRow(LI),WCol(LI) ,WRows(LI)+1,WCols(LI)+2,Scrn(Wptr(LI)))
case else
call qrest(WRow(LI),Wcol(LI) ,WRows(LI) ,WCols(LI) ,Scrn(Wptr(LI)))
end select
LI = LI -1
end if
end sub
sub Qbox(Row,Col,Rows,Cols,attr,BrdrSel) static
if rows>2 and cols>2 then
if brdrsel > 0 and brdrsel < 6 then
on brdrsel gosub single,double,mixed12,mixed21,doubleleftarrow
call qprint(row ,col ,tl$ ,attr)
call qfill (row ,col+1 ,1 ,cols-2,asc(th$),attr)
call qprint(row ,col+cols-1,tr$ ,attr)
call qfill (row+1 ,col ,rows-2,1 ,asc(lv$),attr)
call qfill (row+1 ,col+cols-1,rows-2,1 ,asc(rv$),attr)
call qprint(row+rows-1,Col ,bl$ ,attr)
call qfill (row+rows-1,Col+1 ,1 ,cols-2,asc(bh$),attr)
call qprint(row+rows-1,col+cols-1,br$ ,attr)
call qfill (row+1 ,col+1 ,rows-2 ,cols-2,asc(" "),attr)
else
call qfill (row,col,rows,cols,asc(" "),attr)
end if
end if
exit sub
Single:
TL$=CHR$(218):TH$=CHR$(196):TR$=CHR$(191)
LV$=CHR$(179):RV$=CHR$(179)
BL$=CHR$(192):BH$=CHR$(196):BR$=CHR$(217)
Return
Double:
TL$=CHR$(201):TH$=CHR$(205):TR$=CHR$(187)
LV$=CHR$(186):RV$=CHR$(186)
BL$=CHR$(200):BH$=CHR$(205):BR$=CHR$(188)
Return
Mixed12:
TL$=CHR$(214):TH$=CHR$(196):TR$=CHR$(183)
LV$=CHR$(186):RV$=CHR$(186)
BL$=CHR$(211):BH$=CHR$(196):BR$=CHR$(189)
Return
Mixed21:
TL$=CHR$(213):TH$=CHR$(205):TR$=CHR$(184)
LV$=CHR$(179):RV$=CHR$(179)
BL$=CHR$(212):BH$=CHR$(205):BR$=CHR$(190)
Return
DoubleLeftArrow:
TL$=CHR$(17):TH$=CHR$(205):TR$=CHR$(187)
LV$=CHR$(186):RV$=CHR$(186)
BL$=CHR$(200):BH$=CHR$(205):BR$=CHR$(188)
Return
end sub
sub ClearWindow static
shared wrow(),wcol(),wrows(),wcols(),wattr(),LI
call qfill (wrow(LI)+1,wcol(LI)+1,wrows(LI)-2,wcols(LI)-2,asc(" "),wattr(LI))
end sub
sub PrtWindow(row,col,StrDat$) static
shared wrow(),wcol(),wrows(),wcols(),wattr(),LI
call qprint(wrow(LI)+row,wcol(LI)+col,StrDat$,wattr(LI))
end sub
sub PrtCWindow(row,StrDat$) static
shared wrow(),wcol(),wrows(),wcols(),wattr(),LI
call qprintc(wrow(LI)+row,wcol(LI),wcol(LI)+wcols(LI),StrDat$,wattr(LI))
end sub
sub WindowXY(row,col) static
shared wrow(),wcol(),wrows(),wcols(),wattr(),LI
locate wrow(LI)+row,wcol(LI)+col
end sub
sub makemenu static
shared wrow(),wrows(),wcol(),wcols(),wattr(),wbrdr(),wshdw(),scrn(),wptr(),LI
shared item$(),itemcount,startpos
shared curntpos
for mloop = 1 to itemcount
call qprintc(wrow(LI)+mloop,wcol(LI),wcol(LI)+wcols(LI),item$(mloop),wattr(LI))
next
if curntpos = 0 then if startpos = 0 then curntpos = 1 else curntpos = startpos
tryagain:
call qattr(wrow(LI)+curntpos,wcol(LI)+1,1,wcols(LI)-2,fnattr%(0,7))
while not instat
wend
ans$=inkey$
if len(ans$)=2 then ans$=right$(ans$,1)
call qattr(wrow(LI)+curntpos,wcol(LI)+1,1,wcols(LI)-2,wattr(LI))
select case ans$
case chr$(72),chr$(75),"-","8","4"
decr curntpos
case chr$(80),chr$(77),"+","2","6"
incr curntpos
case chr$(13)
exit sub
case chr$(27)
curntpos=0
exit sub
case else
curntpos = curntpos
end select
if curntpos > itemcount then curntpos = 1
if curntpos < 1 then curntpos = itemcount
goto tryagain
end sub
def fnattr(fore,back)
local temp
temp=(back*16)+fore
if fore>15 then temp = temp + 112
fnattr = temp
end def
SUB QPRINT INLINE
$INLINE "QPRINT.BIN"
END SUB
rem CALL QPRINT(ROW,COL,STR$,ATTR)
SUB QPRINTC INLINE
$INLINE "QPRINTC.BIN"
END SUB
rem CALL QPRINTC(ROW,COLL,COLR,STRDAT$,ATTR)
SUB QFILL INLINE
$INLINE "QFILL.BIN"
END SUB
rem CALL QFILL(ROW,COL,ROWS,COLS,CHAR,ATTR)
SUB QATTR INLINE
$INLINE "QATTR.BIN"
END SUB
rem CALL QATTR(ROW,COL,ROWS,COLS,ATTR)
SUB QSAVE INLINE
$INLINE "QSAVE.BIN"
END SUB
rem CALL QSAVE(ROW,COL,ROWS,COLS,SCRN(??))
SUB QREST INLINE
$INLINE "QREST.BIN"
END SUB
rem CALL QREST(ROW,COL,ROWS,COLS,SCR(??))