Shareware Supreme Volume 6 #1/swsii.zip/swsii/102/QBS-0102.ZIP/QBS102-4.DOC

Text File | 1993-03-24 | 43KB | 1,445 lines

════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3203
 Date:    02-11-93 11:52 (Public)
 From:    MARK BUTLER
 To:      RUSTY GORDON
 Subject: EditLine  1/2
────────────────────────────────────────────────────────────────────────────────
Once upon a time Rusty Gordon uttered these sage words to All:

 RG> ....how do I put a limit to the  number of characters the
 RG> user can enter as in the sample below:

 RG> Enter Feature Name ▒▒▒▒▒▒▒▒▒▒▒▒▒▒.

 I don't know about short but this'll work...

==========================8< Cut Here 8<=============================
DEFINT A-Z
DECLARE SUB EditLine (a$, exitCode)
DECLARE FUNCTION ScanCode ()

    CLS
    LOCATE 12, 1
    PRINT "Enter a 9 character string: ";
    a$ = SPACE$(9)
    COLOR 0, 7
    CALL EditLine(a$, exitCode)
    COLOR 7, 0
    PRINT
    PRINT
    PRINT "a$ = "; a$
    PRINT "exitCode ="; exitCode

    '*** 'exitCode%' will help you to discren whether the user wants
    '*** go back up to the field above, or the field below the current,
    '*** or abort without change etc etc.

SUB EditLine (a$, exitCode) STATIC
    CONST FALSE = 0, TRUE = NOT FALSE
    CONST BACKSPACE = 8
    CONST CTRLLEFTARROW = -115
    CONST CTRLRIGHTARROW = -116
    CONST CTRLY = 25
    CONST CTRLQ = 17
    CONST DELETEKEY = -83
    CONST DOWNARROW = -80
    CONST ENDKEY = -79
    CONST ENTER = 13
    CONST ESCAPE = 27
    CONST HOME = -71
    CONST INSERTKEY = -82
    CONST LEFTARROW = -75
    CONST RIGHTARROW = -77
    CONST TABKEY = 9
    CONST UPARROW = -72

    row = CSRLIN
    col = POS(0)
    length = LEN(a$)
    ptr = 0

    insirt = TRUE
    quit = FALSE
    original$ = a$

    DO
        LOCATE row, col, 0
        PRINT a$;
        IF insirt THEN
            LOCATE row, col + ptr, 1, 6, 7
        ELSE
            LOCATE row, col + ptr, 1, 1, 7
        END IF

        kee = ScanCode
        SELECT CASE kee
            CASE INSERTKEY
                IF insirt THEN
                    insirt = FALSE
                ELSE
                    insirt = TRUE
                END IF
            CASE BACKSPACE
                IF ptr THEN
                    a$ = a$ + " "
                    a$ = LEFT$(a$, ptr - 1) + MID$(a$, ptr + 1)
                    ptr = ptr - 1
                END IF
            CASE DELETEKEY
                a$ = a$ + " "
                a$ = LEFT$(a$, ptr) + MID$(a$, ptr + 2)
            CASE UPARROW
                exitCode = 1
                quit = TRUE
            CASE DOWNARROW
                exitCode = -1
                quit = TRUE
            CASE LEFTARROW
                IF ptr THEN
                    ptr = ptr - 1
                END IF
            CASE RIGHTARROW
                IF ptr < length - 1 THEN
                    ptr = ptr + 1
==========================8< Cut Here 8<=============================

 >>> continued to the next message

--- timEd/B7 * This is your eggs on fried drugs..er..uh..aw forget it.
 * Origin:  Terminal Oasis, Portland OR  (1:105/330.5)



════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3204
 Date:    02-11-93 11:56 (Public)
 From:    MARK BUTLER
 To:      RUSTY GORDON
 Subject: EditLine  2/2
────────────────────────────────────────────────────────────────────────────────
 >>> continued from the previous message

                END IF
            CASE ENTER
                exitCode = 0
                quit = TRUE
            CASE HOME
                ptr = 0
            CASE ENDKEY
                ptr = length - 1
            CASE CTRLRIGHTARROW
                DO UNTIL MID$(a$, ptr + 1, 1) = " " OR ptr = length - 1
                    ptr = ptr + 1
                LOOP
                DO UNTIL MID$(a$, ptr + 1, 1) <> " " OR ptr = length - 1
                    ptr = ptr + 1
                LOOP
            CASE CTRLLEFTARROW
                DO UNTIL MID$(a$, ptr + 1, 1) = " " OR ptr = 0
                    ptr = ptr - 1
                LOOP
                DO UNTIL MID$(a$, ptr + 1, 1) <> " " OR ptr = 0
                    ptr = ptr - 1
                LOOP
                DO UNTIL MID$(a$, ptr + 1, 1) = " " OR ptr = 0
                    ptr = ptr - 1
                LOOP
                IF ptr THEN
                    ptr = ptr + 1
                END IF
            CASE CTRLY
                a$ = SPACE$(length)
                ptr = 0
            CASE CTRLQ
                ctrlQflag = TRUE
            CASE ESCAPE
                a$ = original$
                ptr = 0
                insirt = TRUE
            CASE IS > 255
                SOUND 999, 1
            CASE IS < 32
                SOUND 999, 1
            CASE ELSE
                kee$ = CHR$(kee)
                IF insirt THEN
                    a$ = LEFT$(a$, ptr) + kee$ + MID$(a$, ptr + 1)
                    a$ = LEFT$(a$, length)
                ELSEIF ptr < length THEN
                    MID$(a$, ptr + 1, 1) = kee$
                END IF
                IF ptr < length THEN
                    ptr = ptr + 1

                ELSE
                    SOUND 999, 1
                END IF
                IF kee$ = "y" AND ctrlQflag THEN
                    IF ptr <= length THEN
                        sp = length - ptr + 1
                        MID$(a$, ptr, sp) = SPACE$(sp)
                        ptr = ptr - 1
                    END IF
                END IF
                ctrlQflag = FALSE
        END SELECT
    LOOP UNTIL quit
