home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware 1 2 the Maxx
/
sw_1.zip
/
sw_1
/
PROGRAM
/
VUDU31Q.ZIP
/
VUDEMO.BAS
< prev
next >
Wrap
BASIC Source File
|
1992-06-07
|
21KB
|
684 lines
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
'* VUDEMO.BAS - VUDU Windows Demonstration Program *
'* *
'* Binary Systems *
'* PO BOX 10714 *
'* FARGO, ND 58106 *
'* (701) 281-2732 *
'* *
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
'$INCLUDE: 'VUDU.INC'
DECLARE SUB datedemo ()
DECLARE SUB overview ()
DECLARE SUB printdemo ()
DECLARE SUB randomtest ()
DECLARE SUB randscroll ()
DECLARE SUB windowdemo ()
DECLARE SUB windows ()
DECLARE SUB infielddemo ()
DECLARE SUB messagedemo ()
DECLARE SUB scrolldemo ()
DECLARE SUB bardemo ()
DECLARE SUB begin ()
DEFINT A-Z
CONST HEADLINE = "VUDU Windows Version 3.01 for QuickBASIC and PDS 7 ∙ Demo Program"
DIM SHARED background AS STRING
DIM lin(1 TO 3) AS STRING
' Attributes For Window Interactive Demo
DIM SHARED oldrow AS INTEGER, oldcol AS INTEGER
DIM SHARED oldwfg AS INTEGER, oldwbg AS INTEGER
DIM SHARED oldhedfg AS INTEGER, oldhedbg AS INTEGER
DIM SHARED oldshad AS INTEGER, oldedge AS INTEGER
' Type For INFIELD Specifications
TYPE fieldtype
row AS INTEGER
Col AS INTEGER
lng AS INTEGER
END TYPE
'Main Proc
VINIT ' call VINIT before executing any VUDU statements
' Setting the default values for the 'stretchy box' demo
oldrow = 22: oldcol = 76
oldhedfg = 15: oldhedbg = 1
oldwfg = 15: oldwbg = 1
oldshad = NO: oldedge = 2
FirstLet = CM(YEL + BRITE, WHT + BRITE + FLASH)
LabelPos = RIGHT
LOCATE , , 0 'Cursor off
SCREEN 0: WIDTH 80, 25 '25x80 text mode
' This is the whole program?
SAVSCREEN scr$
begin
RESCREEN scr$
lin(1) = " For ordering information, type out the file 'README'"
lin(2) = " Thank you for viewing VUDU Window Demo by Binary Systems."
lin(3) = " Good night and drive safely."
DEFWIN 0, 0, 0, 3, 0, 3, THIN, YES
a$ = MESSAGE(r, c, "", lin(), "", 10, YES)
PRINTS SPACE$(80), 25, 1, 0
LOCATE 25, 1, 1
END
' DATADATADATA - I Like To Keep My DATA Down Out Of The Way - DATADATADATA
menudata:
DATA Windows Overview, Windows Demonstration
DATA Barmenu Function Demo, ScrollMenu Function Demo
DATA Message Function Demo, Infield Function Demo, DatIn Demo
DATA Print Routines
DATA Random Pattern Generator,Random Scroll,Exit To Dos
barmenudata:
DATA Parameters
DATA The barmenu function accepts two arrays
DATA as parameters. The first contains the
DATA heading names that will appear above
DATA their respective menu. The second is a
DATA two dimensional array to contain the
DATA lists of items which appear under their
DATA respective headings.,,,,,,,,,,,,,,
DATA Headings
DATA You may pass as many menu headings
DATA as you can fit on the menu bar.
DATA you may also pass up to 22 items
DATA for each heading without shadows or
DATA 21 if you prefer shadows. Barmenu
DATA returns the subscript chosen and
DATA key the user entered to escape.,,,,,,,,,,,,,,
DATA Sizing
DATA The function automatically sizes
DATA everthing for you. The headers
DATA are spaced and the widths of the
DATA windows are set according to the
DATA widest item element. The header
DATA bar filler character is variable
DATA to suit different styles.,,,,,,,,,,,,,,
DATA Auto-adjust
DATA If you like your menu choices to be extremely descriptive -
DATA no problem! The bar menu function will automatically adjust
DATA your sub-menu to fit asthetically under the menu label. So
DATA use the whole screen if you wish! Hit ESC or ENTER for menu.
DATA Line 5
DATA Line 6
DATA Line 7
DATA Line 8
DATA Line 9
DATA Line 10
DATA Line 11
DATA Line 12
DATA Line 13
DATA Line 14
DATA Line 15
DATA Line 16
DATA Line 17
DATA Line 18
DATA Line 19
DATA Line 20
DATA Line 21
scrolldata:
DATA The scrollmenu function allows the user to choose from a list
DATA of items which would not normally fit within the boundaries
DATA of a window. The list may be as long as needed and the window
DATA may be as short as needed (minimum of one line).
DATA " MORE "
DATA " Scrolling of one full window length is done with the PgUp"
DATA and PgDn keys. the up and down cursor keys allow moving one
DATA line at a time.
DATA " "
DATA " The following is a demonstration of choosing an item from"
DATA the scrollmenu list. Press <ENTER> to continue
fielddata:
DATA 14,13,17, 14,36,10, 14,52,17
DATA 16,13,17, 16,36,10, 16,52,17
SUB bardemo
DIM headers(1 TO 4) AS STRING
DIM Items(1 TO 4, 1 TO 21) AS STRING
DIM scr AS STRING, retrn AS STRING
RESTORE barmenudata
FOR x = 1 TO 4
READ headers(x)
FOR y = 1 TO 21
READ Items(x, y)
NEXT y
NEXT x
RESCREEN background
DEFWIN 0, 0, 15, 3, 0, 3, THIN, YES
DEFBAR 0, 7, 205, NO
baron = NO
retrn = BARMENU(headers(), Items(), m, i)
SELECT CASE retrn
CASE ESC: retrn = "n escape keypress"
CASE CR: retrn = " carriage return"
END SELECT
DIM Msg(1 TO 1) AS STRING
Msg(1) = "You exited with a" + retrn
Msg(1) = Msg(1) + " and chose menu" + STR$(m) + ", item" + STR$(i) + "."
DEFWIN 15, 0, 15, 4, 14, 4, THIN, YES
Msg(1) = MESSAGE(14, c, "Message Box", Msg(), "", 5, YES)
END SUB
SUB begin
DIM win AS STRING, bar AS STRING, raise AS STRING
DIM fg AS INTEGER, bg AS INTEGER
DIM lin(1 TO 12) AS STRING
DIM clr AS STRING, vid AS STRING
'Create Opening Screen
DEFWIN 0, 0, 7, 1, 7, 1, NONE, NO
OPENWIN 1, 1, 25, 80, ""
'Lightning!
w$ = STRING$(15, 219)
var = 56
FOR x = 1 TO 25
IF x MOD 7 = 0 THEN var = var + 10
IF x > 21 THEN w$ = LEFT$(w$, LEN(w$) - 3)
IF x = 25 THEN var = var + 1
IF x < 25 THEN HILITE x + 1, var - x * 3 + 1, LEN(w$), 8
PRINTS w$, x, var - x * 3, CM(14, 7)
NEXT x
'Print Bottom Bar Labels
PRINTS SPACE$(80), 1, 1, ATTRIB(WHT + BRITE, MAG)
PRINTS HEADLINE, 1, 40 - LEN(HEADLINE) / 2, 0
'laser sound effect
PLAY "mf"
FOR x = 10000 TO 37 STEP -100
SOUND x \ 2, .03
SOUND x, .07
NEXT x
' *********************** FIRST WINDOW ***************************
lin(1) = " V U D U W I N D O W S Version 3.01 By Binary Systems"
lin(2) = " User interface and display tools for Microsoft BASICs"
lin(3) = " "
lin(4) = " Press Any Key For The Demonstration Program "
DEFWIN 15, 4, 15, 4, 14, 4, PAIR, YES
w$ = MESSAGE(r, c, "", lin(), "", 300, YES)
' ********************** SECOND MESSAGE ***************************
'message window describing VUDU
lin(1) = "VUDU (Very Useful Display Utilities) features:"
lin(2) = " Built in mouse support and mouse procedures"
lin(3) = " Automatic sensing of the active video page"
lin(4) = " Automatic sensing of monochrome/color card"
lin(5) = " Optional auto-centering for all windows"
lin(6) = " Auto snow elimination on CGA systems"
lin(7) = " Easy customization"
DEFWIN 15, 4, 15, 4, 14, 4, PAIR, YES
a$ = MESSAGE(0, 0, "The VUDU Windows", lin(), "", 15, YES)
' Print VIDEO INFORMATION
REDIM lin(1 TO 12) AS STRING
SELECT CASE VIDCARD
CASE MONO: lin(1) = "MonoChrome"
CASE CGA: lin(1) = "CGA"
CASE EGA: lin(1) = "EGA"
CASE VGA: lin(1) = "VGA"
END SELECT
lin(1) = lin(1) + " Video Card Detected"
IF Vmouse THEN
lin(2) = "Mouse is active"
ELSE
lin(2) = "Mouse not installed"
END IF
DEFWIN 0, 0, YEL + BRITE, 0, WHT + BRITE, 0, THIN, YES
a$ = MESSAGE(19, 42, "", lin(), "", 0, NO)
' Read Menu Data
RESTORE menudata
FOR x = 1 TO 11
READ lin(x)
NEXT x
' Begin the Menu Loop
DO
'DISPLAY MENU
LabelPos = LEFT
DEFWIN WHT + BRITE, 0, YEL + BRITE, 0, WHT + BRITE, 0, THIN, YES
a$ = MAKEMENU(3, 3, NO, "VUDU", lin(), selection)
SAVSCREEN background
IF a$ <> ESC THEN
SELECT CASE selection
CASE 1: overview
CASE 2: windowdemo
CASE 3: bardemo
CASE 4: scrolldemo
CASE 5: messagedemo
CASE 6: infielddemo
CASE 7: datedemo
CASE 8: printdemo
CASE 9: randomtest
CASE 10: randscroll
END SELECT
END IF
RESCREEN background
LOOP UNTIL a$ = ESC OR selection = 11
END SUB
SUB datedemo
DIM lin(1 TO 4) AS STRING
lin(1) = "MMDDYY"
lin(2) = "MMDDYYYY"
lin(3) = "YYMMDD"
lin(4) = "DDMMYY (Euro)"
LabelPos = CENTER
DEFWIN WHT + BRITE, RED, WHT + BRITE, RED, BLK, RED, THIN, YES
a$ = MAKEMENU(3, 50, NO, "Datin", lin(), selection)
IF a$ = ESC THEN EXIT SUB
REDIM lin(1 TO 1) AS STRING
lin(1) = "Input: Returned: "
a$ = MESSAGE(0, 0, "DATIN Function Demo", lin(), "", 0, NO)
LOCATE 13, 30: VCOLOR YEL + BRITE, BLK
a$ = DATIN(selection - 1)
IF (a$ <> ESC) THEN
PRINTS a$, 13, 51, 0
VSLEEP 3
END IF
END SUB
SUB infielddemo
DIM lin(1 TO 13) AS STRING
DIM fld(1 TO 6) AS fieldtype
DIM retrn AS STRING
RESCREEN background
LabelPos = CENTER
lin(1) = "The InField function does just as its name implies; it"
lin(2) = "allows user input within a specifically defined field"
lin(3) = "of the screen. A powerful alternative to INPUT$, InField"
lin(4) = "gives the programmer full control of the screen while"
lin(5) = "allowing the user full control of the cursor. Here are"
lin(6) = "some keys you may want to try in the demo fields:"
lin(7) = " "
lin(8) = "Enter, Home, End, Ins, Del, Back Space, Tab, Shift+Tab."
lin(9) = "Press the Esc key to end this part of the demo."
lin(10) = " ": lin(11) = " ": lin(12) = " ": lin(13) = " "
DEFWIN 15, 0, CM(4, 7), 0, 15, 0, ILINE, YES
a$ = MESSAGE(2, c, "Message Boxes", lin(), "", 0, NO)
'read in data for fields and hilite
RESTORE fielddata
VCOLOR CM(14, 0), CM(4, 7) ' Set global color
FOR x = 1 TO 6
READ fld(x).row
READ fld(x).Col
READ fld(x).lng
HILITE fld(x).row, fld(x).Col, fld(x).lng, 30
NEXT x
lin(1) = SPACE$(35): lin(2) = ""
'print returned values window
c = 0
a$ = MESSAGE(19, c, "Returned values", lin(), "", 0, NO)
PRINTS "Text Returned: ", 21, 25, CM(4, 7)
x = 1
DO
LOCATE fld(x).row, fld(x).Col
retrn = INFIELD(text$, fld(x).lng)
IF retrn <> ESC THEN
PRINTS SPACE$(17), 21, 41, 0
PRINTS text$, 21, 41, 0 'CM(14,7)
END IF
IF x = UBOUND(fld) THEN x = 1 ELSE x = x + 1
LOOP WHILE retrn <> ESC
LOCATE , , 0
END SUB
SUB messagedemo
DIM lin(1 TO 6) AS STRING
DEFWIN 0, 0, 0, BLU, 0, BLU, NONE, NO
OPENWIN 2, 1, 25, 80, ""
LabelPos = LEFT
DEFWIN 15, 0, 4, 0, 15, 0, ILINE, YES
lin(1) = "The Message Box is a multi-purpose display utility."
lin(2) = "With it you can create dialog boxes which simply"
lin(3) = "display a message to the user for a specified period"
lin(4) = "of time or until a key is pressed. This window will"
lin(5) = "be active for 15 seconds before continuing..."
a$ = MESSAGE(11, 3, "Message Boxes", lin(), "", 15, NO)
IF a$ = ESC THEN EXIT SUB
lin(1) = "You may also choose to create messages which require"
lin(2) = "input from the user before continuing. You pass"
lin(3) = "the possible keystrokes to the function and it"
lin(4) = "will display the message you specify and await one"
lin(5) = "of your keystrokes, returning it when it is encountered."
lin(6) = "For instance, press either 'Q' or 'Z' now..."
a$ = MESSAGE(7, 8, "Message Boxes", lin(), "QZ", 5, NO)
IF a$ = ESC THEN EXIT SUB
' IF A$ <> "" THEN
lin(1) = "Good, I see you found " + a$ + ". The Message function is a power-"
lin(2) = "ful addition to any program requiring user choices. The"
lin(3) = "Message function's capabilities are nicely enhanced when "
lin(4) = "used in conjunction with the INFIELD procedure."
lin(5) = ""
lin(6) = ""
a$ = MESSAGE(4, 13, "Message Boxes", lin(), CHR$(13), 5, NO)
' END IF
RESCREEN scr$
END SUB
SUB overview
DIM head(1 TO 6) AS STRING
DIM Msg(1 TO 7) AS STRING, Choice AS STRING, ret AS STRING
DIM colors(0 TO 4) AS INTEGER
colors(0) = 6
colors(1) = 2
colors(2) = 1
colors(3) = 5
colors(4) = 3
head(1) = "NONE"
head(2) = "THIN"
head(3) = "PAIR"
head(4) = "ILINE"
head(5) = "HLINE"
head(6) = "THICK"
RESCREEN background
FOR x = 0 TO 4
LabelPos = 4 - x
DEFWIN 15, colors(x), 15, colors(x), 15, colors(x), x + 1, YES
OPENWIN 3 + x * 2, 47 - x * 8, 11 + x * 2, 75 - x, head(x + 1)
NEXT x
Msg(1) = "Windows may be defined as having the shown border "
Msg(2) = "attributes. VUDU supports all colors in color text"
Msg(3) = "mode including blinking attributes. Other features"
Msg(4) = "are automatic horizontal and vertical positioning"
Msg(5) = "and optional transparent shadows. Labels may be pos-"
Msg(6) = "itioned centered, right or left offset on the upper"
Msg(7) = "border of the window."
DEFWIN 15, 4, 15, 4, 15, 4, THICK, YES
ret = MESSAGE(13, 11, head(6), Msg(), Choice, 20, YES)
IF ret = ESC THEN EXIT SUB
Msg(1) = "If your programs utilize the video paging feature of "
Msg(2) = "the color video cards, VUDU will write to the active"
Msg(3) = "video page. This allows writing to one page while"
Msg(4) = "viewing another. VUDU also automatically determines"
Msg(5) = "the installed video card and will perform snow"
Msg(6) = "checking if a CGA card is found."
Msg(7) = ""
DEFWIN 15, 2, 15, 2, 15, 2, THICK, YES
LabelPos = RIGHT
ret = MESSAGE(13, 11, head(6), Msg(), Choice, 20, NO)
END SUB
SUB printdemo
DIM lines(1 TO 10) AS STRING, rtn AS STRING, StrVar AS STRING
DIM row AS INTEGER, Col AS INTEGER
FOR x = 5 TO 10: lines(x) = " ": NEXT x 'Give spaces
lines(1) = "Syntax: PRINTS StrVar$, row%, col%, ColorAttribute%"
lines(2) = " PRINTV StrVar$, row%, col%, ColorAttribute%"
lines(3) = " "
lines(4) = "PRINTS displays a string in the horizontal position"
LabelPos = CENTER
DEFWIN 15, 4, 15, 4, 15, 4, THIN, YES
rtn = MESSAGE(r, Col, "PRINTS/PRINTV", lines(), "", 0, NO)
BRIDGE 12, Col, 68, 0
Col = Col + 5
FOR x = 1 TO 6
st$ = st$ + " Prints "
PRINTS st$, 12 + x, Col, x
NEXT x
VSLEEP 5
Col = Col - 2
PRINTS "PRINTV displays a string in the vertical position ", 11, Col, 0
FOR x = 1 TO 49
PRINTV "PRINTV", 13, Col + x, x
NEXT x
VSLEEP 5
END SUB
SUB randomtest
position = 2
counter = 100
DO
IF (counter = 100) THEN
counter = 0
PRINTS SPACE$(80), 25, 1, 63
PRINTS "Esc for menu", 25, position, 0
position = position + 1
IF (position = 69) THEN position = 2
END IF
counter = counter + 1
ulr = RND * 17: WHILE ulr < 1: ulr = RND * 17: WEND
lrr = RND * 24: WHILE lrr < ulr + 2: lrr = RND * 24: WEND
ulc = RND * 60: WHILE ulc < 1: ulc = RND * 60: WEND
lrc = RND * 79: WHILE lrc < ulc + 2: lrc = RND * 79: WEND
fore = RND * 15: back = RND * 7
DEFWIN 0, 0, fore + INT(RND * 2) * 16, back, fore, back, INT(RND * 6 + 1), (INT(RND * 2) - 1) * ((lrr < 24) * -1)
OPENWIN ulr, ulc, lrr, lrc, ""
LOOP WHILE (CLICK <> ESC)
randscroll
END SUB
SUB randscroll
direction = INT(RND * 4)
ScrollAttrib = CM(1, 7)
IF direction > RIGHT THEN
reps = 25
ELSE
reps = 80
END IF
FOR x = 1 TO reps
SCROLL 1, 1, 25, 80, direction
NEXT x
END SUB
SUB scrolldemo
DIM win AS STRING
DIM Items(1 TO 25) AS STRING
DIM tem(1 TO 1) AS STRING
DIM Choice AS INTEGER, row AS INTEGER, Col AS INTEGER
RESTORE scrolldata
FOR x = 1 TO 11
READ Items(x)
NEXT x
DEFWIN 1, 3, 1, 3, 1, 3, PAIR, YES
IF SCROLLMENU(0, 0, 5, YES, Items(), "The ScrollMenu Function", Choice) = ESC THEN
EXIT SUB
END IF
FOR x = 1 TO 25
Items(x) = " Item Number " + STR$(x) + " "
NEXT x
'pick an item scroll menu
DEFWIN 14, 0, 14, 0, 15, 0, ILINE, YES
IF SCROLLMENU(0, 0, 5, YES, Items(), "Scroll Choices", Choice) = ESC THEN
EXIT SUB
END IF
tem(1) = "You Chose " + LTRIM$(RTRIM$(Items(Choice)))
DEFWIN 14, 4, 14, 4, 14, 4, HLINE, YES
a$ = MESSAGE(row, Col, "Result", tem(), "", 3, YES)
END SUB
SUB windowdemo
DIM in AS STRING
LabelPos = LEFT
DEFWIN 15, 4, CM(15, 0), CM(1, 7), CM(15, 0), CM(1, 7), THIN, NO
OPENWIN 1, 1, 25, 80, "VUDU Window Interactive Demonstration"
'Print Prompts
PRINTS "Press:", 3, 5, 30
PRINTS "<H> To Change Header Color", 5, 5, 30
PRINTS "<F> To Change Foreground Color", 7, 5, 30
PRINTS "<B> To Change Background Color", 9, 5, 30
PRINTS "<A> To Change Border Attribute", 11, 5, 30
PRINTS "<S> To Toggle Shadows", 13, 5, 30
PRINTS "<> To Shrink Length", 15, 5, 30
PRINTS "<> To Expand Length", 17, 5, 30
PRINTS "<> To Shrink Width", 19, 5, 30
PRINTS "<" + CHR$(26) + "> To Expand Width", 21, 5, 30
PRINTS "<Esc> Return To Menu", 23, 5, 30
LabelPos = CENTER
endcol = oldcol: endrow = oldrow
wfg = oldwfg: wbg = oldwbg
HedFG = oldhedfg: HedBG = oldhedbg
edge = oldedge
shad = oldshad
winflag = TRUE
DO
IF endrow < oldrow THEN
PRINTS SPACE$(38), oldrow, 40, 16
IF oldshad THEN HILITE oldrow + 1, 42, 38, 16
END IF
IF endcol < oldcol THEN
PRINTV SPACE$(oldrow - 2), 3, oldcol, 16
IF shad THEN
HILITV 4, oldcol + 2, 20, 16
END IF
END IF
'Remove old shadow
IF shad <> oldshad AND shad = NO THEN
HILITE endrow + 1, 42, 38, 16
HILITV 4, endcol + 1, 20, 16
HILITV 4, endcol + 2, 20, 16
winflag = NO
END IF
oldwfg = wfg: oldwbg = wbg
oldhedfg = HedFG: oldhedbg = HedBG
DEFWIN HedFG, HedBG, wfg, wbg, wfg, wbg, edge, shad
IF winflag THEN OPENWIN 3, 40, endrow, endcol, "demo"
oldcol = endcol: oldrow = endrow
wfg = oldwfg: wbg = oldwbg
HedFG = oldhedfg: HedBG = oldhedbg
oldedge = edge
oldshad = shad
winflag = YES
'Process Users Key
IF Vmouse THEN
oldr = 13: oldc = 40
SETMOUSE oldr, oldc
DO
in = CLICK
IF (in = "") THEN
MOUSEXY mr, mc
IF (mr > oldr) THEN in = DnKey
IF (mr < oldr) THEN in = UpKey
IF (mc > oldc + 5) THEN in = RKey
IF (mc < oldc - 5) THEN in = LKey
IF (mr = 1) OR (mr = 25) OR (mc = 1) OR (mc = 80) THEN
SETMOUSE 13, 40: oldr = 13: oldc = 40: in = ""
END IF
END IF
LOOP WHILE (in = "")
oldr = mr: oldc = mc
ELSE
in = GETCH
END IF
in = UCASE$(in)
SELECT CASE in
CASE UpKey: endrow = endrow - 1 'Up Arrow
IF endrow < 5 THEN endrow = 5
CASE DnKey: endrow = endrow + 1 'Down Arrow
IF endrow > 22 THEN endrow = 22
CASE RKey: endcol = endcol + 1 'Right Arrow
IF endcol > 76 THEN endcol = 76
CASE LKey: endcol = endcol - 1 'Left Arrow
IF endcol < 53 THEN endcol = 53
CASE "H": HedFG = HedFG + 1
IF HedFG = 16 THEN
HedFG = 0: HedBG = HedBG + 1
IF HedBG = 8 THEN HedBG = 0
END IF
CASE "F": wfg = wfg + 1 'Foreground Attrib
IF wfg > 15 THEN wfg = 0
CASE "B": wbg = wbg + 1 'Background Attrib
IF wbg > 7 THEN wbg = 0
CASE "A": edge = edge + 1 'Edge Attribute
IF edge > 6 THEN edge = 1
CASE "S": shad = NOT shad 'Shadow Toggle
CASE ELSE: winflag = NO
END SELECT
IF ATTRIB(wfg, wbg) = 0 THEN wfg = 1
LOOP UNTIL in = ESC
END SUB