Category : BASIC Source Code
Archive   : B-WINW.ZIP
Filename : QBDEMO.BAS

 
Output of file : QBDEMO.BAS contained in archive : B-WINW.ZIP



'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("- 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 ? (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



  3 Responses to “Category : BASIC Source Code
Archive   : B-WINW.ZIP
Filename : QBDEMO.BAS

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

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

  3. 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/