END SUB

FUNCTION ScanCode
    DO
        a$ = INKEY$
    LOOP WHILE a$ = ""
    IF ASC(LEFT$(a$, 1)) = 0 THEN
        ScanCode = -ASC(RIGHT$(a$, 1))
    ELSE
        ScanCode = ASC(a$)
    END IF
END FUNCTION
==========================8< Cut Here 8<=============================

  Hope this helps..

·∙■[-M-H-B-]■∙·

--- timEd/B7 * 186,000 miles/sec: Not just a good idea, it's the LAW.
 * Origin:  Terminal Oasis, Portland OR  (1:105/330.5)



════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3866
 Date:    02-13-93 12:36 (Public)
 From:    ROB MCKEE
 To:      ZACK JONES
 Subject: Help
────────────────────────────────────────────────────────────────────────────────
Hello Zack!
   You wrote in a message to Hugh Martin:

 ZJ> Howdy Hugh!

 ZJ> 08 Feb 93, Hugh Martin writes to Zack Jones:

 HM> You're funny, Zack.

 ZJ> I don't know 'bout that - considering some of the mail I've
 ZJ> gotten here lately. I wonder if there's a way to use an asm
 ZJ> routine to print 2000 characters and not scroll the screen?

 Yes, see below...

 ZJ> I'll ask Tom Hanlin over on BASNet and see what he says.

WHAT! When I'm here? Traitor <G> <giggle> ;)

Int 10 Func 9
    ' $INCLUDE: 'qbx.bi'
    DIM r AS RegType
    LOCATE 1, 1 ' can use this or INTERRUPT &h10 (r.ax=&h0200)
Char2Write% = 179 ' can be 0 to 255
      Page% = 0
      Attribute = 7
      CountOfrepeat = 1920             ' 2000 for full screen       r.ax =
&H9 * 256 + Char2Write%
      r.bx = Page% * 256 + Attribute
      r.cx = CountOfrepeat
      Interrupt &H10, r, r
      ' Returns None
    DO: IF INKEY$ = CHR$(27) THEN END
    : LOOP

 Catcha Later , I'll see you on the flip side - Rob


--- timEd/B6
 * Origin: Another Quik_Bas Point in Richmond, CA (1:125/411)


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3893
 Date:    02-12-93 08:58 (Public)
 From:    QUINN TYLER JACKSON
 To:      JOE NEGRON
 Subject: Version Numerology
────────────────────────────────────────────────────────────────────────────────
JN>QTJ> I've always wondered about releases in the hundredth.  .01 means what?

JN>The general practice seems to be that a change in the units
JN>(the "x" in "X.99") indicate a major new release; a change in
JN>the tenths indicate some added functionality (for example, PDS
JN>7.1 added a few features that PDS 7.0 did not have, like the
JN>REDIM PRESERVE, if I recall correctly); and a change in the
JN>hundredths digit indicates a bug fix, and possibly some minor
JN>added functionality.

I knew about this, but the convention seems different with many
developers.  I suppose the most important thing is that any given
company stick to the same schedule.  For instance, my company's policy
is as follows:

1.  Beta's of previously unreleased software are 0.00X
2.  Entirely new features and format changes are X.00
3.  Bug fixes are 0.X0
4.  Distribution changes are 0.0X.

Distrubution changes are changes in documenation or diskette order, but
not the actual software or support files.

Bug fixes are fixes of actual errors that can be isolated and
identified.  Their work around must NOT change database specs or
configuration files, otherwise this is a X.00 change.

New features are like adding Fidonet support to a mailer that never had
it before.

Format changes are like totally reworking a database spec so that
previous versions cannot read data or configurations files.

Using this system, it is assured that version 1.2 and version 1.9 are
fully compatible.  1.99 and 2.0 may not be, even though they are only a
hundredth apart.

This is how we decided it at the company's conception.  Now to actually
release something....

JN>Of course, some publishers use the version numbers as a sort of
JN>marketing tool.  For example, Microsoft added some pretty basic
JN>functionality to Word 4.0 and released it as Word 5.0; I think
JN>they did this to keep their version number "current" with
JN>WordPerfect 5.0.

It's been said that no one buys version 1.0 of anything.  So, a
developer may issue a limited release as 1.0, and then, make a few
changes here and there, and go an release 1.5, or even 2.0.


Quinn


 * SLMR 2.1a *

--- Maximus 2.01wb
 * Origin: VKUG/VPCC QuickBasic Echo - Richmond, BC (1:153/151)



════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4932
 Date:    02-13-93 19:39 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: Graphic Font Editor Part
────────────────────────────────────────────────────────────────────────────────
' Part 1 of 6 parts. This is the basic program. Remember to
' load it using qb/l. The program is a graphics Font editor
' that can be used in EGA or VGA screen modes. You will
' also need FONTGEN.DOC, SROMCHAR.BAS, and LOADFONT.BAS
' which will follow this 6 part Basic Pgm
     '$INCLUDE: 'qb.bi'
     DIM inregs AS REGTYPEX, outregs AS REGTYPEX
     DIM SCRN2(3584)
     DEF SEG = 0
     CLS
     INPUT "Keyboard or Mouse (K or M)? ", i$
     IF i$ = "K" OR i$ = "k" THEN flag$ = "":  ELSE flag$ = "mouse"
     CLS
     DEF SEG = VARSEG(SCRN2(0))
     V = VARPTR(SCRN2(0))
     BLOAD "ROMFONT.DAT", V
     SCREEN 9
     CLS
     KEY OFF
     DEFINT X-Y
     inregs.ax = &H1121
     inregs.cx = 14
     inregs.ES = VARSEG(SCRN2(0))
     inregs.BP = VARPTR(SCRN2(0))
     CALL interruptx(&H10, inregs, outregs)
     DEF SEG
     ON ERROR GOTO ErrorTrap
     DIM a(100)
     H = 280
     V = 168
     IF flag$ = "mouse" THEN
     GOTO JumpIfMouse
     END IF
     DRAW "bm80,164;r4;br2;bu2;u3;bd5;br2;r4;bl6;bd2;d3;"
     GET (78, 157)-(95, 171), a
     LINE (78, 157)-(95, 171), 0, BF
