home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
progm
/
b-window.zip
/
QBDEMO.BAS
< prev
next >
Wrap
BASIC Source File
|
1988-07-15
|
8KB
|
274 lines
'QBDEMO.BAS: Demo of compiled QuickBASIC Version 4 with B-WINDOW
' Compile this as "QBDEMO.OBJ"
' Then link to "QBV4.OBJ" (available, with source code, for $20)
' or
' Load "QBV4.QLB" when you run QuickBASIC interactively:
' QB QBDEMO /LQBV4.QLB
' windowing constants
w.mono% = 0: w.cga% = 1: w.ega% = 2
w.true% = 1: w.false% = 0: w.error% = 0: w.success% = 1
' 6 border types; no border,single line, double line, mixed 1 & 2, block
w.nobdr% = 0: w.sngln% = 1: w.dbln% = 2:
w.mxd1% = 3: w.mxd2% = 4: w.blkln% = 5
' determine if color or monochrome video card
CALL wscrntype(stype%)
IF stype% = w.mono% THEN
' set everything to white-on-black if monochrome board
'window 1 window 2 window 3 window 4
wbgc1% = 0: wbgc2% = 0: wbgc3% = 0: wbgc4% = 0 ' background color
bfgc1% = 7: bfgc2% = 7: bfgc3% = 7: bfgc4% = 7 ' foreground color
bbgc1% = 0: bbgc2% = 0: bbgc3% = 0: bbgc4% = 0 ' background color
wtc1% = 7: wtc2% = 7: wtc3% = 7: wtc4% = 7 ' window text color
sfgc1% = 7: sbgc1% = 0 ' string color
ELSE
' color setup
'window 1 window 2 window 3 window 4
wbgc1% = 2: wbgc2% = 5: wbgc3% = 7: wbgc4% = 5
bfgc1% = 5: bfgc2% = 4: bfgc3% = 1: bfgc4% = 2
bbgc1% = 2: bbgc2% = 4: bbgc3% = 1: bbgc4% = 2
wtc1% = 7: wtc2% = 7: wtc3% = 0: wtc4% = 14
sfgc1% = 12: sbgc1% = 1
END IF
' initialize windowing. do not forget to do this!
CALL winit(status%)
IF status% = w.error% THEN PRINT "initialization error": STOP
' draw a border on screen
x% = 8: y% = 5: wid% = 55: hgt% = 7: btype% = w.blkln%
CALL wborder(status%, x%, y%, wid%, hgt%, btype%)
' write on 1st screen
CALL wgotoxy(18, 7)
CALL wfgcolor(15)
CALL wwrite("Basic Windowing Toolbox Version 2.3")
CALL wgotoxy(15, 8)
CALL wfgcolor(7)
CALL wwrite("Compiled QuickBASIC Demonstration Program")
CALL wgotoxy(12, 9)
CALL wwrite("Source: QBDEMO.BAS Linked with: QBV4.OBJ")
CALL wgotoxy(50, 23)
CALL wwrite("Press any key to continue")
GOSUB keypress
' define 4 windows
wid% = 75: hgt% = 15: bdr% = w.true%
CALL wdef(wnum1%, wid%, hgt%, bdr%)
wid% = 70: hgt% = 20
CALL wdef(wnum2%, wid%, hgt%, bdr%)
wid% = 55: hgt% = 20
CALL wdef(wnum3%, wid%, hgt%, bdr%)
wid% = 38: hgt% = 12
CALL wdef(wnum4%, wid%, hgt%, bdr%)
' open window 1
x% = 0: y% = 9: btype% = w.dbln%: clr% = w.true%
CALL wopen(status%, wnum1%, x%, y%, clr%, wbgc1%, btype%, bfgc1%, bbgc1%)
' write in window 1
CALL wfgcolor(wtc1%)
CALL wbgcolor(wbgc1%)
CALL wgotoxy(0, 2)
CALL wwrite("Text can be ")
CALL wfgcolor(wtc1% + 16)
CALL wwrite("blinking, ")
CALL wfgcolor(15 + 16)
CALL wwrite("blinking bright, ")
CALL wfgcolor(wtc1%)
CALL wwrite("or just ")
CALL wfgcolor(15)
CALL wwrite("bright. ")
CALL wfgcolor(wtc1%)
CALL wwrite("All graphics card colors are also available. ")
IF stype% <> w.mono% THEN
' display colors
x% = 6: y% = 5
FOR y% = 5 TO 7
CALL wgotoxy(x%, y%)
FOR i% = 1 TO 15
CALL wfgcolor(i%)
CALL wwrite("████") 'ascii 219, which has no background
NEXT i%
NEXT y%
END IF
CALL wgotoxy(24, 10)
CALL wwrite("Press any key to continue")
GOSUB keypress
' open window 2
x% = 9: y% = 1
CALL wopen(status%, wnum2%, x%, y%, clr%, wbgc2%, btype%, bfgc2%, bbgc2%)
' write lots of text in window 2
CALL wfgcolor(wtc2%)
CALL wbgcolor(wbgc2%)
FOR i = 1 TO 70
CALL wwrite("Scrolling ")
CALL wfgcolor(15 + 16)
CALL wwrite("up ")
CALL wfgcolor(wtc2%)
CALL wwrite("in the window ")
NEXT i
dir% = 0: num% = 5
CALL wscroll(dir%, num%)
CALL wgotoxy(0, 17)
CALL wwrite("Press any key to continue")
GOSUB keypress
' open window 3
x% = 0: y% = 3: btype% = w.mxd1%: clr% = w.true%
CALL wopen(status%, wnum3%, x%, y%, clr%, wbgc3%, btype%, bfgc3%, bbgc3%)
' write to window 3
CALL wfgcolor(wtc3%)
CALL wbgcolor(wbgc3%)
CALL wgotoxy(1, 1)
CALL wwrite("You can define and edit fields:")
x% = 5
CALL wgotoxy(x%, 2)
CALL wwrite("- <CR> to finish with each field")
CALL wgotoxy(x%, 3)
CALL wwrite("- Arrow keys to move left and right")
CALL wgotoxy(x%, 4)
CALL wwrite("- HOME moves to string start")
CALL wgotoxy(x%, 5)
CALL wwrite("- END moves to string end")
CALL wgotoxy(x%, 6)
CALL wwrite("- DEL erases cursor position")
CALL wgotoxy(x%, 7)
CALL wwrite("- BACKSPACE deletes to left")
CALL wgotoxy(x%, 8)
CALL wwrite("- Auto erase if first key is text")
' define strings with optional initial value
s1$ = "Kenneth Page "
s2$ = "59 Beech Street "
s3$ = "Springfield, AZ 85999"
CALL wgotoxy(1, 10): CALL wwrite("Name:")
CALL wgotoxy(1, 12): CALL wwrite("Addr:")
CALL wgotoxy(1, 14): CALL wwrite("Addr:")
' set up string display colors
CALL wfgcolor(sfgc1%)
CALL wbgcolor(sbgc1%)
CALL wgotoxy(7, 10): CALL wwrite(s1$)
CALL wgotoxy(7, 12): CALL wwrite(s2$)
CALL wgotoxy(7, 14): CALL wwrite(s3$)
' size of editing field on screen is string length-1,
' so have at least one extra trailing space
s1$ = s1$ + " ": s2$ = s2$ + " ": s3$ = s3$ + " "
CALL wgotoxy(7, 10): CALL wgetstr(s1$)
CALL wgotoxy(7, 12): CALL wgetstr(s2$)
CALL wgotoxy(7, 14): CALL wgetstr(s3$)
' get rid of trailing NULL in strings
s1$ = LEFT$(s1$, INSTR(s1$, CHR$(0)) - 1)
s2$ = LEFT$(s2$, INSTR(s2$, CHR$(0)) - 1)
s3$ = LEFT$(s3$, INSTR(s3$, CHR$(0)) - 1)
CALL wfgcolor(wtc3%)
CALL wbgcolor(wbgc3%)
CALL wgotoxy(20, 17)
CALL wwrite("Press any key to continue")
GOSUB keypress
' open window 4
x% = 30: y% = 6: btype% = w.blkln%: clr% = w.true%
CALL wopen(status%, wnum4%, x%, y%, clr%, wbgc4%, btype%, bfgc4%, bbgc4%)
' write to window 4
CALL wfgcolor(wtc4%)
CALL wbgcolor(wbgc4%)
CALL wgotoxy(0, 1)
CALL wwrite("Type in characters. The lines auto-")
CALL wgotoxy(0, 2)
CALL wwrite("matically wrap-around when the right")
CALL wgotoxy(0, 3)
CALL wwrite("margin is reached. Carriage return")
CALL wgotoxy(0, 4)
CALL wwrite("causes scrolling. Press ")
CALL wfgcolor(15)
CALL wwrite("ESC ")
CALL wfgcolor(wtc4%)
CALL wwrite("to quit")
CALL wgotoxy(0, 6)
v$ = "x"
WHILE (ASC(v$) <> 27) '27 = ASCII value for ESCAPE character
GOSUB keypress
IF ASC(v$) <> 27 THEN
' character was <CR>? (ASCII 13)
IF ASC(v$) <> 13 THEN
CALL wwrite(v$)
ELSE
dir% = 0: num% = 1: CALL wscroll(dir%, num%)
CALL wgetcy(y%)
x% = 0: CALL wgotoxy(x%, y%)
END IF
END IF
WEND
' close window 4
CALL wclose
GOSUB keypress
' close window 3
CALL wclose
GOSUB keypress
' close window 2
CALL wclose
GOSUB keypress
' reopen window 2 at a different location
x% = 0: y% = 5: btype% = w.mxd2%: clr% = w.false%
CALL wopen(status%, wnum2%, x%, y%, clr%, wbgc2%, btype%, bfgc2%, bbgc2%)
GOSUB keypress
' close window 2 again
CALL wclose
GOSUB keypress
' close window 1
CALL wclose
GOSUB keypress
' clear screen
CALL winit(status%)
END
'***************
' KEYPRESS
' subroutine that waits for the next key press
'
keypress:
v$ = ""
WHILE v$ = ""
v$ = INKEY$
WEND
RETURN