JumpIfMouse:
     LOCATE 6, 1
     COLOR 14
     PRINT "ROMFONT"
ReEntry3:
     n = 65
     KEY(10) ON
     ON KEY(10) GOSUB ExitPgm
     COLOR 12
     LOCATE 2, 29
     PRINT "EGA/VGA Font Editor"
     LOCATE 4, 32
     PRINT "ELM Software"
ReEntry1:
     LOCATE 2, 60
     COLOR 7
     PRINT "Enter=Accept New Char"

     LOCATE 4, 60
     PRINT "F10=Exit Pgm"
     LOCATE 6, 60
     PRINT "Minus=Prev char";
     LOCATE 8, 60
     PRINT "Plus=Next char";
     LOCATE 10, 60
     PRINT "D=Place Pixel";
     LOCATE 12, 60
     PRINT "E=Erase Pixel";
     LOCATE 14, 60
     PRINT "S=Save New Char Set";
     LOCATE 16, 60
     PRINT "C=Change ASCII Value";
     LOCATE 18, 60
     PRINT "L=Load New Char Set";
     LOCATE 20, 60
     PRINT "A=Current Char Set";
     LOCATE 22, 60
     PRINT "X=Clear Screen";
     LOCATE 2, 2
     COLOR 14
     PRINT CHR$(n)
'End of part 1 of 6

--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4933
 Date:    02-13-93 19:42 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: Graphic Font Editor part
────────────────────────────────────────────────────────────────────────────────
'Part 2 of 6 Font Editor
     LOCATE 4, 1
     COLOR 12
     PRINT n;
     COLOR 8
     FOR y = 90 TO 250 STEP 10
     LINE (1, y)-(161, y)
     NEXT
     FOR x = 1 TO 161 STEP 20
     LINE (x, 90)-(x, 250)
     NEXT
     FOR y = 90 TO 250 STEP 10
     LINE (220, y)-(380, y)
     NEXT
     FOR x = 220 TO 380 STEP 20
     LINE (x, 90)-(x, 250)
     NEXT
     LOCATE 19, 2: COLOR 14: PRINT "Template Character";
     LOCATE 19, 32: PRINT "Edit Character";
ReEntry2:
     FOR x = 8 TO 15
     FOR y = 14 TO 29
     IF POINT(x, y) = 14 THEN
     GOSUB AsciiToMainBitMap
     END IF
     NEXT
     NEXT
     IF flag$ = "mouse" THEN
     GOTO MainMouseRoutine
     END IF
KeyBoardWait:
     i$ = INKEY$
     PUT (H, V), a
     PUT (H, V), a
     IF i$ = "" THEN
     GOTO KeyBoardWait
     END IF
     AA = ASC(i$)
     IF AA = 0 THEN
     GOTO ArrowKeys
     END IF
     IF i$ = "=" OR i$ = "+" THEN
     GOSUB IncreaseAsciiValue
     END IF
     IF i$ = "-" OR i$ = "_" THEN
     GOSUB DecreaseAsciiValue
     END IF
     IF i$ = "D" OR i$ = "d" THEN
     PAINT (H + 2, V + 4), 2, 8
     END IF
     IF i$ = "E" OR i$ = "e" THEN
     PAINT (H + 2, V + 4), 0, 8
     END IF

     IF i$ = "S" OR i$ = "s" THEN
     GOSUB SaveNewCharSetToDisk
     END IF
     IF i$ = "C" OR i$ = "c" THEN
     GOTO ChangeAsciiValue
     END IF
     IF i$ = "L" OR i$ = "l" THEN
     GOTO LoadNewCharSet
     END IF
     IF i$ = "A" OR i$ = "a" THEN
     GOSUB ShowPresentCharSet
     END IF
     IF i$ = "x" OR i$ = "X" THEN
     ec = 1
     GOSUB ClearScreen
     END IF
     IF i$ = CHR$(13) THEN
     GOSUB UpdateArray
     END IF
     GOTO KeyBoardWait
ClearScreen:
     IF ec = 1 THEN ec = 0: GOTO EditOnly
     FOR x = 11 TO 151 STEP 20
     FOR y = 85 TO 250 STEP 10
' end of part 2 of 6

--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4934
 Date:    02-13-93 19:44 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: Graphic Font Editor part
────────────────────────────────────────────────────────────────────────────────
'Part 3 of 6 Font Editor
     PAINT (x, y), 0, 8
     NEXT: NEXT
EditOnly:
     FOR x = 230 TO 370 STEP 20
     FOR y = 85 TO 250 STEP 10
     PAINT (x, y), 0, 8
     NEXT: NEXT
     RETURN
ArrowKeys:
     IF ASC(MID$(i$, 2)) = 75 THEN
     H = H - 20
     END IF
     IF ASC(MID$(i$, 2)) = 77 THEN
     H = H + 20
     END IF
     IF ASC(MID$(i$, 2)) = 72 THEN
     V = V - 10
     END IF
     IF ASC(MID$(i$, 2)) = 80 THEN
     V = V + 10
     END IF
     IF H < 222 THEN
     H = 222
     END IF
     IF H > 362 THEN
     H = 362
     END IF
     IF V < 88 THEN
     V = 88
     END IF
     IF V > 238 THEN
     V = 238
     END IF
     GOTO KeyBoardWait
AsciiToMainBitMap:
     'transfer from ASCII char to main bit map
     PAINT (-150 + (x * 20), -45 + (y * 10)), 2, 8
     PAINT (65 + (x * 20), -45 + (y * 10)), 2, 8
     RETURN
ExitPgm:
     REM exit program
     DEF SEG
     SCREEN 0
     CLS
     END
IncreaseAsciiValue:
     REM increase ascii value
     n = n + 1
     IF n > 122 THEN n = 122
     GOSUB ClearScreen
     LOCATE 3, 2
     PRINT "              ";

     GOTO ReEntry1
DecreaseAsciiValue:
     REM decrease ascii value
     n = n - 1
     IF n < 48 THEN n = 48
     GOSUB ClearScreen
     LOCATE 3, 2
     PRINT "              ";
     GOTO ReEntry1
UpdateArray:
     REM Temp Save Routine to memory array only
     S = VARSEG(SCRN2(0))
     O = VARPTR(SCRN2(0))
     DEF SEG = S
     y = 85
IncrementVertical:
     y = y + 10
     IF y > 250 THEN
     GOTO ZeroCounter
     END IF
     x = 230
     IF POINT(x, y) = 2 THEN
     T = 128
     END IF
'end of part 3 of 6

--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4935
 Date:    02-13-93 19:46 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: Graphic Font Editor part
────────────────────────────────────────────────────────────────────────────────
' part 4 of 6 Font Editor
     x = 250
     IF POINT(x, y) = 2 THEN
     T = T + 64
     END IF
     x = 270
     IF POINT(x, y) = 2 THEN
     T = T + 32
     END IF
     x = 290
     IF POINT(x, y) = 2 THEN
     T = T + 16
     END IF
     x = 310
     IF POINT(x, y) = 2 THEN
     T = T + 8
     END IF
     x = 330
     IF POINT(x, y) = 2 THEN
     T = T + 4
     END IF
     x = 350
     IF POINT(x, y) = 2 THEN
     T = T + 2
     END IF
     x = 370
     IF POINT(x, y) = 2 THEN
     T = T + 1
     END IF
     POKE O + n * 14 + CT, T
     CT = CT + 1
     T = 0
     GOTO IncrementVertical
ZeroCounter:
     CT = 0
     DEF SEG
     LOCATE 2, 2
     PRINT "    ";
     COLOR 14
     LOCATE 2, 2
     PRINT CHR$(n);
     RETURN
SaveNewCharSetToDisk:
     REM Save New Char Set - Permanent Change to Disk
Input1:
     LOCATE 22, 2
     COLOR 14
     INPUT "File Name "; f$
     IF f$ = "romfont" OR f$ = "ROMFONT" THEN
     BEEP
     LOCATE 22, 2
     PRINT "                           ";
     GOTO Input1

     END IF
     IF LEN(f$) > 8 THEN
     BEEP
     LOCATE 22, 2
     PRINT "                         ";
     GOTO Input1
     END IF
     LOCATE 22, 2
     PRINT "                       ";
     DEF SEG = VARSEG(SCRN2(0))
     O = VARPTR(SCRN2(0))
     BSAVE f$ + ".dat", O, 3584
     DEF SEG
     RETURN
ChangeAsciiValue:
     REM Change ASCII Value
     LOCATE 2, 2
     PRINT "            ";
     LOCATE 4, 1
     PRINT "            ";
     GOSUB ClearScreen
Input2:
     LOCATE 22, 2
     COLOR 14
'end of part 4 of 6

--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4936
 Date:    02-13-93 19:48 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: Graphic Font Editor Part
────────────────────────────────────────────────────────────────────────────────
'Part 5 of 6 Font Editor
     INPUT "New ASCII Value"; i$
     n = VAL(i$)
     IF n < 48 OR n > 122 THEN
     LOCATE 22, 2
     PRINT "                     ";
     GOTO Input2
     END IF
     LOCATE 4, 1
     COLOR 12
     PRINT n;
     LOCATE 22, 2
     PRINT "                          ";
     LOCATE 2, 2
     COLOR 14
     PRINT CHR$(n);
     GOTO ReEntry2
LoadNewCharSet:
     REM Load New Char Set
     LOCATE 22, 2
     COLOR 14
     INPUT "File Name "; f$
     IF ASC(LEFT$(f$, 1)) > 90 THEN
     END IF
     LOCATE 22, 2
     PRINT "                           ";
     DEF SEG = VARSEG(SCRN2(0))
     V = VARPTR(SCRN2(0))
     BLOAD f$ + ".dat", V
     DEF SEG
     GOSUB ClearScreen
     H = 280
     V = 168
     LOCATE 6, 1
     PRINT "              ";
     LOCATE 6, 2
     PRINT UCASE$(f$);
     GOTO ReEntry3
ErrorTrap:
     REM On Error Routine
     RESUME LoadNewCharSet
ShowPresentCharSet:
PCOPY 0, 1
CLS : COLOR 14
FOR x = 48 TO 122
PRINT CHR$(x);
NEXT
HoldScrn:
     i$ = INKEY$
     IF i$ = "" THEN
     GOTO HoldScrn
     END IF
     PCOPY 1, 0

RETURN
MainMouseRoutine:
     inregs.ax = 0
     CALL interruptx(&H33, inregs, outregs)
     hmin% = 224
     hmax% = 375
     inregs.cx = hmin%
     inregs.dx = hmax%
     inregs.ax = 7
     CALL interruptx(&H33, inregs, outregs)
     vmin% = 92
     vmax% = 122
     inregs.cx = vmin%
     inregs.dx = vmax% * 2
     inregs.ax = 8
     CALL interruptx(&H33, inregs, outregs)
     inregs.cx = 0
     inregs.dx = 0
     inregs.ax = 4
     CALL interruptx(&H33, inregs, outregs)
MainMouseInkey:
     i$ = INKEY$
     inregs.ax = 1
     CALL interruptx(&H33, inregs, outregs)
'End of part 5 of 6

--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4937
 Date:    02-13-93 19:50 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: Graphic Font Editor part
────────────────────────────────────────────────────────────────────────────────
'Part 6 of 6 Font Editor
     inregs.ax = 3
     CALL interruptx(&H33, inregs, outregs)
     x = outregs.cx
     y = outregs.dx
     IF outregs.bx = 1 THEN
     inregs.ax = 2
     CALL interruptx(&H33, inregs, outregs)
     PAINT (x, y), 2, 8
     END IF
     IF outregs.bx = 2 THEN
     inregs.ax = 2
     CALL interruptx(&H33, inregs, outregs)
     PAINT (x, y), 0, 8
     END IF
     IF i$ = "-" OR i$ = "_" THEN
     inregs.ax = 2
     CALL interruptx(&H33, inregs, outregs)
     GOSUB DecreaseAsciiValue
     END IF
     IF i$ = "=" OR i$ = "+" THEN
     inregs.ax = 2
     CALL interruptx(&H33, inregs, outregs)
     GOSUB IncreaseAsciiValue
     END IF
     IF i$ = "a" OR i$ = "A" THEN
     inregs.ax = 2
     CALL interruptx(&H33, inregs, outregs)
     GOSUB ShowPresentCharSet
     END IF
     IF i$ = "c" OR i$ = "C" THEN
     inregs.ax = 2
     CALL interruptx(&H33, inregs, outregs)
     GOSUB ChangeAsciiValue
     END IF
     IF i$ = "l" OR i$ = "L" THEN
     inregs.ax = 2
     CALL interruptx(&H33, inregs, outregs)
     GOSUB LoadNewCharSet
     END IF
     IF i$ = "s" OR i$ = "S" THEN
     GOSUB SaveNewCharSetToDisk
     END IF
     IF i$ = "x" OR i$ = "X" THEN
     ec = 1
     inregs.ax = 2
     CALL interruptx(&H33, inregs, outregs)
     GOSUB ClearScreen
     END IF
     IF i$ = CHR$(13) THEN
     inregs.ax = 2
     CALL interruptx(&H33, inregs, outregs)
     GOSUB UpdateArray

     END IF
     IF i$ = "" THEN
     GOTO MainMouseInkey
     END IF
     GOTO MainMouseInkey
' Part 6 of 6 end of program

--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4938
 Date:    02-13-93 19:52 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: SROMCHAR.BAS (NEEDED FOR
────────────────────────────────────────────────────────────────────────────────
CLS
LOCATE 10, 20: PRINT "Searching for and saving EGA/ROM characters."
LOCATE 11, 32: PRINT "Please be patient."
DEF SEG = &HC000
FOR x = 0 TO 65525
p = PEEK(x)
IF p = &H7E AND PEEK(x + 1) = &H81 AND PEEK(x + 2) = &HA5 AND PEEK(x + 3) =
&H81 AND PEEK(x + 4) = &H81 AND PEEK(x + 5) = &HBD THEN GOTO savefont
NEXT
savefont:
DEF SEG = &HC000
BSAVE "romfont.dat", x - 16, 3584
LOCATE 13, 20: PRINT "EGA ROM characters captured to ROMFONT.DAT"
END


--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4939
 Date:    02-13-93 19:54 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: LOADFONT.BAS (NEEDED FOR
────────────────────────────────────────────────────────────────────────────────
'$INCLUDE: 'qb.bi'
 DIM inregs AS RegTypeX, outregs AS RegTypeX
 DIM scrn2(3584)
 SCREEN 9: REM can also be screen 12 or 13 if you have VGA
 DEF SEG = VARSEG(scrn2(0))
 v = VARPTR(scrn2(0))
 ' You will want to replace "romfont.dat" with your new fonts
 BLOAD "romfont.dat", v
 inregs.ax = &H1121
 inregs.cx = 14
 inregs.es = VARSEG(scrn2(0))
 inregs.bp = VARPTR(scrn2(0))
 CALL INTERRUPTX(&H10, inregs, outregs)
 DEF SEG
 'Your Program would start here
 PRINT "This is A Test AAA 1234567890."
 PRINT "ABCDEFGHIJKLMNOPQRSTUVWXYZ earl montgomery";
HoldScreen:
 GOTO HoldScreen


--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5050
 Date:    02-11-93 18:40 (Public)
 From:    JOHN GALLAS
 To:      JAMES ZMIJEWSKI
 Subject: SOUND BLASTER         1/2
────────────────────────────────────────────────────────────────────────────────
JZ>Does anyone out there know how to use Qbasic to drive the sound blaster.
JZ>I'm just begining to get back in to programing and looking at the online
JZ>help I can't find any acess routines that look appropriate.
JZ>        In the future I would like to upgrade to a higher language Quick
JZ>basic or visual basic, which would you recomend.

Heres a program to play the SB:

-------------------------------<cut here>-----------------------------

' SBSOUND.BAS by Brett Levin 1992
'
'  These routines were made entirely from a pretty detailed (techie, but
' not that I mind <G>) text file on programming the FM ports on the AdLib/SB.
'  You are free to use this in any program what so ever, as long as you
' give credit where credit is due.. (stole that line from Rich!) :)

DEFINT A-Z
DECLARE FUNCTION DetectCard% ()
DECLARE SUB SBInit ()
DECLARE SUB WriteReg (Reg%, Value%)
DECLARE SUB SBPlay (note%)

CONST false = 0, true = NOT false

SCREEN 0: CLS

IF DetectCard = true THEN
  PRINT "AdLib-compatible sound card detected."
ELSE
  PRINT "Unable to find/detect sound card."
  BEEP
  SYSTEM
END IF
PRINT " Initalizing...";

SBInit

PRINT " Done."

FOR nt = 0 TO 255
SBPlay nt
NEXT nt

PRINT
PRINT "  These routines only support one channel/voice of the FM chip, but"
PRINT "eventually I may fix them so you can have a bunch o' instruments on"
PRINT "at once.  I'd also like to write a replacement for SBFMDRV.COM, but"
PRINT "that's far off, and probably not in QB anyway.  This is too fast"
PRINT "compiled, so if you are going to use it in anything, add a delay."
PRINT "                                  Enjoy!         -Brett 11/12/92"
PRINT


FOR nt = 255 TO 0 STEP -1
SBPlay nt
NEXT nt

PRINT "[Press any key to end]"
SLEEP

CALL WriteReg(&HB0, &H0)  'Makes sure no extra sound is left playing

FUNCTION DetectCard%

'  Purpose:   Detects an AdLib-compatible card.
'             Returns -1 (true) if detected and 0 (false) if not.
'  Variables: Nope

CALL WriteReg(&H4, &H60)
CALL WriteReg(&H4, &H80)
B = INP(&H388)
CALL WriteReg(&H2, &HFF)
CALL WriteReg(&H4, &H21)
  FOR x = 0 TO 130
    A = INP(&H388)
  NEXT x
C = INP(&H388)
CALL WriteReg(&H4, &H60)
CALL WriteReg(&H4, &H80)
Success = 0
IF (B AND &HE0) = &H0 THEN
  IF (C AND &HE0) = &HC0 THEN
    Success = -1
  END IF
END IF
DetectCard% = Success

END FUNCTION

SUB SBInit
'  Initialize the sound card

'(This is the "quick-and-dirty" method; what it's doing is zeroing out
'  all of the card's registers.  I haven't had any problems with this.)

FOR q = 1 TO &HF5
  CALL WriteReg(q, 0)
NEXT q

END SUB

SUB SBPlay (freq%)

'  Purpose:      Plays a note

'  Variables:    freq% - Frequency (00-FF hex)

'                duration% - Duration (n seconds) (not used)

'  I'm still working on this part, it may be ugly, but it works <g>.
'  The first group of WriteRegs is the modulator, the second is the
'  carrier.
'  If you just want to know how to create your own instrument, play around
'  with the second values in the first four calls to WriteReg in each group.
'  :-)  Have fun!  - Brett

CALL WriteReg(&H20, &H7)    ' Set modulator's multiple to F
CALL WriteReg(&H40, &HF)    ' Set modulator's level to 40 dB
CALL WriteReg(&H60, &HF0)   ' Modulator attack: quick, decay: long
CALL WriteReg(&H80, &HF0)   ' Modulator sustain: medium, release: medium
CALL WriteReg(&HA0, freq%)


CALL WriteReg(&H23, &HF)   ' Set carrier's multiple to 0
CALL WriteReg(&H43, &H0)   ' Set carrier's level to 0 dB
CALL WriteReg(&H63, &HF0)  ' Carrier attack: quick, decay: long
CALL WriteReg(&H83, &HFF)  ' Carrier sustain: quick, release: quick
CALL WriteReg(&HB0, &H20)  ' Octave

CALL WriteReg(&HE0, &H0)   ' Waveform argument for Tom..
                           ' &H00 is the default, but I felt like
                           ' dropping it in for you.. :)

' I originally had an extra argument, duration!, but for some reason
' I wanted to do the timing outside of this sub..  You can change it back
' if needs require..

'TimeUp! = TIMER + duation!
'WHILE TimeUp! > TIMER: WEND  ' Worst you can be off is .182 of a second

END SUB
>>> Continued to next message

 * OLX 2.1 TD * Connection Attempt #172 ..<ring>...CONNECT 300...<CLICK>

--- TMail v1.30.4
 * Origin: TC-AMS MLTBBS 2.2 - Minnetonka, MN (612)-938-4799 (1:282/7)



════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5051
 Date:    02-11-93 18:40 (Public)
 From:    JOHN GALLAS
 To:      JAMES ZMIJEWSKI
 Subject: SOUND BLASTER         2/2
────────────────────────────────────────────────────────────────────────────────
>>> Continued from previous message
SUB WriteReg (Reg%, Value%)
'  Purpose:   Writes to any of the SB/AdLib's registers
'  Variables: Reg%: Register number,
'             Value%: Value to insert in register
'              (Note: The registers are from 00-F5 (hex))
OUT &H388, Reg     '388h = address/status port, 389h = data port
  FOR x = 0 TO 5   ' This tells the SB what register we want to write to
    A = INP(&H388) ' After we write to the address port we must wait 3.3ms
  NEXT x

OUT &H389, Value   ' Send the value for the register to 389h
  FOR x = 0 TO 34  ' Here we must also wait, this time 23ms
    A = INP(&H388)
  NEXT x

END SUB

---------------------------<clip here>-------------------------

That program will produce a motorcycle engine effect.  I do have code
that will play a frequency (from 0 to 800 I believe) on any of 11
octaves, and I'm waiting for the authors permission to post it.

By the way, we've had quite a few people with names that have been tough
to pronounce in the past few weeks, but yours tops them all!  Can ya
give me a hint?  It looks like Zem-ij-ew-sky - am I close?

 * OLX 2.1 TD * Connection Attempt #172 ..<ring>...CONNECT 300...<CLICK>

--- TMail v1.30.4
 * Origin: TC-AMS MLTBBS 2.2 - Minnetonka, MN (612)-938-4799 (1:282/7)



════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5055
 Date:    02-11-93 18:29 (Public)
 From:    JOHN GALLAS
 To:      OWEN GIBBINS
 Subject: FILE HANDLING
────────────────────────────────────────────────────────────────────────────────
OG>Are there any functions in QuickBASIC similar to the EXIST and NOT EXIST
OG>functions in batch files?

Yes!  Try the following...

'=========================================================================
'DIR.BAS by Dave Cleary
'
'One of the most useful additions to BASIC 7 PDS is the DIR$ function.
'This function allows you to read a directory of filenames. It also
'allows you to check the existence of a file by doing the following:
'
'  IF LEN(DIR$("COMMAND.COM")) THEN
'     PRINT "File Found"
'  ELSE
'     PRINT "File not found"
'  END IF
'
'Now QuickBASIC 4.X users can have this useful function for their
'programs.
'
'Calling DIR$ with a FileSpec$ returns the the name of the FIRST
'matching file name. Subsequent calls with a null FileSpec$ return the
'NEXT matching file name. If a null string is returned, then no more
'matching files were found. FileSpec$ can contain both a drive and a
'path plus DOS wildcards. Special care should be taken when using
'this on floppy drives because there is no check to see if the drive
'is ready.
'========================================================================
     DEFINT A-Z

     DECLARE FUNCTION DIR$ (FileSpec$)

     '$INCLUDE: 'QB.BI'

     '-----  Some constants that DIR$ uses
     CONST DOS = &H21
     CONST SetDTA = &H1A00, FindFirst = &H4E00, FindNext = &H4F00

     '--------------------------------------------------------------------
     'This shows how to call DIR$ to find all matching files

     'CLS
     'FileSpec$ = "C:\QB\SOURCE\*.BAS"
     'Found$ = DIR$(FileSpec$)
     'DO WHILE LEN(Found$)
     '   PRINT Found$
     '   Found$ = DIR$("")
     'LOOP

     '--------------------------------------------------------------------

 FUNCTION DIR$ (FileSpec$) STATIC


        DIM DTA AS STRING * 44, Regs AS RegTypeX
        Null$ = CHR$(0)

     '-----  Set up our own DTA so we don't destroy COMMAND$
        Regs.AX = SetDTA                    'Set DTA function
        Regs.DX = VARPTR(DTA)               'DS:DX points to our DTA
        Regs.DS = -1                        'Use current value for DS
        InterruptX DOS, Regs, Regs          'Do the interrupt

     '-----  Check to see if this is First or Next
        IF LEN(FileSpec$) THEN              'FileSpec$ isn't null, so
                                            'FindFirst
           FileSpecZ$ = FileSpec$ + Null$   'Make FileSpec$ into an ASCIIZ
                                            'string
           Regs.AX = FindFirst              'Perform a FindFirst
           Regs.CX = 0                      'Only look for normal files
           Regs.DX = SADD(FileSpecZ$)       'DS:DX points to ASCIIZ file
           Regs.DS = -1                     'Use current DS
        ELSE                                'We have a null FileSpec$,
           Regs.AX = FindNext               'so FindNext
        END IF

        InterruptX DOS, Regs, Regs          'Do the interrupt

     '-----  Return file name or null
        IF Regs.Flags AND 1 THEN            'No files found
           DIR$ = ""                        'Return null string
        ELSE
           Null = INSTR(31, DTA, Null$)     'Get the filename found
           DIR$ = MID$(DTA, 31, Null - 30)  'It's an ASCIIZ string starting
        END IF                              'at offset 30 of the DTA

 END FUNCTION

 * OLX 2.1 TD * He's not dead, Jim, he's metaphysically challenged.

--- TMail v1.30.4
 * Origin: TC-AMS MLTBBS 2.2 - Minnetonka, MN (612)-938-4799 (1:282/7)



════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5143
 Date:    02-13-93 03:24 (Public)
 From:    SEAN SULLIVAN
 To:      ALL
 Subject: Moving Clock Screen Saver
────────────────────────────────────────────────────────────────────────────────
Greetings and Salutations All!


This is something I whipped up out of boredom.   Feel free to do what you
wish with it.  This means you too, Lee.


----------------8<  cut here >8--------------------------------------------
':::::::::::: MOVING CLOCK SCREEN BLANKER :::::::::::::::::
'Written by: Sean P. Sullivan
'            February 13, 1993
'
'A simple screen blanker routine. It will display the
'current time, moving it's position once every second.
'It is currently set to run using SCREEN 1 to take
'advantage of the larger characters.  See program comments
'on how to change to different screens.
'This should work on most BASICS from GW to VB.
'
'This code is released to the public domain.
'It may be printed, used, changed, whatever.
'Printable in QBS: YES!
'
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

DEFINT A-Z
'---- starting row ----
  row = 1
'---- starting col ----
  col = 1
'---- screen mode (default 1-CGA) ----
  scrn = 1
'---- # cols for SCREEN mode, subtract 14 from max cols ----
'---- to prevent clock from printing off screen         ----
'---- ie:  CGA  max cols=40, so clim=39-14 or 25        ----
  clim = 25
'---- # rows for SCREEN mode, usually always 23 ----
  rlim = 23
'---- freq of clock update (default=1 sec) ----
  freq = 1


'start TIMER
  TIMER ON

'set screen mode
  SCREEN scrn

'for every change in the timer by the freq amount gosub ShowClock
  ON TIMER(freq) GOSUB ShowClock

'loop until a key is pressed
DO

  LOOP WHILE INKEY$ = ""
END

'turn timer off and exit program
TIMER OFF
END


'Show clock subroutine
ShowClock:

'clear out old clock position
  LOCATE row, col: PRINT SPACE$(14)
'find new row position between 0-23
  row = 99
  DO WHILE row > rlim
     row = INT(RND(1) * 100) + 1
  LOOP
'find new column position between 0-25
  col = 99
  DO WHILE col > clim
     col = INT(RND(1) * 100) + 1
  LOOP
'print clock at new position
  LOCATE row, col: PRINT "Time: "; TIME$
  RETURN

------------------------8< cut here >8--------------------------------

Sean

--- GoldED 2.40.P0623
 * Origin: COMNET Point #28 [Watervliet, NY] (1:267/113.28)



════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5744
 Date:    02-14-93 10:11 (Public)
 From:    RICHARD DALE
 To:      ALL
 Subject: Choose file from screen
────────────────────────────────────────────────────────────────────────────────
I forgot who was asking for it, but here is a method of choosing a
filename from the screen.

It's in numbered-line BASIC, but it should be simple enough to convert
over to QuickBASIC.  I keep meaning to do it, but never get a
round tuit.


9010 CLS:COLOR 14,0:FILES "*.*"
9020 FOR GX = 2 TO 22: IF SCREEN(GX, 1) = 32 THEN GL = GX - 1:
     LOCATE GX,1: PRINT SPACE$(20): PRINT SPACE$(20): GOTO 9030
9030 NEXT GX: GROW = 2: GCOL = 1: COLOR 3, 0: LOCATE 23, 9:
     PRINT "<- This file?  Use arrow keys to select, <R> to Recall,
     or <ESCAPE>"
9040 IF SCREEN(GROW,GCOL) = 32 THEN 9120
9050 GFILE$ = "": FOR GX = 0 TO 11: GFILE$ = GFILE$ + CHR$(SCREEN(GROW,
     GCOL + GX)): NEXT GX
9060 COLOR 0,7: LOCATE GROW, GCOL + 13: PRINT "<-": COLOR 14, 0:
     LOCATE 23, 1: PRINT LEFT$(GFILE$, 8)
9070 GKEY$ = RIGHT$(INKEY$, 1): IF GKEY$ = "" THEN 9070
9080 IF GKEY$ = CHR$(27) THEN GFILE$ = "": GOTO 9170
9090 IF GKEY$ = "R" OR GKEY$ = "r" THEN 9170
9100 IF INSTR("HPKM", GKEY$) = 0 THEN 9070
9110 LOCATE GROW, GCOL + 13: PRINT SPACE$(2);
9120 IF GKEY$ = "H" THEN GROW = GROW - 1: IF GROW < 2 THEN GROW = GL
9130 IF GKEY$ = "P" THEN GROW = GROW + 1: IF GROW > GL THEN GROW = 2
9140 IF GKEY$ = "K" THEN GCOL = GCOL - 18: IF GCOL < 1 THEN GCOL = 55
9150 IF GKEY$ = "M" THEN GCOL = GCOL + 18: IF GCOL > 55 THEN GCOL = 1
9160 GOTO 9040
9170 RETURN


Day 22: America Held Hostage

 * DeLuxe2 1.26b #2989 * Bill Clinton:  The Dan Quayle of Presidents
--- FidoPCB v1.4 beta
 * Origin: Sound Advice - 24 Nodes [phone] (1:280/333)



════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5983
 Date:    02-10-93 11:19 (Public)
 From:    FRANCOIS ROY
 To:      TRENT SHIRLEY
 Subject: CD-ROM RECOGNITION
────────────────────────────────────────────────────────────────────────────────
You can use CALL INTERRUPT to read the ISO-9660 sectors via MSCDEX.  The VTOC
(Volume Table of Contents) is accessible as shown below; I don't have its
structure so can't tell you what the fields mean, but I can betcha no two are
alike... the VTOC is a 2048-byte string; I defined my buffer in CDVTOC with a
length of 4096 because for some reason 2048 gives me String Space Corrupt
errors... the demo routine below prints the first 800 bytes of the VTOC but
you may want to store the whole 2048 bytes as the CD's "fingerprint".

The code snippet below is for QB; QBX far strings need a small alteration.

DECLARE SUB CDVTOC (D$, V$)
DECLARE SUB CDDRIVE (DR$)
   TYPE REGTYPE  ' For CALL INTERRUPT
     AX AS INTEGER
     BX AS INTEGER
     CX AS INTEGER
     DX AS INTEGER
     BP AS INTEGER
     SI AS INTEGER
     DI AS INTEGER
     FL AS INTEGER
     DS AS INTEGER
     ES AS INTEGER
   END TYPE
   DIM SHARED INR AS REGTYPE, OUR AS REGTYPE
   CALL CDDRIVE(D$)
   PRINT "Drive:"; D$
   CALL CDVTOC(D$, V$)
   PRINT LEFT$(V$, 800)
   END

SUB CDDRIVE (DR$) STATIC
    DR$ = STRING$(32, 0)
    INR.AX = &H150D
    INR.BX = SADD(DR$)
    INR.ES = SSEG(DR$)
    CALL InterruptX(&H2F, INR, OUR)
    IF ASC(DR$) = 0 THEN DR$ = "" ELSE DR$ = CHR$(ASC(DR$) + 65) + ":"
END SUB

SUB CDVTOC (D$, V$) STATIC
REM Reads VTOC
    DR$ = STRING$(4096, 0)
    INR.AX = &H1505
    INR.BX = SADD(DR$)
    INR.CX = INSTR("ABCDEFGHIJKLMNOP", LEFT$(D$, 1)) - 1
    INR.DX = 0  ' 1st volume descriptor
    INR.ES = SSEG(DR$)
    CALL InterruptX(&H2F, INR, OUR)
REM AX=1 is normal and indicates a standard vol. descr.
REM AX=15 is 'Invalid Drive' and 21 is 'Not Ready'. 255 means no vol. desc.
    IF OUR.AX > 1 THEN V$ = "Error" + STR$(OUR.AX) ELSE V$ = DR$
END SUB


--- ME2_1104
 * Origin: Out of String Space - the Final Frontier (Fidonet 1:163/506.2)