home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Supreme Volume 6 #1
/
swsii.zip
/
swsii
/
102
/
QBS-0101.ZIP
/
QBS-0101.DOC
< prev
next >
Wrap
Text File
|
1993-01-04
|
218KB
|
6,110 lines
------------------------------------------------------------------------
The QuickBASIC Scrapbook QUIK_BAS
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
QuickBASIC Scrapbook is produced by Quantum Software
(C)Copyright 1993 by Lee Madajczyk
Licensed to Quantum Software
*** ALL INFORMATION CONTAINED IN THE QUICKBASIC SCRAPBOOK
IS PUBLIC DOMAIN. ALL INFORMATION COMPILED IN THIS
SCRAPBOOK WAS ORIGINALLY POSTED ON THE QUIK_BAS ECHO,
FIDO-NET SYSTEMS. DATE, TIME, AND AUTHOR'S NAME HAVE
BEEN PRESERVED.
Special thanks to all those who have contributed or have
a published letter or reply. Without your help, this
would not have been possible.
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
Editor's Article
Welcome to The QuickBASIC Scrapbook! QBS is a publication devoted
to providing you with the most up-to-date information available, by
using the QUIK_BAS echo of FidoNet and compiling important messages
and programs posted in QUIK_BAS echo. Quantum Software distribution
sites are listed in the file DISTSITE.QS. If you would like to
become a distribution site, please see SITE_APP.QS. Thank you for
your co-operation. Due to a time crunch, I cannot provide an index
or table of contents. One will be included in the nest issue. An
index for this issue may also be distributed with the next issue.
Remember! A disk subscription is available for only $19.95! This
subscription not only gives you the normal six issues ONE WEEK
ahead of BBS releases, but gives you a special seventh issue not
released to the public. Subscription information can be found in
the SUBSCRBE.QBS file.
This Month: Rich Geldreich's PC-Speaker MOD player, registration
encoding, errorlevel reading, loading PCX files, existing file
check, and more!
Thank you for getting this file!
Contact Information:
U.S. Mail Netmail:
Quantum Software Lee Madajczyk
Lee Madajczyk Infinity (1:280/5)
8012 Cottonwood
Lenexa, KS 66215-4165 (816)761-0860
ATTN: QB Scrapbook Kansas City, MO
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
P r o d u c t R e v i e w
UI4QB
UI4QB is the ultimate in user interfaces! After reviewing the program
for only a few days, I must say it is nothing short of impressive. Of
course, I did register the program back in August, but I thought that
it would be best to review it for you anyway. Microsoft originally
made the program, but it was for the PDS system. Author William Cobb
then redeveloped the program and set it up for use with QuickBASIC.
I have called Microsoft many times and they assured me that William
Cobb's switching between languages and releasing the program is
completely legal. The number for you to call is (800) 426-9400. Press
(2) for Developer's Assistance. I am assuming that you are at least
halfway familiar with the QuickBASIC interface. Cobb's UI4QB can make
you program use menus that look just like QB's. You can also
* Change colors of the menus
* Open multiple, moving windows
* Use built-in mouse support
* Supports B/W and EGA / VGA systems
* Interface with the DOS directories
* Pop up option boxes, shadowed boxes
* More!
The only problem I had with UI4QB was reading the manual. The manual
can stand a little refinement, but as it stands it is fine. Seasoned
programmers can easily pick up on the variables, while the newer
people may have trouble. At first. You get use to it. Trust me. I
should know. The author is rumored to be working on a new release.
The registration price? Only 15 dollars. The current version is
UI4QB 1.1a, and can be F'REQed from:
Infinity (816)761-0860 (1:280/5)
Filename: UI4QB11A.*
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
═════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #19212
Date: 12-05-92 12:47 (Public)
From: JOHN GALLAS
To: SUNNY HUGHES
Subject: Bload File Format?
─────────────────────────────────────────────────────────────────────
SH>Does anyone have the format for a Bsaved file... From what I understand
SH>from the on-line help in QB, you should be able to load in a Bsaved file
SH>from and standard I/O device minus the keyboard. What I'm trying to do is
SH>send a Bsaved file with a binary protocol throught the modem and read it
SH>and load it and display it on the remote end. I know I'd have to parse
SH>the input for the beginning of the file then load it, but from there I'm
SH>lost. Does this even sound like a god idea or can someone come up with a
SH>more efficient way of doing it without having to resort to a the remote
SH>user having to have all the Bsaved files on their end with the terminal?
Sure..
The first 7 bytes are some kind of BSave signature that you can ignore.
Then the next 4000 bytes are the actual screen. 2000 bytes for the
text, and 2000 bytes for the colors. The first of the 4000 (8th in the
file) is the character in the upper left hand corner. The next byte is
that charactes attribute. Then the next character, and its attribte.
Heres some code to read in a bsave file and print it to the screen:
open "filename" for binary as #1
x$ = space$(7) 'make a dummy buffer to read in the first 7 bytes
get #1,,x$ 'read it in and don't do anything with it
x$=" " 'now set the buffer size to 1 byte
pointer = 0 'the screen pointer we're using
def seg = &HB800 'b000 for mono
do until eof(1)
get #1,,x$
poke pointer, asc(x$)
pointer=pointer+1
loop
def seg
close #1
This should be pretty slow (*definatly* waaay slower than Bload) but it
will get the job done. Another thing you could consider doing is saving
the 4000 screen bytes into an array of integers, and then using a
movbytes routine to print them to the screen *instantly*. I think Mark
Butler posted a movbytes routine, you can ask him for it if you're
interested.
* OLX 2.1 TD * Do you expect my opinion to be swayed by mere PROOF?
--- RyPacker v2.5b
* Origin: The Ghost Mode - An RyBBS System! (612)-688-0026 (1:282/3006)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #19480
Date: 12-06-92 08:44 (Public)
From: EARL MONTGOMERY
To: ALL
Subject: Animation
────────────────────────────────────────────────────────────────────────────────
' Here is another version of a previous post. This one includes a text
' scroll:
DEFINT A-Z: SCREEN 7: CLS : x = 60: pg = -1: v = 118: h = 30: up = 23
Q$ = "E2U2R1U4H2R3U1D1R2U1D1R3G2D4R1D2F2L10"
n$ = "E2U1E2U2G2L1H1U1E4R3F2D4G1D2F2L10"
start:
FOR c = 0 TO 7
x = x + 1: h = h + 1: pg = pg + 1: up = up - 1
IF up < 5 THEN up = 23
IF pg + 1 = 8 THEN PCOPY 7, 0: pg = 0
SCREEN , , pg + 1, pg
COLOR 2: CLS
LOCATE 2, 2: COLOR 3: PRINT "Demo Of Animation Using Page Flipping"
LOCATE up, 10: COLOR 1: PRINT "Chess Pieces In The Sky"
DRAW "BM=" + VARPTR$(x) + ",=" + VARPTR$(v)
DRAW "s8;C8;X" + VARPTR$(Q$): PAINT (x + 4, v - 2), 4, 8
DRAW "BM=" + VARPTR$(h) + ",=" + VARPTR$(v)
DRAW "C8;X" + VARPTR$(n$): PAINT (h + 4, v - 2), 15, 8
FOR z = 0 TO 20
PSET (RND * 320, RND * 200), RND * 15
IF x > 300 THEN GOTO holdscrn
NEXT: NEXT
GOTO start
holdscrn:
GOTO holdscrn
'E N D
Earl
--- Maximus 2.01wb
* Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #19971
Date: 12-05-92 15:30 (Public)
From: ANDY C. OLIVER
To: ALL
Subject: MOUSEQB
────────────────────────────────────────────────────────────────────────────────
'COPIED FROM COMPUTE APRIL 1992 PG 52
'ENTERED BY A. CHRISTOPHER OLIVER FOR SUPERLINK BBS.
'YOU NEED TO LOAD THIS TO THE BEGINNING OF YOUR PROGRAM.
'OR MAKE IT A LIBRARY
'SUPERLINK BBS - (904)735-2224 FRI-MON
DEFINT A-Z
'$INCLUDE QB.BI
DECLARE SUB HIDEMOUSE ()
DECLARE SUB SHOWMOUSE ()
DECLARE SUB GETMOUSECORD (K%, K3%, M4%)
DECLARE SUB STARTMOUSE ()
DIM SHARED Inregs AS RegType, Outregs AS RegType
STARTMOUSE
DO
GETMOUSECORD K, X, Y
LOCATE 1,1
PRINT X, Y, K
LOOP WHILE K=0
HIDEMOUSE
END
SUB GETMOUSECORD (K%, M3%, M4%)
Inregs.ax%=3
CALL INTERRUPT(&H33, Inregs, Outregs)
M3%=Outregs.cx% /8+1
M4%=Outregs.dx% /8+1
K%=Outregs.bx%
END SUB
SUB HIDEMOUSE
Inregs.ax%=2
CALL INTERRUPT(&H33, Inregs, Outregs)
END SUB
SUB SHOWMOUSE
Inregs.ax=1
CALL INTERRUPT(&H33, Inregs, Outregs)
END SUB
SUB STARTMOUSE
Inregs.ax%=0
CALL INTERRUPT(&H33, Inregs, Outregs)
Mouseinitialize%=Outregs.ax%
END SUB
--- TMail v1.31
* Origin: Cornucopia TBBS - Winter Park, FL - 407/645-4929 (1:363/18)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #3771
Date: 11-21-92 13:45 (Public)
From: SCOTT DRYSDALE
To: JIM COYLE
Subject: Existing File check
────────────────────────────────────────────────────────────────────────────────
Hi.
JC> fucntion Exist% (FileName$)
JC> open Filename$ for binary as #1
JC> if lof(1)=0 then
I use the EXACT same function exept mine uses FREEFILE so as to not disrupt
anything that might be open at the time.
--- Maximus 2.01wb
* Origin: The BULLpen BBS * Intel 14.4EX (613)549-5168 (1:249/140)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #4284
Date: 11-21-92 07:05 (Public)
From: FRANKLIN BEAL
To: BILL CAMPBELL
Subject: Randmizing
────────────────────────────────────────────────────────────────────────────────
BC>can anyone help me. i wrote a program to randamize numbers, but it
>keeps repeating the number such as, i type the number 3 and i want it
>to randamize 1-3 but it will put maybe 1 2 2. so can anyone tell me how
>to solve my problem?????
>thanks,
>bill campbell
Try this:
DO
DO: x$ = INKEY$: LOOP UNTIL x$ <> ""
IF x$ = CHR$(27) THEN END
IF VAL(x$) > 0 THEN
RANDOMIZE TIMER
x% = INT(VAL(x$))*RND+1
PRINT x%
END IF
LOOP
If you want to add a lower limit to the generated number, the following
will work.
DO
INPUT "Lower Limit? "; LBound%
IF LBound% <= 0 THEN END
INPUT "Upper Limit? "; UBound%
RANDOMIZE TIMER
x% = INT((LBound% - UBound%) + 1)*RND+LBound%
PRINT x%
END IF
LOOP
L8R
Franklin Beal
* SLMR 2.0 * Anything worth fixing is worth doing right the first time
--- WM v2.04/91-0012
* Origin: Com-Dat BBS Hillsboro, OR. HST (503) 681-0543 (1:105/314)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #4331
Date: 11-22-92 00:30 (Public)
From: PETE DUDESEK
To: MICHAEL BAILEY
Subject: Variable Sharing in QB45
────────────────────────────────────────────────────────────────────────────────
> combnations of COMMON SHARED, DIM SHARED, and SHARED statements with
> each of the modules and subs, and the variables still aren't being
> shared back up to the module level and across to other modules.
> Anyone know what I'm doing wrong, or am I trying to handle this
I had the same problem recently and here is how I do it now.
This is a simple little test program for you to use to see how
to pass variables in modules. Just cut each one out and save
them as a seperate files. COMMON.INC, DECLARE.INC, MAIN.BAS,
SUB1.BAS, SUB2.BAS, and SUB3.BAS.
Now load up QB and load in MAIN.BAS. Then with File/Load command
Load in SUB1.BAS, SUB2.BAS and SUB3.BAS.
Now run the program to see it work at passing to and from.
' ----- save this as COMMON.INC --------
' These are all the common shared variables to be used
' by MAIN.BAS, SUB1.BAS, SUB2.BAS, SUB3.BAS
COMMON SHARED Global1$, Global2$, Global3$
COMMON SHARED Global1%, Global2%, Global3%
COMMON SHARED Global4$()
DIM SHARED Global4$(10)
Global1$ = "This is the Global1$"
Global2$ = "This is the Global2$"
Global3$ = "This is the Global3$"
Global1% = 1
Global2% = 2
Global3% = 3
FOR Z% = 1 TO 10
Global4$(Z%) = "This is array Global4$ " + STR$(Z%)
NEXT Z%
'----- End of COMMON.INC -----
'----- Save this as DECLARE.INC -----
' This is the common declare file to be used with
' MAIN.BAS, SUB1.BAS, SUB2.BAS, SUB3.BAS
DECLARE SUB Sub1Sub ()
DECLARE SUB Sub2Sub ()
DECLARE FUNCTION Sub3Function% (Tmp$)
DECLARE FUNCTION Sub3Function4$ (Tmp AS INTEGER)
'----- End of DECLARE.INC -----
'----- Save as MAIN.BAS -----
' This is a simple test program
' This is the main module called MAIN.BAS
' $INCLUDE: 'DECLARE.INC'
' $INCLUDE: 'COMMON.INC'
CLS
PRINT
PRINT "We are in the main Module"
PRINT
Sub1Sub
Sub2Sub
PRINT Sub3Function(Test$)
PRINT Test$
PRINT
PRINT "Press a key to see the Global4$() array passing test"
DO: LOOP WHILE INKEY$ = ""
FOR X% = 1 TO 10
PRINT Sub3Function4$(X%)
NEXT X%
END
'----- End of MAIN.BAS -----
'----- Save as SUB1.BAS -----
DECLARE SUB Sub1Sub ()
' This is SUB1.BAS
' $INCLUDE: 'DECLARE.INC'
' $INCLUDE: 'COMMON.INC'
SUB Sub1Sub
PRINT "Coming to you from SUB1.BAS - SUB Sub1Sub"
PRINT Global1$
PRINT
END SUB
'----- End of SUB1.BAS -----
'----- Save as SUB2.BAS -----
' This is SUB2.BAS
' $INCLUDE: 'DECLARE.INC'
' $INCLUDE: 'COMMON.INC'
Sub2Sub
SUB Sub2Sub
PRINT "Coming to you from SUB2.BAS - SUB Sub2Sub"
PRINT Global2$, Global2%
PRINT
END SUB
'----- End of SUB2.BAS -----
'----- Save as SUB3.BAS -----
' This is SUB3.BAS
' $INCLUDE: 'DECLARE.INC'
' $INCLUDE: 'COMMON.INC'
FUNCTION Sub3Function% (Tmp$)
PRINT "Coming to you from SUB1.BAS - FUNCTION Sub3Functiuon%"
Sub3Function% = Global3%
Tmp$ = Global3$
END FUNCTION
FUNCTION Sub3Function4$ (Tmp%)
Sub3Function4$ = Global4$(Tmp%)
END FUNCTION
'----- End of SUB3.BAS -----
Note: That if you create a new FUNCTION in one of the sub modules
remember to create a declare statement for it and put it in the
DECLARE.INC. Same goes for SUB's, even though QB automatically
adds a DECLARE SUB to your MAIN Module.
Hope it helps you out.
--- Squish v1.01
# Origin: UBU-Midwest - Bensenville IL - 708-766-1089 (8:7401/13)
* Origin: FamilyNet Intl. Echogate [708] 887-7685 (1:115/887)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #4334
Date: 11-21-92 11:21 (Public)
From: DIK COATES
To: TRENT SHIRLEY
Subject: registration encodin
────────────────────────────────────────────────────────────────────────────────
>>>> QUOTING Trent Shirley to Dik Coates <<<<
TS> means, and I know NOTHING about Algorithms.
Trent, an algorithm is simply a method of formulating a problem
and solving it. The algorithm for dividing a pile of pennies equally
might be as simple as putting 1 into each of two pockets until the pile has
disappeared...(hoping you have no remainder)...
TS> Even given exact code, would it not still be nearly
TS> impossible to crack the unknown algorithm? That is what I
It is not impossible, meerly very difficult...Because the sample (the amount
of encrypted text is small, it is more difficult), combined with the fact
that two different encryption techniques are used, and the results blended
help make it very difficult...It is always possible to go into the program
code and unravel the encryption techniques, but if your application is
sensitive enough that totally bulletproof encryption is required, you should
be working it out with a cryptographic programmer. I have some DES stuff, and
a bunch of PD source for encryption...for C or Assembly programming or linking
libraries. If I can find it in my box of goodies, can put it on line, but
from your introductory comments...you might have some problem with it...
TS> was hoping for anyway. Possibly some mostly useful code,
TS> with enough info to formulate my own algorithm.
I can upload some of my earlier stuff that can be used... half a dozen
routines for rotating and shuffling bit values (all done in BASIC) if that
will help...but by publishing it, your own approach will be less secure!
Gimme the word, and I'll put it on line... The following is a bit of an
example of what can be done...your imagination is the only thing stopping
you!
An approach you can take is to to take the name... convert each character to
an ASCII value and write the ASCII value in binary form. For example 'A' has
an ASCII value of 65 which has a binary value of 01000001. This binary number
can be rotated 3 to the left yielding the binary value 00001010 which is the
same ASCII value 10 which corresponds to the symbol of 'a dark square with a
small white o in the centre'. The same letter 'A' can be rotated 4 characters
to the left yielding a binary number 00010100 which is the same as ASCII value
20 yielding the symbol that looks like 'an uppercase backwards P'. These
values
can be written to a binary file and someone not knowing the method of
encryption
will not be able to decypher the letters A and A. The program can read the
first symbol and convert it back to an 'A' and then read the second sysbol and
convert it to an 'A' and compare the values...if they are the same, no one has
tampered with the encrypted file...I hope you can follow this so far...tried
to
make it as clear as I can.
The method of encryption above is fairly simple, but unless someone knows the
technique, they will have difficulty 'breaking' the code. It can be made much
more complicated simply by making the amount it shifted to the left dependent
on the letter, so they all shift different amounts, or the value shifted can
depend on the character in front or behind.
Another approach is to take the binary value and separate every second bit
value and combine the two halves. For example 1 0 1 1 0 0 1 0 becomes
^ ^ ^ ^
1 1 0 1 and 0 1 0 0
so 10110010 becomes 1101 0100.
Hope I haven't confused you too badly...will post some simple stuff if you
want.
TS> I was just hoping for something a bit generic that would be
TS> applicable.
There may be some PD encryption routines in BASIC out there, but I'm not
familiar with them. Regards Dik
TS> ! Origin: Pioneer Valley PCUG1 (1:321/109)
Where's this at?
... Damn touchscreen, Anyone see my braille tagline... -Dik
--- Blue Wave/QWK v2.10
--- Maximus 2.00
* Origin: Durham Systems (ONLINE!) (1:229/110)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #3934
Date: 11-21-92 23:08 (Public)
From: RICH GELDREICH
To: ALL
Subject: Asm Fader/fix 1 (ASM)
─────────────────────────────────────────────────────────────────────────────
Ooops! After looking back at the ASM fader I posted a few days ago, I
discovered that I posted the wrong one! Duh! Well, here is the one I
originally wanted to post. The ASM code follows. Next message has OBJ
and test program.
;Noiseless VGA DAC fading routines for QB4.5/PDS(works on 286's and up)
;By Rich Geldreich 1992
;Assembled with TASM v2.0
.286
IDEAL
MODEL SMALL
DATASEG
Palette db 768 dup (?)
NewPalette db 768 dup (?)
CODESEG
PUBLIC GetPalette, SetPalette
EVEN
PROC SetPalette ;Sets the pallette retrieved by
;GetPalette to a specified brightness
;DECLARE SUB SetPalette (BYVAL Brigtness, BYVAL Start, BYVAL Num)
Brightness EQU [ss:bp+10] ;0-128
Start EQU [ss:bp+08] ;0-255
Num EQU [ss:bp+06] ;1-256
Parameters = 3
Push bp ;set us up a stack frame
Mov bp, sp
Push es ds si di ;lets not get QB mad now
Mov ax, @data ;get access to palette buffers
Mov ds, ax
Mov es, ax
Xor ax, ax
Mov al, Start ;get start color
Mov dx, 03C7h ;tell the VGA some DAC values will
Out dx, al ;be coming
Inc dx
Out dx, al
Inc dx ;dh=3
Mov si, ax ;add start*3 to the palette offset
Shl si, 1
Add si, ax
Add si, offset Palette
Mov bl, Brightness
Cmp bl, 128 ;limit brightness if too high
Jna @@Ok1
Mov bl, 128
@@Ok1:
Mov cx, Num ;CX=# of registers to change
Jcxz @@Done ;if no registers to change then exit
Add ax, cx ;calculate the last register to change
Sub ax, 256 ;if too many then limit
Jna @@OK2
Sub cx, ax
@@OK2:
Mov di, offset NewPalette
Mov bp, cx ;save cx for later
EVEN ;color precalculation loop
@@10: REPT 3 ;repeat 3 times(for Red, Green, & Blue)
Lodsb ;
Mul bl ;new=old*brightness
Shl ax, 1 ;new=(new*2)\256 or new=new\128
Mov al, ah
Stosb
ENDM
Loop @@10
Mov cx, bp ;multiply number of colors by 3
Shl cx, 1
Add cx, bp
Mov si, offset NewPalette
Mov dl, 0DAh ;wait for vertical retrace
@@15: In al, dx ;wait for end of vertical retrace
Test al, 8 ;(for very fast machines)
Jnz @@15
@@20: In al, dx ;now wait for start of vertical
Test al, 8 ;retrace
Jz @@20
Mov dl, 0C9h ;dx=03C9h
Rep Outsb ;output the new colors
@@Done:
Pop di si ds es bp
Retf Parameters*2 ;bye bye
ENDP SetPalette
PROC GetPalette ;Must call this routine before
;DECLARE SUB GetPalette () ;SetPalette!
Push es
Mov ax, @data
Mov es, ax
Mov dx, offset Palette ;es:dx addresses palette
Mov cx, 256
Xor bx, bx
Mov ax, 01017h
Int 010h
Pop es
Retf 0
ENDP GetPalette
END
--- MsgToss 2.0b
* Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #4061
Date: 11-21-92 19:35 (Public)
From: BRENT ASHLEY
To: RAYMOND PAQUIN
Subject: QB SIMULTANEOUS KEYS (ASM)
─────────────────────────────────────────────────────────────────────────────
;
; KeyPress.ASM by Brent Ashley
; maintains map of the "pressed" status of all keys
; allows you to detect multiple keys pressed
;
.model medium, basic
.code
Old09 Label Dword ;Label for to old Int 09h handler
Old09Offset dw ? ;Offset part
Old09Segment dw ? ;Segment part
Hooked db 0 ;Our installed flag
KeyMap db 80h dup(0) ;map of kybd, one byte per scancode
InstKeyPress proc uses ds ax dx ; From BASIC: CALL InstKeyPress
; REMEMBER to call UnhookKeyPress!
cmp cs:Hooked,0 ;Are we already hooked?
jnz InstallExit ;If so, exit
mov ax,3509h ;Get current vector for int 09h
int 21h
mov cs:Old09Segment,es ;Remember it for later
mov cs:Old09Offset,bx
mov ax,2509h
push ds
push cs
pop ds ;Point int 09h handler to our code
mov dx, offset OurInt09
int 21h
pop ds
mov cs:Hooked,-1 ;Set our installed flag
InstallExit:
ret
OurInt09: ;Our Int 09h handler
push ax
push bx
push dx
push si
in al, 60h ;get scancode from keyboard port
test al, 080h ;is "released" bit set?
jnz Released ;yup - go to it
mov dl, 0FFh ;nope - set key pressed flag
jmp PutFlag
Released:
and al, 07Fh ;yes - clear bit for index
mov dl, 0 ;and set flag for release
PutFlag:
xor ah, ah
mov si, ax ;assign index
mov cs:KeyMap[si], dl ;put flag in place
pop si
pop dx
pop bx
pop ax
Continue:
jmp dword ptr cs:[Old09] ;Transfer control to orig Int 09h
InstKeyPress endp
KeyPressed proc uses bx si, ScanCode:WORD
; from BASIC: TrueOrFalse% = KeyPressed(ScanCode%)
mov bx, ScanCode ;get scan code addr
mov si, [bx] ;load value as index
mov al, cs:KeyMap[si] ;put flag in al
and al, 07Fh ;make sure less than 80h
cbw ;convert to word for integer value
ret
KeyPressed endp
UnhookKeyPress proc ; from BASIC: CALL UnHookKeyPress
cmp cs:Hooked,0 ; are we installed?
jz UnHooked ; nope - exit
push ax
push ds
mov ax,2509h ;Unhook ourself
mov ds,Old09Segment
mov dx,Old09Offset
int 21h ;Point Int 09h back to original
handler
pop ds
pop ax
mov cs:Hooked,0 ;Set installed flag back to zero
UnHooked:
ret
UnhookKeyPress endp
END
--- FidoPCB v1.3 [ff053/x]
* Origin: Canada Remote Systems, Mississauga, Ontario (1:229/15)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #4068
Date: 11-21-92 22:40 (Public)
From: MATHIEU BOUCHARD
To: ALL
Subject: VGA graphics/Palette
────────────────────────────────────────────────────────────────────────────────
Here is my LIGHTNING FAST palette writer...
load QB.QLB...
$include:'qb.bi'
dim rin as regtypex
dim rout as regtypex
dim pal as string * 768
...
'to change palette: c=color, r=red 0-63, g=green 0-63, b=blue 0-63
mid$(pal,c*3+1,3)=chr$(r)+chr$(g)+chr$(b)
'after all your changes, let's update:
rin.ax=&h1012:rin.bx=0:rin.cx=256:rin.dx=varptr(pal):rin.es=varseg(pal)
interruptx &h10,rin,rout
--- Maximus 2.01wb
* Origin: R&D BBS, (819) 772-2952 HST/V32 (Line 2) (1:163/506)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #5003
Date: 11-21-92 11:14 (Public)
From: PETER BARNEY
To: MARK THOMAS
Subject: Error Level
────────────────────────────────────────────────────────────────────────────────
Try this (you must load QB.QLB or QBX.QLB for this to work)
'$INCLUDE 'QB.BI' '<- qbx.bi for pds.
SUB ExitProgram (s)
'Exits the program with an errorlevel. Instead of END, use
'ExitProgram <int> where <int> is the error level you wish
'to exit with
DIM Regs AS RegType
Regs.ax = &H4C00 + (s AND 255)
CALL Interrupt(&H21, Regs, Regs)
END SUB
--- FMail 0.92
* Origin: Pete's Place - Toledo, Ohio (1:234/35.1)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #5004
Date: 11-21-92 11:29 (Public)
From: PETER BARNEY
To: MARK THOMAS
Subject: Networking....Share
────────────────────────────────────────────────────────────────────────────────
> When running on a network, I get a share violation.
> Can anyone suggest a way that I can prevent this problem
OPEN "filename.ext" FOR RANDOM ACCESS <access> <lock> AS #1 LEN=whatever
Replace <access> with:
Read Opens the file for reading only.
Write Opens the file for writing only.
Read Write Opens the file for both reading and writing.
(This mode works only on random and binary files,
and files opened for append.)
Replace <lock> with:
Shared Any process on any machine can work with the
file.
Lock Read No other process can read the file. (this
access is granted only if no other process has
a previous read access to the file.
Lock Write No other process is granted write access to this
file. This lock is granted only if no other
process has a previous write access to the file.
Lock Write Read No other process is granted either read or write
write acess to the file. This access is granted
only if read or write access has not been already
granted to another process, or if a lock read or
lock write is not already in place.
hope this helps!
--- FMail 0.92
* Origin: Pete's Place - Toledo, Ohio (1:234/35.1)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #5450
Date: 11-28-92 20:08 (Public)
From: LEE MADAJCZYK
To: JAMES FRAZEE
Subject: PCX Load SUB
────────────────────────────────────────────────────────────────────────────────
JF> Is there a program to convert .PCX into a .BSV file. I found
JF> out finally how easy it is too BLOAD a .BSV file and If I can
JF> convert a .PCX into a .BSV it would be easier.
JF>
JF> Now if someone can give me code to load a 16 color .PCX file
JF> as a menu for a game,let me know,please.
Here you go.... (I stole this from SOMEWHERE....)
'PCX SAVE & PCX LOAD FOR EGA SCREEN 9 (640 x 350, 16 COLOR)
'BY G.C.HARDER, RE-ENGINEERED FROM C SOURCE IN
' "FRACTAL PROGRAMMING IN C"
DEFINT A-Z
DECLARE SUB PCXSave (File$, Pal.Array%())
DECLARE SUB PCXLoad (File$, Pal.Array%())
FileName$ = "Demo4.PCX"
SCREEN 9, 0, 1, 0
DIM Pal.Array%(15)
FOR I% = 0 TO 15: READ Pal.Array%(I%): NEXT
CLS
LOCATE 25, 30: PRINT "Loading " + FileName$;
PCXLoad FileName$, Pal.Array%()
'default Palette Colors
DATA 0,1,2,3,4,5,20,7,56,57,58,59,60,61,62,63
SUB PCXLoad (File$, Pal.Array%()) STATIC
SCREEN 9, 0, 0, 0: OPEN File$ FOR BINARY AS #1: SEEK #1, 17
DIM Byte AS STRING * 1
FOR I% = 0 TO 15
GET #1, , Byte: red% = ASC(Byte) / 85
GET #1, , Byte: green% = ASC(Byte) / 85
GET #1, , Byte: Blue% = ASC(Byte) / 85
red% = ((red% AND 1) * 32) OR ((red% AND 2) * 2)
green% = ((green% AND 1) * 16) OR (green% AND 2)
Blue% = ((Blue% AND 1) * 8) OR ((Blue% AND 2) \ 2)
Hue% = red% OR green% OR Blue%: Pal.Array%(I%) = Hue%
NEXT
PALETTE USING Pal.Array%(0): SEEK #1, 129: DEF SEG = &HA000
FOR k% = 0 TO 349
A$ = INKEY$: IF A$ = CHR$(27) THEN END
Addr% = 80 * k%: Line.end% = Addr% + 80: J% = 1
DO WHILE J% <= 4
B% = J%
IF J% = 3 THEN B% = 4
IF J% = 4 THEN B% = 8
OUT &H3C4, 2: OUT &H3C5, B%
GET #1, , Byte: Byte.1% = ASC(Byte)
IF (Byte.1% AND 192) <> 192 THEN
POKE Addr%, Byte.1%: Addr% = Addr% + 1
IF Addr% >= Line.end% THEN Addr% = 80 * k%: J% = J% + 1
ELSE
Byte.1% = Byte.1% AND 63
GET #1, , Byte: Byte.2% = ASC(Byte)
FOR M% = 1 TO Byte.1%
B% = J%
IF J% = 3 THEN B% = 4
IF J% = 4 THEN B% = 8
OUT &H3C4, 2: OUT &H3C5, B%: POKE Addr%, Byte.2%
Addr% = Addr% + 1
IF Addr% >= Line.end% THEN Addr% = 80 * k%: J% = J% + 1
NEXT
END IF
LOOP
NEXT
OUT &H3C4, 2: OUT &H3C5, &HF: DEF SEG ': CLOSE #1
END SUB
Hope this helps. After you load your file, just BSAVE it. If you
want the PCX saving routine, or anyone else for that matter, give
me a ring!
Lee Madajczyk
Quantum Software
... OFFLINE 1.40 * Difference between a virus & Windows? Viruses don't fail.
---
* Origin: Infinity -=[HST]=- (1:280/5)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #5543
Date: 11-23-92 19:07 (Public)
From: STEVE GARTRELL
To: ROBERT CHURCH
Subject: QB/PDS/VBDOS INT Handlers
────────────────────────────────────────────────────────────────────────────────
'So Basic can't do interrupt handlers...The DemRegs variable
'passes back the status of the registers at the time of the
'interrupt. Likewise, if you change a DemRegs.(anyreg)
'value inside the handler sub, that value will be placed
'in the respective register!!! Dangerous toy, A? The
'global variable Busy% is read inside the Absolute array
'ASM; if it's <> 0 then the routine chains directly (mostly)
'to the original vector. Which you will want, if you are going
'to DEF SEG out of DGROUP, for instance!!!
'NOT FOR USE IN THE ENVIRONMENT!! Compile it, and then
'let it run for 20 or 30 seconds, and you'll start seeing the
' registers passed back...
'
'This is _not_ a toy...If you are not sure what you are doing,
' try thinking about worst-case scenarios, and take proper
' preventative measures...Like, if you play with disk access
' interrupts, BACK UP!!
'Compiled and tested under QB45 and PDS...
DEFINT A-Z
'$INCLUDE: 'VBDOS.BI' 'QB.BI if using QB4.5, QBX.BI in PDS
DECLARE SUB Handler ()
'remark out the original DECLARE SUB Absolute declaration in your
' include file; it's modified here...
DECLARE SUB Absolute (RegsOff%, Busy%, OldSeg%, OldOff%,_
StartPtr%, address AS INTEGER)
'bet ya can't guess what my middle initial is...
TYPE SKGregs
ax AS INTEGER
bx AS INTEGER
cx AS INTEGER
dx AS INTEGER
si AS INTEGER
di AS INTEGER
es AS INTEGER
ds AS INTEGER
flags AS INTEGER
bp AS INTEGER
END TYPE
CONST C$ = "Created 08/31/92 by Steve Gartrell."
'don't want this stuff moving around!!! These
' MUST remain global!!!
'$STATIC
DIM SHARED AsmArray%(1 TO 88), DemRegs AS SKGregs
DIM SHARED OldOff%, OldSeg%, RetToAsm%, RegsOff%, SetUp%
DIM SHARED TicCnt%, Busy%
'$DYNAMIC
CLS
LOCATE 1, 70: PRINT LEFT$(TIME$, 8)
SetUp% = VARPTR(AsmArray%(47))
RetToAsm% = VARPTR(AsmArray%(29))
NewSeg% = VARSEG(AsmArray%(1))
NewOff% = VARPTR(AsmArray%(1))
RegsOff% = VARPTR(DemRegs)
DIM Regs AS RegTypeX
'DOS get interrupt vector using the clock 08h for
' demo purposes...Can use any other, too, but be
' aware that results can be extremely dependent
' upon what QB/PDS has done/is gonna do with the
' original vector!!!
Regs.ax = &H3508
CALL INTERRUPTX(&H21, Regs, Regs)
'save 08h original vector
OldSeg% = Regs.es
OldOff% = Regs.bx
'read all the sneaky little ASM opcodes in, which are primarily
' concerned with register saving, and navigating around the
' flow "limitations" imposed by QB/PDS...
RESTORE
FOR Word% = 1 TO 88
READ DataStr$
AsmArray(Word%) = VAL(DataStr$)
NEXT
'Call the sub that sets up necessary address calculations...
Handler 'OldSeg% & OldOff% are global, remember...
'Use DOS set interrupt call to change interrupt &H08 vector to
' the one returned for the AsmArray code that resides in DGROUP...
Regs.ax = &H2508
Regs.ds = NewSeg%
Regs.dx = NewOff%
CALL INTERRUPTX(&H21, Regs, Regs)
cnt& = 0
DO
'gotta do something to show clock is interrupt driven
' Fix Busy% true, and the interrupt-driven time
' print can occur before this LOCATE and PRINT finish,
' with the number then showing up at coordinate 2,1!!
cnt& = cnt& + 1
Busy% = -1
LOCATE 5, 35
PRINT cnt&;
Busy% = 0
IF cnt& > 2000000 THEN cnt& = 1
LOOP UNTIL LEN(INKEY$)
'Return INT &H08 to it's original vector-THIS MUST ALWAYS
' BE DONE!!!
Regs.ax = &H2508
Regs.ds = OldSeg%
Regs.dx = OldOff%
CALL INTERRUPTX(&H21, Regs, Regs)
LOCATE 24, 1
END 'This is the end, my FIDO friend, the end...
'88 WORDS, FIRST call at VARPTR(47), LAST call at VARPTR(29)
ReversedOpcodes:
DATA &H8B55,&H9CEC,&H061E,&H5657,&H5152,&H5053,&HD78C,&HDF8E
DATA &H90BB,&H8B90,&H2307,&H75C0,&H8E30,&H8BC7,&HFCF4,&H90BF
DATA &HB990,&H000A,&HA5F3,&HEF83,&H5714,&HEE83,&H5614,&HB8FB
DATA &H9090,&HB850,&H9090,&HCB50,&HC483,&H8C0E,&H8ED7,&H8EDF
DATA &H5FC7,&HFC5E,&H0AB9,&HF300,&H58A5,&H595B,&H5E5A,&H075F
DATA &H9D1F,&H2E5D,&H2EFF,&H0058,&H9090,&H9090,&H8B55,&H50EC
DATA &H5253,&H8B56,&H065E,&H1F8B,&HEB83,&H8B5C,&H0246,&H0305
DATA &H8900,&H3487,&H8B00,&H0446,&H8789,&H0030,&HF38B,&H5E8B
DATA &H8B08,&H8917,&H5894,&H8B00,&H0A5E,&H178B,&H9489,&H005A
DATA &H5E8B,&H890C,&H119C,&H8B00,&H0E5E,&H178B,&H9489,&H001F
DATA &HC68B,&H5805,&H8900,&H5644,&H5A5E,&H585B,&HCA5D,&H000A
REM $STATIC
STATIC SUB Handler ()
SHARED OldOff%, OldSeg%, RetToAsm%, RegsOff%, SetUp%
SHARED TicCnt%, Busy%, DemRegs AS SKGregs, NewOff%
'Make sure we're looking at DGROUP
DEF SEG
CALL Absolute(RegsOff%, Busy%, OldSeg%, OldOff%, SetUp%, SetUp%)
EXIT SUB
'This routine's LIFE DEPENDS UPON a certain amount of
' code bytes between the EXIT SUB and the next command
' (happens to be JGE [IF < THEN] here, but not critical). IF
' YOU SPECIFY /D(ebug) when compiling, YOUR system will HANG!!
' ('Cuz the compiler will sneak some stuff in in between
' the EXIT SUB and your first line of code!!!) Also, ERROR
' handling (/E/X compile options) in QB is probably
' impossible, and should be approached with care in PDS (like,
' anything but LOCAL error handling is probably out of the
' question, and LOCAL in this sub is a no-no!!!)
' Put any code you want between the EXIT SUB and the
' DEF SEG...EXCEPT (at least) END or it's equivalents...
' You MUST return the clock to it's original vector before
' exiting to DOS, SHELLing, and so forth!!!
'update if 10 seconds have elapsed AND it's safe to do so!
IF TicCnt% < 10 THEN
TicCnt% = TicCnt% + 1 'a little delay...
ELSE
Busy% = -1
LOCATE 1, 70
PRINT LEFT$(TIME$, 8) 'update the time
LOCATE 2, 1
'print the register values at interrupt...
' Remember, if you change a register variable at
' this point, it _will_ change the register contents!!
PRINT "AX = "; HEX$(DemRegs.ax); "h"; SPACE$(4)
PRINT "BX = "; HEX$(DemRegs.bx); "h"; SPACE$(4)
PRINT "CX = "; HEX$(DemRegs.cx); "h"; SPACE$(4)
PRINT "DX = "; HEX$(DemRegs.dx); "h"; SPACE$(4)
PRINT "SI = "; HEX$(DemRegs.si); "h"; SPACE$(4)
PRINT "DI = "; HEX$(DemRegs.di); "h"; SPACE$(4)
PRINT "ES = "; HEX$(DemRegs.es); "h"; SPACE$(4)
PRINT "DS = "; HEX$(DemRegs.ds); "h"; SPACE$(4)
PRINT "BP = "; HEX$(DemRegs.bp); "h"; SPACE$(4)
PRINT "Flags = "; HEX$(DemRegs.flags); "h"; SPACE$(4)
TicCnt% = 1
Busy% = 0
END IF
DEF SEG
CALL Absolute(dummy%, dummy%, dummy%, dummy%, dummy%, RetToAsm%)
END 'I stuck this END in here just to show you that
' the instruction pointer will never get here...
END SUB
--- D'Bridge 1.30/071082
* Origin: RadioLink! Columbus, OH (614)766-2162 HST/DS (1:226/140)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #5544
Date: 11-23-92 19:08 (Public)
From: STEVE GARTRELL
To: ROBERT CHURCH
Subject: QB/PDS/VBDOS INT Handlers
────────────────────────────────────────────────────────────────────────────────
.model medium, basic
.code
handle PROC
IntEntry:
push bp ; push everything
mov bp, sp ; stack frame
pushf
push ds
push es
push di
push si
push dx
push cx
push bx
push ax
mov di, ss ;cuz the damned data seg
mov ds, di ; can get lost
BusyOff:
mov bx, 9090h
mov ax, [bx]
and ax, ax
jnz SHORT TooBusy
mov es, di ;point dest seg at DGROUP
mov si, sp ;stack address for regs to si
cld
RegsOff:
mov di, 9090h ;QB/PDS reg TYPE offset to di
mov cx, 0Ah
rep movsw
sub di, 14h
push di
sub si, 14h
push si
sti
HandSeg:
mov ax, 9090h ;Here the QB sub segment
push ax ; is placed on the stack for the
; RETF
HandOff:
mov ax, 9090h ;Here the QB sub offset
push ax ; is placed on the stack for the
retf ; RETF
AllDone:
add sp, 0Eh ;roll the stack ptr back past the
; last CALL Absolute far return
; address and the five dummy
; variables on the stack. Then
; pop everything
mov di, ss ;cuz the damned data seg
mov ds, di ; can get lost
mov es, di
pop di ;popped in reverse dest/source
pop si
cld
mov cx, 0Ah
rep movsw
TooBusy:
pop ax
pop bx
pop cx
pop dx
pop si
pop di
pop es
pop ds
popf
pop bp
jmp cs:OldInt
JmpAddr:
OldInt DD 90909090h
Start:
assume ds:seg IntEntry
push bp ; set up stack frame ptr
mov bp, sp
push ax
push bx
push dx
push si
mov bx, [bp + 6] ;get ptr to start of this handler
; (stored in DGROUP)
mov bx, [bx]
sub bx, Start - IntEntry
mov ax, [bp + 2] ; get QB sub return offset
add ax, 03h ; add 3 to compensate for JMP
; opcode/disp and store in code
mov WORD PTR [bx + HandOff + 1], ax
mov ax, [bp + 4] ; get QB sub return seg
; and store in code
mov WORD PTR [bx + HandSeg + 1], ax
mov si, bx ;preserve start of code ptr
mov bx, [bp + 8] ;original int offset ptr to DX
mov dx, WORD PTR [bx] ; and moved to code storage
mov WORD PTR [si + JmpAddr], dx
mov bx, [bp + 0Ah] ;original int segment ptr to DX
mov dx, WORD PTR [bx] ; and moved to code storage
mov WORD PTR [si + JmpAddr + 2], dx
mov bx, [bp + 0Ch] ;busy flag ptr offset to DX
; and moved to code storage
mov WORD PTR [si + BusyOff + 1], bx
mov bx, [bp + 0Eh] ;SKGregs ptr to DX, adj to end,
mov dx, WORD PTR [bx] ; and moved to code storage
mov WORD PTR [si + RegsOff + 1], dx
mov ax, si ;start of code ptr in AX
add ax, JmpAddr - IntEntry ;add distance to offset of OldInt
; and move to actual JMP opcode
mov [si + (JmpAddr - IntEntry) - 2], ax
pop si
pop dx
pop bx
pop ax
pop bp
retf 0Ah ;return clearing stack
; of five ptr words
handle ENDP
END ;this is the end, my FIDO friend, the end...
--- D'Bridge 1.30/071082
* Origin: RadioLink! Columbus, OH (614)766-2162 HST/DS (1:226/140)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #5673
Date: 11-21-92 15:01 (Public)
From: RICHARD DALE
To: TRENT SHIRLEY
Subject: Registration Encoding
────────────────────────────────────────────────────────────────────────────────
TS>Im looking for information on implementing REGISTRATION codes into my
software.
TS> The best method I KNOW of is using an algorithm that will encode the
persons
TS>name and BBS name, then sending back the code to the person and tell them
to
This isn't exactly what you're looking for, as it can't be done by the
individual user.
ChkSum = 0
ValidSum = 2874
Tst$ = Copyright1$
FOR I% = 1 TO LEN(Tst$)
ChkSum = ChkSum + ASC(MID$(Tst$, I%))
NEXT I%
PRINT ChkSum
'IF ChkSum <> ValidSum THEN CALL LeaveProgram
For example, Copyright1$ could be "Joe Blow 689453". Run this, taking
the value ChkSum returns and put it in the second line. Then delete
the line PRINT ChkSum and unremark the last line.
Anyone using a hex editor to change copyright notices will change the
value in ChkSum, and the program will terminate.
* 1st 1.01 #567 * Pardon me, but would you have any Blue Poupon?
--- FidoPCB v1.2 [ff013/c]
* Origin: Sound Advice - 24 Nodes (816)436-4516 (1:280/333)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #5993
Date: 11-21-92 18:06 (Public)
From: TONY ELLIOTT
To: PETER BARNEY
Subject: Truncating Files
────────────────────────────────────────────────────────────────────────────────
Peter,
PB> Is there an easy way in QB to truncate a file to a certain length
PB> without copying it?
Sure .. Not directly via QB, but through an interrupt call. As long as
the file is opened for RANDOM, BINARY or OUTPUT, this should work fine.
I wrote it for QBX, but it'll work fine for other version by changing
the $INCLUDE to QB.BI for VBDOS.BI.
DECLARE FUNCTION TruncateFile% (Handle%, NewLength&)
DEFINT A-Z
REM $INCLUDE: 'qbx.bi'
OPEN "TEST.DAT" FOR BINARY AS #1 'Create a file to test
A$ = " "
PUT #1, 10240, A$ 'Make it 10K long
PRINT "File length:"; LOF(1) 'Make sure
Handle% = FILEATTR(1, 2) 'Get DOS file handle
NewLength& = 5000 'New length for this file
Status% = TruncateFile%(Handle%, NewLength&) 'Do it
IF Status% THEN
PRINT "DOS Error";Status%;" occurred."
ELSE
PRINT "New file length:"; LOF(1)
END IF
CLOSE
FUNCTION TruncateFile% (Handle%, NewLength&)
DIM Reg AS RegTypeX
'First, position the file read/write pointer to the place where the
'truncation should take place. We can't trust BASIC's SEEK statement
'because the movement is sometimes held until the next read/write.
Reg.AX = &H4200 'DOS "Set file pointer" function
Reg.BX = Handle%
'We go through these steps to prevent "overflow" errors when
'NewLength& > 32767. The high word of the file position goes in CX
'and the low word goes in DX. Since BASIC treats integers and longs
'"signed" variables, we need to take to extra steps to prevent
'an overflow error as we break the long integer down.
DEF SEG
Addr% = VARPTR(NewLength&)
Reg.CX = CVI(CHR$(PEEK(Addr% + 2)) + CHR$(PEEK(Addr% + 3)))
Reg.DX = CVI(CHR$(PEEK(Addr%)) + CHR$(PEEK(Addr% + 1)))
CALL InterruptX(&H21, Reg, Reg)
IF Reg.Flags AND 1 THEN
Status% = Reg.AX
GOTO TruncateExit
END IF
'Now, write 0 bytes.
Reg.AX = &H4000 'Dos "Write file or device"
Reg.BX = Handle%
Reg.CX = 0 'Write 0 bytes
Reg.DX = 0 'These are not needed, but make
Reg.DS = 0 ' sure they're zero, just in case
CALL InterruptX(&H21, Reg, Reg)
IF Reg.Flags AND 1 THEN
Status% = Reg.AX
END IF
TruncateExit:
TruncateFile% = Status%
END FUNCTION
... Okay, I pulled the pin. What now? Where are you going?
--- Blue Wave/Max v2.10 [NR]
* Origin: Oakland BBS - McDonough, GA - (404) 954-0071 (1:133/706.0)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #6039
Date: 11-23-92 22:35 (Public)
From: RICH GELDREICH
To: HARVEY PARISIEN
Subject: Gif Decompression Sys
────────────────────────────────────────────────────────────────────────────────
'Cheap, no frills GIF decompressor for the VGA's 320x200x256 mode.
'By Rich Geldreich 1992 (Public domain, use as you wish.)
'Sorry for no documentation, I wanted to crunch it to 150 lines...
DEFINT A-Z
DIM Prefix(4095), Suffix(4095), OutStack(4095), ShiftOut(8)
'The following line is for the QB environment(slow).
DIM Ybase AS LONG, Powersof2(11) AS LONG, WorkCode AS LONG
'For more speed, unremark the next line and remark the one above,
'before you compile... (Change back when inside the environment.)
'DIM Ybase AS INTEGER, Powersof2(11) AS INTEGER, WorkCode AS INTEGER
FOR A = 0 TO 7: ShiftOut(8 - A) = 2 ^ A: NEXT
FOR A = 0 TO 11: Powersof2(A) = 2 ^ A: NEXT
A$ = COMMAND$: IF A$ = "" THEN INPUT "GIF file"; A$: IF A$ = "" THEN END
IF INSTR(A$, ".") = 0 THEN A$ = A$ + ".gif"
OPEN A$ FOR BINARY AS #1
A$ = " ": GET #1, , A$
IF A$ <> "GIF87a" THEN PRINT "Not a GIF87a file.": END
GET #1, , TotalX: GET #1, , TotalY: GOSUB GetByte
NumColors = 2 ^ ((A AND 7) + 1): NoPalette = (A AND 128) = 0
GOSUB GetByte: Background = A
GOSUB GetByte: IF A <> 0 THEN PRINT "Bad screen descriptor.": END
IF NoPalette = 0 THEN P$ = SPACE$(NumColors * 3): GET #1, , P$
DO
GOSUB GetByte
IF A = 44 THEN
EXIT DO
ELSEIF A <> 33 THEN
PRINT "Unknown extension type.": END
END IF
GOSUB GetByte
DO: GOSUB GetByte: A$ = SPACE$(A): GET #1, , A$: LOOP UNTIL A = 0
LOOP
GET #1, , XStart: GET #1, , YStart: GET #1, , XLength: GET #1, , YLength
XEnd = XStart + XLength: YEnd = YStart + YLength: GOSUB GetByte
IF A AND 128 THEN PRINT "Can't handle local colormaps.": END
Interlaced = A AND 64: PassNumber = 0: PassStep = 8
GOSUB GetByte
ClearCode = 2 ^ A
EOSCode = ClearCode + 1
FirstCode = ClearCode + 2: NextCode = FirstCode
StartCodeSize = A + 1: CodeSize = StartCodeSize
StartMaxCode = 2 ^ (A + 1) - 1: MaxCode = StartMaxCode
BitsIn = 0: BlockSize = 0: BlockPointer = 1
X = XStart: Y = YStart: Ybase = Y * 320&
SCREEN 13: DEF SEG = &HA000
IF NoPalette = 0 THEN
OUT &H3C7, 0: OUT &H3C8, 0
FOR A = 1 TO NumColors * 3: OUT &H3C9, ASC(MID$(P$, A, 1)) \ 4: NEXT
END IF
LINE (0, 0)-(319, 199), Background, BF
DO
GOSUB GetCode
IF Code <> EOSCode THEN
IF Code = ClearCode THEN
NextCode = FirstCode
CodeSize = StartCodeSize
MaxCode = StartMaxCode
GOSUB GetCode
CurCode = Code: LastCode = Code: LastPixel = Code
IF X < 320 THEN POKE X + Ybase, LastPixel
X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
ELSE
CurCode = Code: StackPointer = 0
IF Code > NextCode THEN EXIT DO 'bad GIF if this happens
IF Code = NextCode THEN
CurCode = LastCode
OutStack(StackPointer) = LastPixel
StackPointer = StackPointer + 1
END IF
DO WHILE CurCode >= FirstCode
OutStack(StackPointer) = Suffix(CurCode)
StackPointer = StackPointer + 1
CurCode = Prefix(CurCode)
LOOP
LastPixel = CurCode
IF X < 320 THEN POKE X + Ybase, LastPixel
X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
FOR A = StackPointer - 1 TO 0 STEP -1
IF X < 320 THEN POKE X + Ybase, OutStack(A)
<<-to be continued on next message->>
--- MsgToss 2.0b
* Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #6040
Date: 11-23-92 22:39 (Public)
From: RICH GELDREICH
To: HARVEY PARISIEN
Subject: A Gif decoder/p2
────────────────────────────────────────────────────────────────────────────────
<<Part 2 Starts Here>>
X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
NEXT
IF NextCode < 4096 THEN
Prefix(NextCode) = LastCode
Suffix(NextCode) = LastPixel
NextCode = NextCode + 1
IF NextCode > MaxCode AND CodeSize < 12 THEN
CodeSize = CodeSize + 1
MaxCode = MaxCode * 2 + 1
END IF
END IF
LastCode = Code
END IF
END IF
LOOP UNTIL DoneFlag OR Code = EOSCode
BEEP
A$ = INPUT$(1)
END
GetByte: A$ = " ": GET #1, , A$: A = ASC(A$): RETURN
NextScanLine:
IF Interlaced THEN
Y = Y + PassStep
IF Y >= YEnd THEN
PassNumber = PassNumber + 1
SELECT CASE PassNumber
CASE 1: Y = 4: PassStep = 8
CASE 2: Y = 2: PassStep = 4
CASE 3: Y = 1: PassStep = 2
END SELECT
END IF
ELSE
Y = Y + 1
END IF
X = XStart: Ybase = Y * 320&: DoneFlag = Y > 199
RETURN
GetCode:
IF BitsIn = 0 THEN GOSUB ReadBufferedByte: LastChar = A: BitsIn = 8
WorkCode = LastChar \ ShiftOut(BitsIn)
DO WHILE CodeSize > BitsIn
GOSUB ReadBufferedByte: LastChar = A
WorkCode = WorkCode OR LastChar * Powersof2(BitsIn)
BitsIn = BitsIn + 8
LOOP
BitsIn = BitsIn - CodeSize
Code = WorkCode AND MaxCode
RETURN
ReadBufferedByte:
IF BlockPointer > BlockSize THEN
GOSUB GetByte: BlockSize = A
A$ = SPACE$(BlockSize): GET #1, , A$
BlockPointer = 1
END IF
A = ASC(MID$(A$, BlockPointer, 1)): BlockPointer = BlockPointer + 1
RETURN
<<-Cut Here->>
There you go!
This is a more efficient version of my first GIF decoder... It can
decode 320x200x256 GIFs at an acceptable speed(MUCH faster than my
original decoder), but there are still a few optimizations I left out to
keep it simple.
Rich
--- MsgToss 2.0b
* Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #7056
Date: 11-24-92 21:34 (Public)
From: JIM HARRE
To: TOM HAMMOND
Subject: HELP! Unsigned #'s
────────────────────────────────────────────────────────────────────────────────
In a message of <19 Nov 92 19:40:00>, Tom Hammond (1:289/15) writes:
>I was confused that the value of this variable appeared to be a negative
>number. Looking into the actual file, I found that the two bytes were
>&H73 and &H84. I assumed that the two bytes were stored LOW HIGH, so I
>reversed their position and ran them through a HEX-to-DEC calculator to
>obtain a confirmation of what I'd previously printed out. The
>calculated value was 33907.... NOT the -31629 I'd come to expect.
>
>Now I'm REALLY confused! Would anyone care to lend a helping hand and
Remember that QB is always going to assume an integer is signed, that's why
you got -31629. Try this:
num% = &H8473 'your number
PRINT num% 'shows -31629
IF num% < 0 THEN 'QB thinks it is a signed variable
PRINT num% + 65536 'shows 33907
END IF
Hey, there's your magic 33907! Of course you can't store that in an integer
since the maximum value for a signed short integer is +32767. You CAN
straighten it out with a long integer like this:
num% = &H8473
lnum& = num%
IF lnum& < 0 THEN lnum& = lnum& + 65536
PRINT lnum&
Moving between signed and unsigned numbers can be hazardous to the health of
your hair! {-)
<*> Jim
--- QM v1.00
* Origin: * EMC/80 * St Louis MO (314)843-0001 -=<HST/ds>=- (1:100/555.0)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #7574
Date: 11-19-92 04:22 (Public)
From: WALTON DELL
To: DAVID KOUTS
Subject: Paint Program
────────────────────────────────────────────────────────────────────────────────
-=> Quoting David Kouts to All <=-
DK> I'm kind of an amateur QBASIC programmer who likes to do a
DK> lot with graphics. I'm working on a (kind-of) drawing program, and was
DK> wondering if anyone could tell me how I could get input from a mouse?
DK> What commands would I use?
Here's a very simple paint program:
'This doesn't work with DOS 5 QBasic!
DEFINT A-Z
'$INCLUDE: 'QB.BI' 'do DIR \QB.BI /s if you need path
DECLARE SUB PrintScrn ()
DECLARE SUB MouseNow (leftbutton%, rightbutton%, xmouse%, ymouse%)
DECLARE SUB MouseShow ()
DECLARE SUB MouseHide ()
SUB MouseHide
DIM InRegs AS RegType, OutRegs AS RegType
InRegs.ax = 2
Interrupt 51, InRegs, OutRegs
END SUB
SUB MouseNow (leftbutton%, rightbutton%, xmouse%, ymouse%)
DIM InRegs AS RegType, OutRegs AS RegType
InRegs.ax = 3: leftbutton% = 0: rightbutton% = 0
Interrupt 51, InRegs, OutRegs
IF OutRegs.bx = 1 THEN leftbutton% = -1
IF OutRegs.bx = 2 THEN rightbutton% = -1
IF OutRegs.bx = 3 THEN leftbutton% = -1: rightbutton% = -1
xmouse% = OutRegs.cx: ymouse% = OutRegs.dx
END SUB
SUB MouseShow
DIM InRegs AS RegType, OutRegs AS RegType
InRegs.ax = 1
Interrupt 51, InRegs, OutRegs
END SUB
SUB PrintScrn
DIM InRegs AS RegType, OutRegs AS RegType
Interrupt 5, InRegs, OutRegs
END SUB
SCREEN 0, 0, 0, 0: CLS : COLOR 3: MouseShow
DO
MouseNow Left, Right, x, y
IF Left THEN
MouseHide
LOCATE y, x: PRINT CHR$(219);
MouseShow
ELSEIF Right THEN
MouseHide
LOCATE y, x: PRINT " ";
MouseShow
END IF
KeyPress$ = UCASE$(INKEY$)
IF KeyPress$ = "P" THEN PrintScrn
LOOP UNTIL KeyPress$ = "Q"
MouseHide
END
DK> I'm having to do all my programming on a word-processor and
DK> taking it to my grandparent's house to test it, since this dinky 256k
DK> computer of mine won't run QB. Is there any way I can get QB to run on
DK> this thing?
Not that I know of, but I'd HIGHLY recommend that you either upgrade
your memory, find a cheap (less than $15) XT motherboard (at least) if
you have IBM compatible parts, or buy a whole new system.
Walton Dell
P.S. I love to help beginners.
... Misspelled? No way! I have an error-correcting modem.
Blue Wave/QWK v2.10
--- WM v2.01/92-0162
* Origin: The Huff & Puff BBS (602)-996-0033 USR DS (1:114/144)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #7733
Date: 11-23-92 14:49 (Public)
From: JOHN GALLAS
To: MIKE KERR
Subject: Preserving orig. COMMAND$
────────────────────────────────────────────────────────────────────────────────
MK>The problem I'm having now, is similar, yet not. Sorry, I won't be
MK>cryptic any more! :-) I have just written a program that will print
MK>C:\QBASIC\PP.BAS
MK>Which is EXACTLY what I want. I get this from MID$(COMMAND$,4). So,
MK>what's the problem? When I compile the program, all that gets read in
MK>is:
MK>QBASIC\PP.BAS
<etc etc>
Heres a routine that'll use interrupts to read in the command line
entered from DOS. It shouldn't take off any characters, and it even
preserves upper/lower case.
'=================================================================
'Date: 04-11-91
'From: BRENT ASHLEY
'Subj: ORIGINAL COMMAND LINE; preserving lower case
'Conf: QBASIC (62)
'The command line as entered at the DOS prompt, in all its mixed-case
'splendour, is found at offset &H81 of the program's PSP (Program Segment
'Prefix), with the length of the command string at offset &H80 of the
'PSP.
'
'Finding your PSP from within QuickBASIC entails Interrupt calls.
' ~~~~~~~~~
'That same area of the PSP, however, is also the default disk transfer
'area for the program (or is it the default File Control Block? - I don't
'have my references handy) At any rate, I suspect QB always defines its
'own DTAs and FCBs, so the data won't be overwritten, but this cannot
'always be guaranteed. It would be best, therefore, if you were to get
'this info, to get it as early in the program's execution as possible,
'especially before any file I/O.
'======================================================================
DECLARE FUNCTION CmdLine$ ()
DEFINT A-Z
' $INCLUDE: 'qb.bi'
PRINT "Here's the original command line:"
PRINT "["; CmdLine$; "]"
END
FUNCTION CmdLine$
'
' CmdLine - returns original command line
'
DIM Regs AS RegType
STATIC CmdLen, CmdBuild$, i
'
' DOS Interrupt 21h service 62h returns the segment
' address of the running program's PSP in the bx register.
'
Regs.ax = &H6200
CALL Interrupt(&H21, Regs, Regs)
DEF SEG = Regs.BX
'
' The command line's length is found at offset 80h of the PSP
' and the actual command line starts at 81h
'
CmdBuild$ = ""
CmdLen = PEEK(&H80)
FOR i = 1 TO CmdLen
CmdBuild$ = CmdBuild$ + CHR$(PEEK(&H80 + i))
NEXT
'
' restore BASIC data segment and return data
'
DEF SEG
CmdLine$ = CmdBuild$
END FUNCTION
The only problem is, you can't change the command line from within the
QB environment, but if you're always running from an exe, it'll work
fine.
* OLX 2.1 TD * I don't have a life, I have a BBS..
--- RyPacker v2.5b
* Origin: The Ghost Mode - An RyBBS System! (612)-688-0026 (1:282/3006)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #9093
Date: 11-25-92 18:09 (Public)
From: GEORGE BATALIAS
To: DICK DENNISON
Subject: 19200+
────────────────────────────────────────────────────────────────────────────────
DD> > Are you doing 14.4 with OPEN COM?
DD> JH> NAK! (G). QB's Open stops at 9600. Using a neat third-party gizmo
(th
DD> NAK. You can use OPEN to 19200, Try it. (And you can poke it to 115k
DD> if you need to.)
Yea. Some of my DOORS run at 19200. Using qb45. Never saw them
run faster! Whats the secret? I don't use qbser or add on library. Just
straight qb code from CATPATCH.BAS part of it goes like this:
IF baud = 2400 then
bp$ = "2400"
' (cut out for shortness)
IF baud = 19200 then
bp$ = "19200"
END IF
'baud is the baud rate passed from the bbs dropfile
' maybe i could just add:
IF baud = 38400 then
bp$ = "38400"
IF baud = 76800 then
bp$ = ""76800"
' ETC up to 14,400
open com1 + ":" + bp$ + par$ for random as #3
"Whad du ya think?"
I'm not to familiar with POKE, PEEK, INTERUPTS, ETC
-----
For anyone else writing a door (or for outputing over the modem) that
doesn't want to spend the $$$ then i would recommend CATPATCH (uses
CALLINFO.BBS) or the new DPATCH (uses door.sys). Its FREE! Complete
source is included. (thats all there is, QB code!). I have modified
this code and i am a beginner. Works like a charm!. I bet someone could
modify it even for ANSI music(over the modem).....(G) any takers????
Well, anyway call Jim Brewers BBS (GULF COAST BBS)and you can get these
bas files ( i believe they are CATPATCH.ZIP and DPATCH.ZIP). He says he
doesn't support it anymore but they are there for DLD. (Thanks JIM!)
QB does go to 19200! ..... maybe more!
L8TR
GB
* OLX 2.2 * CORVETTE BBS...1-702-431-2284...Las Vegas...FS files...
--- WM v2.04/91-0049
* Origin: Reservation Only! Las Vegas,Nv~702-898-8630~ (1:209/721)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #9225
Date: 11-25-92 13:24 (Public)
From: PETER BARNEY
To: MICHAEL BAILEY
Subject: Variable Sharing in QB45
────────────────────────────────────────────────────────────────────────────────
> Thanks for the response, but my problem is sharing a typed record
> variable (ie COMMON SHARED RAC AS RACMAST, where RACMAST is a record
> variable defined in a TYPE statement) between SUB proceedures in
> different modules.
I couldn't find a problem... Try this:
'---------This is MODULE1.BAS---------
DECLARE SUB GetName ()
DECLARE SUB ChangeName ()
TYPE RacMast
name AS STRING * 10
age AS INTEGER
END TYPE
COMMON SHARED Rac AS RacMast
CALL GetName 'sub in this module
PRINT Rac.name
PRINT Rac.age
END
SUB GetName
Rac.name = "peter"
Rac.age = 20
CALL ChangeName 'sub in other module
END SUB
'---------This is MODULE2.BAS---------
TYPE RacMast
Name AS STRING * 10
Age AS INTEGER
END TYPE
COMMON SHARED Rac AS RacMast
SUB ChangeName
Rac.Name = "Mike"
Rac.Age = 25
END SUB
As you can see, the SUB ChangeName changes the data in Rac and returns it to
the calling SUB GetName, which in turn returns it to the module-level code in
MODULE1.BAS
If I'm missing something, or you have more questions, let me know.
--- FMail 0.92
* Origin: Pete's Place (1:234/35.1)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #10851
Date: 11-26-92 14:25 (Public)
From: JOHN GALLAS
To: DAVE WILLIAMS
Subject: Sequential Data Deletn
────────────────────────────────────────────────────────────────────────────────
DW> I am writing a program for a small business. It keeps a list ofrecords.
DW>Sometimes one or more records will need to be eliminated.
DW>Is there a way to delete individual records from a file? And then
DW>renumber the remaining records?
DW> Each record is for an account. So each has its 1st variable as:
DW> accnt.name Could I have the program check to see if accnt.name
DW> = space$(8), and if so delete that record?
DW> Thanks for any help. I'm pretty new in Qbasic and this is obviouslya
DW>pretty `basic' question
The only way that I know of to delete records from a random file is to
read it in, and output a second file, like this:
OPEN "ACCOUNTS.DAT" FOR RANDOM AS #1 LEN = LEN(Accnt)
OPEN "$$$$ii$i.uuu" FOR RANDOM AS #2 LEN = LEN(Accnt) 'dummy file
TotalRecords = LOF(1) \ LEN(Accnt)
Count = 0
FOR x = 1 TO TotalRecords
GET #1, x, Accnt
IF Accnt.name <> SPACE$(8) THEN
'if this record isn't blank then save it to the new file
Count = Count + 1
PUT #2, Count, Accnt
END IF
NEXT x
CLOSE 1, 2
KILL "ACCOUNTS.DAT"
NAME "$$$$i$ii.uuu" AS "ACCOUNTS.DAT"
'now all the records with blank names should be gone.
* OLX 2.1 TD * It's not "crippleware". It's "functionally challenged".
--- RyPacker v2.5b
* Origin: The Ghost Mode - An RyBBS System! (612)-688-0026 (1:282/3006)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #10994
Date: 11-28-92 05:52 (Public)
From: DICK DENNISON
To: DAVID COLSTON
Subject: 19200 baud in QB
────────────────────────────────────────────────────────────────────────────────
DD>NAK. You can use OPEN to 19200, Try it. (And you can poke it to 115k
DD>if you need to.)
DC> Well, don't stop there. Please give details.
Use the straight OPEN COM statement for 19200. To go higher you can
use this code (originally from Donn Bly):
SUB baudlatch 'enables 38400 baud want to put in com3 and com4 support
'NewBaud$ = "38400"
'BaudNum% = 3 'for 38.4
'BaudNum% = 2 'for 56000
BaudNum% = 1 'for 115K
SELECT CASE Port$
CASE "COM1:"
BaseAddress% = &H3F8
CASE "COM2:"
BaseAddress% = &H2F8
CASE "COM3:"
BaseAddress% = &H3E8
CASE "COM4:"
BaseAddress% = &H2E8
END SELECT
OldLSR% = INP(BaseAddress% + 3)
OUT (BaseAddress% + 3), (OldLSR% OR &H80) ' Enable the Divisor L
atch
OUT (BaseAddress% + 0), (BaudNum% MOD &HFF) ' Lo Byte of Baud Rate
OUT (BaseAddress% + 1), (BaudNum% \ &H100) ' Hi Byte of baud Rate
OUT (BaseAddress% + 3), OldLSR% ' Disable Divisor Latc
h
END SUB
'Sorry for the line wrap. Enjoy.
--- VP [DOS] V4.09e
* Origin: The MailMan (914)374-3903 NY Quick Share Pt #7 *HST (1:272/34)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #12296
Date: 11-29-92 23:10 (Public)
From: AARON LAPIKAS
To: LUKE MERRILL
Subject: Ctrl-Alt-Del Trap
────────────────────────────────────────────────────────────────────────────────
> an educational game for children. Can anyone give me a hint as to
> the best way to trap or disable the Ctrl-Alt-Del combination in QB.
Hi Luke!
I'm sure that this isn't the best way, and I'm sure that others will tell you
better ways of doing it, but my way will work. Here is an example:
KEY 15, CHR$(&H04)+CHR$(38) 'Define a key for CTRL-ALT
KEY(15) ON 'Turn the key on
ON KEY(15) GOSUB TrapKey
DO
LOOP 'Idle loop, used just as an example
TrapKey:
'When the CTRL-ALT combination is pressed,
RETURN 'the program branches to here, then returns
'to the program.
The only problem with this method is that the CAP-LOCK, SCROLL-LOCK, and NUM-
LOCK must be off. However, you can POKE to certain memory locations and shut
them off at the beginning of your program in case they were on. Again, this
is not the best way to do this, but if no one else helps you, it's a starting
place.
Aaron
--- FMail 0.90
* Origin: Send your Finleys and Hershisers to Sharon, PA. (1:2601/506.1)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #12646
Date: 11-29-92 12:15 (Public)
From: RICK PEDLEY
To: SCOTT WUNSCH
Subject: Accessing COM3/4:
────────────────────────────────────────────────────────────────────────────────
On 11-27-92 Scott Wunsch wrote to All...
SW> Salutations, All!
SW>
SW> I seems to me that I've seen a post here about COM3/4.
SW> All that was done was simply switching the addresses in low
SW> memory, and then 3 & 4 became 1 & 2. ;) Does anybody still
SW> have this? Or at least have the PEEK/POKE addresses
SW> necessary?
----------------------------------------------------------------------------
' DIAL BAS : Dial a phone number on the screen
' author .....: Dick Dennison [74270,3636] 1:272/34 914-374-3903 *hst 24 hrs
' supports ...: COM1 - COM4
' syntax .....: DIAL portnum%
' includes ...: None
' notes ......: Move the cursor with the arrow keys to the phone number
' : Press the spacebar and move the right arrow key across
' : the number and press Enter
' : Uses Basic's OPEN COMx commands
' cost .......: Free = Credit where credit due
' : Do not use as is for commercial use - may not be resold
' : May not be rebundled without prior written consent
' dated ......: 10/19/91,10/9/92
' credits ....: Thanks to Mike Welch for CLIPMSG, and Pete Petrakis for his
' : notes on Com Port swapping.
DECLARE SUB Hangup (port%)
DECLARE SUB Getnum (row%, Col%, markit%, port%)
DECLARE SUB Setup (port%)
LOCATE 1, 1
doscolor% = SCREEN(1, 1, -1)
fg% = doscolor% AND &HF
bg% = doscolor% / &H10 AND 6 '&H7 - 1
COLOR 0, 7
LOCATE 24, 1
PRINT " Move the cursor to the beginning of the phone number and press_
Space " 'line is wrapped
PRINT " DIALX from Dick Dennison";
GOTO Here
LOCATE 10, 1
IF VAL(COMMAND$) < 1 OR VAL(COMMAND$) > 4 THEN 'Get the portnum%
PRINT "Port number must be on command line"
END
ELSE port% = VAL(COMMAND$)
END IF
Here:
port% = 2 'Hard code the port here
'==================================================
'Setup some special key functions
CR$ = CHR$(13)
Nul$ = CHR$(0)
ArrowLt$ = Nul$ + CHR$(75)
ArrowRt$ = Nul$ + CHR$(77)
ArrowUp$ = Nul$ + CHR$(72)
ArrowDn$ = Nul$ + CHR$(80)
EndKey$ = Nul$ + CHR$(79)
Esc$ = CHR$(27)
BackSp$ = CHR$(8)
Home$ = Nul$ + CHR$(71)
SpaceBar$ = CHR$(32)
'===================================================
'Save vectors at bios Addresses for Com1-Com2
DEF SEG = 0
OldPort1H = PEEK(&H400)
OldPort1L = PEEK(&H401)
OldPort2H = PEEK(&H402)
OldPort2L = PEEK(&H403)
DEF SEG
'==================================================================
'Move cursor around
DO 'This section lets the user move
In$ = INKEY$ 'move the cursor around on the screen
SELECT CASE In$ 'to the beginning of the phone number
CASE CHR$(48) TO CHR$(57)
numflag% = -1
count% = count% + 1
markit% = -1
PRINT In$;
CASE CR$
IF markit% THEN 'A CR signals the end of the highlight
row% = CSRLIN
Col% = POS(0) - count%
IF numflag% THEN count% = count% - 1
EXIT DO
END IF
CASE Esc$ 'END
END
CASE Home$ 'Goto the beginning of the line
LOCATE , 1
CASE EndKey$ 'Goto the end of the line
LOCATE , 80
CASE ArrowUp$ 'UpArrow
x% = CSRLIN
IF x% > 1 THEN LOCATE x% - 1
CASE ArrowDn$ 'DownArrow
x% = CSRLIN
IF x% < 25 THEN LOCATE x% + 1
CASE ArrowLt$ 'LeftArrow
IF POS(0) > 1 THEN LOCATE , POS(0) - 1
IF markit% THEN count% = count% - 1 'If markit% then ' ' was
' pressed
CASE ArrowRt$ 'RightArrow
IF markit% THEN
count% = count% + 1 'If markit% then ' ' was pressed
row% = CSRLIN: Col% = POS(0)
a% = SCREEN(row%, Col%)
PRINT CHR$(a%);
ELSE
IF POS(0) < 80 THEN LOCATE , POS(0) + 1
END IF
CASE BackSp$
IF POS(0) > 1 THEN 'Backspace with delete
count% = count% - 1
LOCATE , POS(0) - 1
PRINT " ";
LOCATE , POS(0) - 1
END IF
CASE SpaceBar$
IF markit% THEN
count% = count% + 1 'If markit% then ' ' was pressed
row% = CSRLIN: Col% = POS(0)
a% = SCREEN(row%, Col%)
PRINT CHR$(a%);
ELSE
BEEP
markit% = -1 'Flag set for marking number
END IF
END SELECT
LOCATE , , 1 'Keep cursor flashing
LOOP
'======================================================================
'Get the phone number off the screen
Getnum row%, Col%, count%, port%
'Restore old vectors
CLOSE 1
'DEF SEG = 0
' POKE &H400, OldPort1H
' POKE &H401, OldPort1L
' POKE &H402, OldPort2H
' POKE &H403, OldPort2L
'DEF SEG
COLOR fg%, bg%
END
SUB Getnum (row%, Col%, markit%, port%)
GOTO Here1:
IF row% < 1 THEN row% = 1
IF Col% < 1 THEN Col% = 1
LOCATE row%, Col%
FOR x% = 0 TO markit% 'Read the phone number off the screen
a% = SCREEN(row%, Col% + x%)
Dialstr$ = Dialstr$ + CHR$(a%)
NEXT x%
Here1:
Dialstr$ = "544-1573"
LOCATE 23, 25
PRINT " Dialing : "; Dialstr$; " ";
LOCATE 25, 1
PRINT " Pickup handset and then press space or ESC when phone rings_
"; 'line is wrapped
COLOR 7, 0
Setup port%
PRINT #1, "ATM1DP" + Dialstr$ 'Dial the number
LOCATE 24, 1
DO
b$ = INKEY$
IF b$ = " " THEN
Hangup port%
EXIT DO
END IF
IF b$ = CHR$(27) THEN
Hangup port%
EXIT DO
END IF
LOOP
END SUB
SUB Hangup (port%)
PRINT SPACE$(25) + "...Disconnecting 1";
SELECT CASE port% 'Drop DTR
CASE 1
OUT &H3FC, (INP(&H3FC) AND 254) 'com1
CASE 2
OUT &H2FC, (INP(&H2FC) AND 254) 'com2
' CASE 3
' OUT &H3FC, (INP(&H3FC) AND 254) 'com3
' CASE 4
' OUT &H2FC, (INP(&H2FC) AND 254) 'com4
END SELECT
PRINT "...2...";
PRINT #1, "+++"; 'Switch to modem command mode if needed
SLEEP 1
PRINT #1, "ATH" 'Send hangup command
PRINT "...CLICK" + SPACE$(22);
END SUB
SUB Setup (port%)
'Sets up the comport by swapping the address fo com4 with com2 and
'com3 with com1 if necessary
'DEF SEG = 0
' POKE &H400, &HF8
' POKE &H401, 3
' POKE &H402, &HF8
' POKE &H403, 2
SELECT CASE port%
CASE 1
Start$ = "COM1:2400,N,8,1,DS0"
CASE 2
Start$ = "COM2:2400,N,8,1,DS0"
CASE 3
POKE &H400, &HE8 'For com1 to com3
Start$ = "COM1:2400,N,8,1,DS0"
CASE 4
POKE &H402, &HE8 'For com2 to com4
Start$ = "COM2:2400,N,8,1,DS0"
END SELECT
'DEF SEG
OPEN Start$ FOR RANDOM AS 1
END SUB
___--------------------------------------------------------------------
... OFFLINE 1.40
--- Maximus 2.01wb
* Origin: The BULLpen BBS * Intel 14.4EX (613)549-5168 (1:249/140)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #14193
Date: 12-01-92 05:15 (Public)
From: JERRY ALDRICH
To: ALL
Subject: Directory Tree
────────────────────────────────────────────────────────────────────────────────
Howdy,
Yesterday, I found myself in need of a routine to read and display the
directory tree in QB (actually PDS 7.1). I scanned the echo and found
there was a discussion going on about how to do just that. Seemed to
be 2 answers, get a LIB, and use SHELL "DIR > DIR.TXT". Since I didn't
want to go searching for a lib, I tried the latter. Basically, I modified
the WHEREIS program to look for directories instead of files. It worked,
but it was also SLOWWWW! On a 386sx/16 with a 15ms IDE drive and 176
directories, it took 97 seconds (compiled) to do the scan. I KNEW there
had the be a better way! I put some thought into it, and the following
code developed. It will NOT work on a Mono system, due to the fact it
uses 2 video pages, but it works just fine with color. The resulting
program will scan the same drive in 16.7 Seconds (compiled) or 19.5
seconds in the environment. And it's ALL QB code! Here 'tis:
------------------------------ CUT HERE -----------------------------------
DECLARE SUB GetDirs (Path$, Level%)
DECLARE SUB ShowTree ()
DEFINT A-Z
' Dimension Array to Hold Directories and Variable for Number of Dirs
DIM SHARED Path$(300), DCnt
' Set Active and Visual Pages to 1 and Clear Screen
SCREEN 0, , 1, 1: CLS
' Prompt User for Drive Letter and Prepare Screen
PRINT "Get Tree For Which Drive :";
DO: Drive$ = UCASE$(INKEY$): LOOP UNTIL LEN(Drive$): PRINT Drive$
PRINT "Scanning Drive " + Drive$ + " :"
' Set Frist Path to Root and Directory Count to 1
Path$(1) = Drive$ + ":": DCnt = 1
' Send Output to Page 0 (hide it)
SCREEN 0, , 0, 1
' Start Recursive Directory Scan
GetDirs Path$(1), 1
' Clear Screen and Set OutPut Back to Page 1 and Show Tree
CLS : SCREEN 0, , 1, 1
ShowTree
' Set All Pages to 0 and End
SCREEN 0, , 0, 0
END
SUB GetDirs (Path$, Level)
' Clear Screen, Display Sub Directories in Path$, Find out Last Line
CLS : FILES RTRIM$(Path$) + "\*.": LastLin = CSRLIN - 3
' Start Scanning Each Line of the Screen for Directory Entries
FOR Lin = 1 TO LastLin
FOR Col = 0 TO 3 ' Start with Column Offset of 0
D$ = "" ' Clear Temp Character Variable
DEF SEG = &HB800 ' Set Default Segment to Video Memory
' Read One Entry (17 Characters) From Video Memory
FOR Char = 0 TO 34 STEP 2
D$ = D$ + CHR$(PEEK(Lin * 160 + Col * 36 + Char))
NEXT
DEF SEG ' Set Default Segement Back to QB Data
' If Entry is a Sub Directory
IF INSTR(D$, "<DIR>") AND INSTR(D$, ".") = 0 THEN
' Update Count on Visible Page
DCnt = DCnt + 1: SCREEN 0, , 1, 1: LOCATE 2, 19
PRINT LTRIM$(STR$(DCnt)): SCREEN 0, , 0, 1
' Add the Parent Path to the Name
P$ = RTRIM$(Path$) + "\" + RTRIM$(LEFT$(D$, INSTR(D$, " ")))
' Store it to the Array
Path$(DCnt) = P$
' Do a Recursive Search of That Sub for Subs
GetDirs P$, Level + 1
' Find Last \ in Directory Name
DO
W = INSTR(W + 1, P$, "\"): IF W THEN P = W
LOOP WHILE W
' Parse Out the Parent Directory
P$ = LEFT$(P$, P - 1)
' Clear Screen, Re-Display Parent Directory, and Get Last Line
CLS : FILES P$ + "\*.": LastLin = CSRLIN - 3
END IF
NEXT
NEXT
END SUB
SUB ShowTree
CLS : S = 1: Top = 1: IF DCnt < 22 THEN Max = DCnt - 1 ELSE Max = 22
Refresh:
OldN = 0: N = 0
FOR I = Top TO Top + Max
P$ = Path$(I): N = 0: P = 0
DO
W = INSTR(W + 1, P$, "\"): IF W THEN P = W: N = N + 1
LOOP WHILE W
P2$ = Path$(I + 1): N2 = 0: P2 = 0
DO
W = INSTR(W + 1, P2$, "\"): IF W THEN P2 = W: N2 = N2 + 1
LOOP WHILE W
Nof$ = LEFT$(RIGHT$(P$, LEN(P$) - P) + SPACE$(20), 20)
IF INSTR(Nof$, ":") THEN
LOCATE I, S: PRINT LEFT$("\" + SPACE$(20), 20)
ELSE
T$ = "": FOR J = 1 TO N - 1: T$ = "│ " + T$: NEXT
IF N2 < N THEN T$ = T$ + "└" ELSE T$ = T$ + "├"
LOCATE I - Top + 1, S: PRINT T$ + "──";
PRINT Nof$
END IF
NEXT
DO: K$ = INKEY$: LOOP UNTIL LEN(K$)
IF LEN(K$) = 1 THEN K = ASC(K$) ELSE K = -ASC(RIGHT$(K$, 1))
SELECT CASE K
CASE 27
CLS : EXIT SUB
CASE -80
Top = Top + 1
CASE -72
Top = Top - 1
CASE -73
Top = Top - 19
CASE -81
Top = Top + 19
END SELECT
IF Top < 1 THEN Top = 1
IF Top + Max > DCnt THEN Top = DCnt - Max
GOTO Refresh
END SUB
------------------------------- CUT HERE --------------------------------
This Sub is to display the directory tree created by the previous sub.
It ain't much, but it works.
Any suggestions or comments about improving the speed would be greatly
appreciated!
Have fun with it!
Jerry Aldrich
--- Renegade v8-27 Beta
* Origin: The Bumpkinland BBS - "Home of BLand Software" (1:296/3)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #20350
Date: 12-06-92 22:23 (Public)
From: MARK REJHON
To: SHANE HEADER
Subject: Alphabetizer FUNCTION
────────────────────────────────────────────────────────────────────────────────
> Does anyone have a FUNCTION that that will
> alphabatize a complete
> string array? I have tried unsucessfuly. I'm sure I could do
> it, but I thought I would check with you guys to see if you had one
> lying around.
The simplest sorting algorithm, for a 100 string array, non-case sensitive,
is listed below. I assume that speed isn't important here. <G>
DO
Swapped% = 0
FOR StringNum% = 1 TO 99
IF UCASE$(Array$(StringNum%)) > UCASE$(Array$(StringNum% + 1)) THEN
SWAP Array$(StringNum%), Array$(StringNum% + 1)
Swapped% = -1
ENDIF
NEXT StringNum%
LOOP WHILE Swapped%
Mark Rejhon
--- FMail 0.92
* Origin: +++ VIddIBBS +++ (613) 521-4486! (1:163/255)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #20558
Date: 12-03-92 23:13 (Public)
From: ERIC B. FORD
To: MICHEL BERTLER
Subject: Prime numbers gen.
────────────────────────────────────────────────────────────────────────────────
> Your program is quite fast! However, could you make it
> ask for a user
> input (upper limit) and redirect its output into a
> readable Ascii file rather than on the screen?
Well, here's a version to have an upper limit. (For above 32767 change to
LONGs) To redirect it to an ASCII file you can just compile and then do
something like:
PRIME >Primes.txt
' Load QB with the "/l" option
DIM prime(32767) AS INTEGER: CLS
PRINT " Prime Number Generater"
PRINT " Eric Ford"
PRINT
PRINT "What number would you like to end checking at?"
INPUT Last%
PRINT : PRINT
INPUT "Filename (Leave blank for screen)"; File$
PRINT "The numbers below are prime. Now testing..."
tim1 = TIMER: half% = Last% / 2 + 1
FOR i% = 3 TO half% STEP 2
j% = 2
WHILE j% * i% <= Last%
prime(j% * i%) = 1
j% = j% + 1
WEND
NEXT i%
FOR j% = 4 TO Last% STEP 2
prime(j%) = 1
NEXT j%
FOR First% = 1 TO 3
prime(First%) = 0
NEXT First%
tim2 = TIMER
IF len(ltrim$(rtrim$(File$))) = 0 then
FOR i% = 2 TO Last%
IF prime(i%) = 0 THEN primes = primes + 1: PRINT i%
NEXT i%
else
open file$ for output as #1
for i% = 2 to Last%
if prime(i%) = 0 then
primes = primes + 1
print #1, i%
end if
next i%
close
end if
tim = tim2 - tim1
PRINT " --- Done --- "; primes;
PRINT " primes computed in"; tim; "seconds"
A good deal of this is from the message editor and not QB, so beware of minor
mistooks.
---
* Origin: Eric Ford (1:3632/1.6)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #20619
Date: 12-06-92 20:51 (Public)
From: BRENT ASHLEY
To: JOHN GALLAS
Subject: QB SIMULATNEOUS INPUT
────────────────────────────────────────────────────────────────────────────────
Here it is again - without any embellishment. - Brent -
'BASIC test code:
DECLARE FUNCTION KeyPressed%(ScanCode%)
CALL InstKeyPress ' install resident code
CLS
DO
LOCATE 1,1
FOR i% = 2 TO 9 ' scancode of 1 to 8
IF KeyPressed(i%) THEN PRINT CHR$(47+i%); ELSE PRINT " ";
NEXT
PRINT
LOOP UNTIL INKEY$=CHR$(27) ' escape to quit
CALL UnHookKeyPress ' unhook resident code - IMPORTANT!!!
END
; KeyPress.ASM by Brent Ashley
; checks the "pressed" status of any key
.model medium, basic
.code
Old09 Label Dword ;Label for to old Int 09h handler
Old09Offset dw ? ;Offset part
Old09Segment dw ? ;Segment part
Hooked db 0 ;Our installed flag
KeyMap db 80 dup(0) ;map of kybd, one byte per scancode
InstKeyPress proc uses ds ax dx ; From BASIC: CALL InstKeyPress
; REMEMBER to call UnhookKeyPress!
cmp cs:Hooked,0 ;Are we already hooked?
jnz InstallExit ;If so, exit
mov ax,3509h ;Get current vector for int 09h
int 21h
mov cs:Old09Segment,es ;Remember it for later
mov cs:Old09Offset,bx
mov ax,2509h
push ds
push cs
pop ds ;Point int 09h handler to our code
mov dx, offset OurInt09
int 21h
pop ds
mov cs:Hooked,-1 ;Set our installed flag
InstallExit:
ret
OurInt09: ;Our Int 09h handler
push ax
push bx
push dx
push si
in al, 60h
test al, 080h ;is "released" bit set?
jnz Released ;yup - go to it
mov dl, 0FFh ;nope - set key pressed flag
jmp PutFlag
Released:
and al, 07Fh ;yes - clear bit for index
mov dl, 0 ;and set flag for release
PutFlag:
xor ah, ah
mov si, ax ;assign index
mov cs:KeyMap[si], dl ;put flag in place
pop si
pop dx
pop bx
pop ax
Continue:
jmp dword ptr cs:[Old09];Transfer ctrl to orig Int 09h
InstKeyPress endp
KeyPressed proc uses bx si, ScanCode:WORD
; from BASIC: TrueOrFalse% = KeyPressed(ScanCode%)
mov bx, ScanCode ;get scan code addr
mov si, [bx] ;load value as index
mov al, cs:KeyMap[si] ;put flag in al
cbw ;convert to word for integer value
ret
KeyPressed endp
UnhookKeyPress proc ; from BASIC: CALL UnHookKeyPress
cmp cs:Hooked,0 ; are we installed?
jz UnHooked ; nope - exit
push ax
push ds
mov ax,2509h ;Unhook ourself
mov ds,Old09Segment
mov dx,Old09Offset
int 21h ;Point Int 09h back to orig hndlr
pop ds
pop ax
mov cs:Hooked,0 ;Set installed flag back to zero
UnHooked:
ret
UnhookKeyPress endp
END
--- FidoPCB v1.3 [ff053/x]
* Origin: Canada Remote Systems, Mississauga, Ontario (1:229/15)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #20725
Date: 12-07-92 21:06 (Public)
From: EARL MONTGOMERY
To: ALL
Subject: Animation (Page Flipping)
────────────────────────────────────────────────────────────────────────────────
I had asked in previous posts how I could avoid the PCOPY 7,0.
Well I finally figure it out. I had forgotten about the SWAP
command. For those that are interested here is the code again:
DEFINT A-Z: SCREEN 7: CLS : x = 60: pg = -1: v = 118: h = 30: up = 23
write2page% = 1: viewpage% = 0
Q$ = "E2U2R1U4H2R3U1D1R2U1D1R3G2D4R1D2F2L10"
n$ = "E2U1E2U2G2L1H1U1E4R3F2D4G1D2F2L10"
start:
FOR c = 0 TO 7
x = x + 1: h = h + 1: pg = pg + 1: up = up - 1
IF up < 5 THEN up = 23
SCREEN , , write2page%, viewpage%
CLS
LOCATE 2, 2: COLOR 3: PRINT "Demo Of Animation Using Page Flipping"
LOCATE up, 10: COLOR 1: PRINT "Chess Pieces In The Sky"
DRAW "BM=" + VARPTR$(x) + ",=" + VARPTR$(v)
DRAW "s8;C8;X" + VARPTR$(Q$): PAINT (x + 4, v - 2), 4, 8
DRAW "BM=" + VARPTR$(h) + ",=" + VARPTR$(v)
DRAW "C8;X" + VARPTR$(n$): PAINT (h + 4, v - 2), 15, 8
FOR z = 0 TO 50
PSET (RND * 320, RND * 200), RND * 15
SWAP write2page%, viewpage%
IF x > 300 THEN GOTO holdscrn
NEXT: NEXT
GOTO start
holdscrn:
GOTO holdscrn
' E N D
Earl
--- Maximus 2.01wb
* Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #21116
Date: 12-07-92 07:49 (Public)
From: ZACK JONES
To: TOM CARROLL
Subject: FIDO MESSAGES
────────────────────────────────────────────────────────────────────────────────
Hello Tom!
04 Dec 92, Tom Carroll writes to All:
TC> Does anyone know how to get the Destination Zone and Origin Zone numbers
TC> from a fido style .MSG?
Here's something I picked up some time ago - hopefully this will help.
Credit, of course, goes to Marshall Emm.
'By: Marshall Emm
REM Define the header of a Fido message
TYPE msghdr
FromUserName AS STRING * 36
ToUserName AS STRING * 36
Subject AS STRING * 72
DateTime AS STRING * 20
TimesRead AS INTEGER
DestNode AS INTEGER
OrigNode AS INTEGER
Cost AS INTEGER
OrigNet AS INTEGER
DestNet AS INTEGER
Fill AS STRING * 8
ReplyTo AS INTEGER
Attribute AS INTEGER
NextReply AS INTEGER
END TYPE
DIM Header AS msghdr
f$ = "d:2.msg"
OPEN f$ FOR BINARY AS 1
GET 1, 1, Header
size = LOF(1) - LEN(Header) + 1: Message$ = STRING$(size, 0)
GET 1, LEN(Header) + 1, Message$ 'text of message, i.e.
' everything after the header
CLOSE
PRINT "Message file: "; f$
PRINT
PRINT "FromUserName: "; Header.FromUserName
PRINT " ToUserName: "; Header.ToUserName
PRINT " Subject: "; Header.Subject
PRINT
PRINT " OrigNet: "; Header.OrigNet
PRINT " OrigNode: "; Header.OrigNode
PRINT " DestNet: "; Header.DestNet
PRINT " DestNode: "; Header.DestNode
PRINT
PRINT " DateTime: "; Header.DateTime
PRINT " TimesRead: "; Header.TimesRead
PRINT " Cost: "; Header.Cost
PRINT
PRINT " ReplyTo: "; Header.ReplyTo
PRINT " Attribute: "; Header.Attribute
PRINT " NextReply: "; Header.NextReply
PRINT
PRINT Message$
'now the fun starts if you want to format the text of Message$, which
'is a single "line."
Zack
--- GoldED 2.40
* Origin: Zack's Shack San Antonio, TX (210) 653-2115 (1:387/641)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #21943
Date: 12-07-92 22:52 (Public)
From: JOE NEGRON
To: SHANE HEADER
Subject: Alphabetizer FUNCTION
────────────────────────────────────────────────────────────────────────────────
SH> Does anyone have a FUNCTION that that will alphabatize a complete
> string array? I have tried unsucessfuly. I'm sure I could do it, but I
> thought I would check with you guys to see if you had one lying around.
What you need is a sort routine. There are a number of different
sorting methods; here is a relatively simple one, based on the Bubble
Sort, called a "Comb" sort:
============================== Begin code ==============================
DEFINT A-Z
DECLARE SUB CombSort (Array$())
'***********************************************************************
'* SUB CombSort
'*
'* PURPOSE
'* Sorts an array using the Comb sort algorithm.
'*
'* CREDIT(S)
'* This routine was taken from the article "A Fast, Easy Sort", by
'* Stephen Lacey and Richard Box, from the "Hands On" column of the
'* April 1991 issue of Byte.
'***********************************************************************
SUB CombSort (Array$()) STATIC
FirstEl% = LBOUND(Array$)
LastEl% = UBOUND(Array$)
Gap% = LastEl%
DO
IF Gap% * 8 / 11 > 1 THEN
Gap% = Gap% * 8 / 11
ELSE
Gap% = 1
END IF
Switch% = 0
FOR I% = FirstEl% TO LastEl% - Gap%
J% = I% + Gap%
IF Array$(I%) > Array$(J%) THEN
SWAP Array$(I%), Array$(J%)
Switch% = Switch% + 1
END IF
NEXT I%
LOOP UNTIL Switch% = 0 AND Gap% = 1
END SUB
=============================== End code ===============================
Simply pass your array to this SUB as follows:
CombSort Array$()
or
CALL CombSort(Array$())
As I said, there are a number of different sorting algorithms. I use
this one the majority of the time since it is small, simple, and fairly
fast.
Just for comparison's sake, here is a Shell sort:
============================== Begin code ==============================
DEFINT A-Z
DECLARE SUB ShellSort (Array$())
'***********************************************************************
'* SUB ShellSort
'*
'* PURPOSE
'* Sorts an array using the shell sort algorithm.
'***********************************************************************
SUB ShellSort (Array$()) STATIC
FirstEl% = LBOUND(Array$)
LastEl% = UBOUND(Array$)
Span% = LastEl% \ 2
DO WHILE Span% > 0
Boundary% = LastEl% - Span%
DO
Flag% = 0
FOR I% = FirstEl% TO Boundary%
IF Array$(I%) > Array$(I% + Span%) THEN
SWAP Array$(I%), Array$(I% + Span%)
Flag% = I%
END IF
NEXT I%
Boundary% = Flag% - Span%
LOOP WHILE Flag%
Span% = Span% \ 2
LOOP
END SUB
=============================== End code ===============================
Both of these routines are fairly fast, and require a minimal amout of
memory.
BTW, these routines are implemented as SUBs rather than FUNCTIONs,
because they do not need to return a value to the caller.
--Joe in Bay Ridge, Brooklyn, NY--
Mon 12-07-1992, 22:38
* SLMR 2.1a * Windows: Brought to you by the makers of Edlin!
--- Maximus 2.01wb
* Origin: * BlueDog BBS * (212) 594-4425 * NYC FileBone Hub (1:278/709)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #22064
Date: 12-07-92 23:29 (Public)
From: ERIC B. FORD
To: JEFFERY FOY
Subject: *.MSG
────────────────────────────────────────────────────────────────────────────────
Ah, looking at this I wonder:
'
' *** MAILFIND V1.00 Copyright 1992 Eric Ford ***
'
'ON ERROR GOTO errmsg:
' Open the file
TYPE headertype
fromname AS STRING * 36
toname AS STRING * 36
subject AS STRING * 72
datetime AS STRING * 20
timesread AS INTEGER
destnode AS INTEGER
orignode AS INTEGER
cost AS INTEGER
orignet AS INTEGER
destnet AS INTEGER
fill AS STRING * 8 ' WHAT???
replyto AS INTEGER
attribute AS INTEGER
nextreply AS INTEGER
END TYPE
What's in there? Anything important? Does Front Door need that dumb stuff
or is it 'reserved'? I am thinking of adding a automatic routing system to
VIPMAIL (BTW- Any suggestions?) and need some place to put it, and would
prefer not to have to invade the message body. Can I stuff it there? Any
other ideas?
---
* Origin: Eric Ford (1:3632/1.6)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #22629
Date: 12-08-92 13:13 (Public)
From: ROB MCKEE
To: ALL
Subject: Errorlevel
────────────────────────────────────────────────────────────────────────────────
Hi All,
I found out where MS-Dos V.5 Command.com keeps the ErrorLevel Info
(plus &h2b3 from the beginning of Command.com as Listed by Mem /d) Does
anyone know
C:\>MEM/D
Address Name Size Type
------- -------- ------ ------
000000 000400 Interrupt Vector
000400 000100 ROM Communication Area
000500 000200 DOS Communication Area
000700 IO 000A60 System Data
CON System Device Driver
_____________________/\ ____________________________
\/
COM4 System Device Driver
001160 MSDOS 0013D0 System Data
002530 IO 002C70 System Data
_____________________/\ ____________________________
\/
0051B0 MSDOS 000040 System Program
005200 COMMAND 000940 Program
005B50 EZPOINT 000040 Data
005BA0 COMMAND 000400 Environment
The byte on my computer as configured is 0054B3. But what I want to know
how to do is access the List of List from within QBas. I wrote an ASM
program thats hardcoded to read the Byte at &h54b3. I would like to be able
to find where COMMAND.COM start's in any computer and then read the
ERRORLEVEL.
n ErrLvl.com
RCX
4b
a
MOV AX,054B ; Point to Segment
PUSH DS ; Save Data Seg
MOV DS,AX ; Load new Data Segment
MOV AL,[0003] ; Get Errorlevel
POP DS ; Restore Data Segment
JMP 0113 ; Jmp around Data
DB 00 00 00 0D 0A 24 00 ; Working Data
MOV [0112],AL ; Save Errorlevel
CMP AL,00 ; Is it 0 don't need to Divide then
JZ 012F ; If 0 skip Divide
XOR AH,AH ; 0 out Remainder
MOV BL,0A ; Set Divisor
DIV BL ; Divide
MOV [010E],AH ; Save the 1's digit
XOR AH,AH ; 0 out Remainder
DIV BL ; Divide
MOV [010D],AH ; Save the 10's digit
MOV [010C],AL ; Save the 100's digit
MOV DX,010C ; Set start of string
MOV AH,09 ; Load for Output String Func
ADD BYTE PTR [010C],30 ; Add 30h to make it Ascii #
ADD BYTE PTR [010D],30 ; Add 30h to make it Ascii #
ADD BYTE PTR [010E],30 ; Add 30h to make it Ascii #
INT 21 ; Output the String
MOV AL,[0112] ; Get the ERRORLEVEL again
MOV AH,4C ; Setup for Exit with ERRORLEVEL
INT 21 ; ByeBye...
w
q
------------------------------ 8< ---------------------------
AS you can see, it Exit's with the same Errorlevel that it had coming into
it. I have a listing of the Dos 3.x Master List but I don't know if it's the
same as Dos 5. If I can intercept the ErrorLevel inside Qbas then I can
replace alot of 'IF ERRORLEVEL statements in my Bat Files and do more things
in my Bat files.
TTYL -Rob
--- EZPoint V2.1
* Origin: Flyer Proof Computer Services V# 510-237-8091 (1:125/1212.13)
TTYL -Rob
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #23279
Date: 12-08-92 07:56 (Public)
From: DAVID COLSTON
To: ALL
Subject: Sorts
────────────────────────────────────────────────────────────────────────────────
I have caught several post on sorts. In particular a need to sort a
directory. Here is a sample program for this in 7.1.
DECLARE SUB QuickSort (A$(), NumberofRecords!)
DIM A$(1000)
Count = 1
Filespect$ = "*.*"
A$(Count) = DIR$(Filespect$)
IF LEN(A$(1)) > 0 THEN
DO
A$ = DIR$
IF LEN(A$) > 0 THEN
Count = Count + 1
A$(Count) = A$
END IF
LOOP UNTIL LEN(A$) = 0
ELSE
Count = 0
END IF
IF Count > 0 THEN
QuickSort A$(), Count
OPEN "O", 2, "Files.Dir"
FOR I = 1 TO Count
PRINT #2, A$(I)
NEXT
CLOSE
END IF
SUB QuickSort (A$(), NumberofRecords) STATIC
False = 0
Offset = NumberofRecords \ 2
' Loop until offset gets to zero:
DO WHILE Offset > 0
Limit = NumberofRecords - Offset
DO
' Assume no switches at this offset:
Switch = False
' Compare elements and switch ones out of order:
FOR I = 1 TO Limit
IF A$(I) > A$(I + Offset) THEN
SWAP A$(I), A$(I + Offset)
Switch = I
END IF
NEXT I
' Sort on next pass only to where
' last switch was made:
Limit = Switch
LOOP WHILE Switch
' No switches at last offset, try one half as big:
Offset = Offset \ 2
LOOP
END SUB
'I hope this helps some of you.
* OLX 2.1 TD * Press any key to continue or any other key to quit
--- WM v2.04/92-0178
* Origin: Paradox of Arkansas *Wildcat 3.0* 501-646-7158 (1:19/121)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #24372
Date: 12-10-92 02:52 (Public)
From: JOHN SNEERINGER
To: SHANE HEADER
Subject: Alphabetizer FUNCTION
────────────────────────────────────────────────────────────────────────────────
* Originally addressed to All, Shane Header said:
SH-> Does anyone have a FUNCTION that that will
SH->alphabatize a complete
SH->string array? I have tried unsucessfuly. I'm sure I could do
SH->it, but I
SH->thought I would check with you guys to see if you had one
SH->lying around.
DEFINT A-Z
' ==============================================================
' The Fastest QuickBasic Sort Routine Alive. 516% faster than
' any living bubble array. THIS ONE DOES STRINGS, NOT NUMERICS.
' ==============================================================
DECLARE FUNCTION RandInt% (Lower, Upper)
DECLARE SUB QuickSort (Low, High)
DIM SHARED SortArray$(11)
CLS
SortArray$(1) = "6"
SortArray$(2) = "3"
SortArray$(3) = "5"
SortArray$(4) = "6"
SortArray$(5) = "8"
SortArray$(6) = "9"
SortArray$(7) = "5"
SortArray$(8) = "4"
SortArray$(9) = "3"
SortArray$(10) = "2"
SortArray$(11) = "1"
Low = 1
High = 11
CALL QuickSort(Low, High)
FOR a = Low TO High
PRINT SortArray$(a)
NEXT
SUB QuickSort (Low, High)
IF Low < High THEN
IF High - Low = 1 THEN
IF SortArray$(Low) > SortArray$(High) THEN
SWAP SortArray$(Low), SortArray$(High)
END IF
ELSE
RandIndex = RandInt%(Low, High)
SWAP SortArray$(High), SortArray$(RandIndex)
Partition$ = SortArray$(High)
DO
I = Low: J = High
DO WHILE (I < J) AND (SortArray$(I) <= Partition$)
I = I + 1
--- D'Bridge 1.30/071082
* Origin: RadioLink! Columbus, OH (614)766-2162 HST/DS (1:226/140)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #24373
Date: 12-10-92 02:54 (Public)
From: JOHN SNEERINGER
To: ALL
Subject: Rest of Q-Sort
────────────────────────────────────────────────────────────────────────────────
LOOP
DO WHILE (J > I) AND (SortArray$(J) >= Partition$)
J = J - 1
LOOP
IF I < J THEN
SWAP SortArray$(I), SortArray$(J)
END IF
LOOP WHILE I < J
SWAP SortArray$(I), SortArray$(High)
IF (I - Low) < (High - I) THEN
QuickSort Low, I - 1
QuickSort I + 1, High
ELSE
QuickSort I + 1, High
QuickSort Low, I - 1
END IF
END IF
END IF
END SUB
FUNCTION RandInt% (Lower, Upper) STATIC
' =======================================================================
' Returns a random integer greater than or equal to the Lower parameter
' and less than or equal to the Upper parameter.
' =======================================================================
RandInt% = INT(RND * (Upper - Lower + 1)) + Lower
END FUNCTION
---
* Origin: RadioLink! Columbus, OH (614)766-2162 QuickBasic! HST/DS
(1:226/140)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #3326
Date: 12-08-92 15:36 (Public)
From: VICTOR YIU
To: MICHEL BERTLER
Subject: Prime numbers gen.
────────────────────────────────────────────────────────────────────────────────
-=> Quoting Eric B. Ford to Michel Bertler <=-
To redirect:
EBF> PRIME >Primes.txt
________Clip here_______
' the slightly modified version of
' Eric Ford's prime # generator
DEFINT A-Z: CLS
INPUT "Highest #"; Last
DIM Prime(Last + 1) AS INTEGER
H = Last \ 2
T! = TIMER
FOR I = 3 TO H STEP 2
J = 2
WHILE J * I <= Last
Prime(J * I) = 1
J = J + 1
WEND
NEXT I
FOR J = 4 TO Last STEP 4
Prime(J) = 1
NEXT J
T! = TIMER - T!
PRINT "2 3";
FOR I = 3 TO Last STEP 2
IF Prime(I) = 0 THEN PRINT I;
NEXT I
PRINT
PRINT "Computed in"; T!; "seconds"
_______
This program is much neater (and slightly faster I think) than the
on-the-fly program he made...
... Restroom meter: [......../] Aaarhgh. I've got to go!!!
--- Blue Wave/RA v2.10 [NR]
* Origin: Hard Disc Cafe / Houston Texas / (713) 589-2690 / (1:106/30.0)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #3755
Date: 12-11-92 06:33 (Public)
From: STEVE GARTRELL
To: GEOFFREY LIU
Subject: Rotate GET/PUT arrays
────────────────────────────────────────────────────────────────────────────────
'For big arrays, this screams for conversion to assembly.
'But, using this, it's just a translation job.
'Remember, this is a pixel by pixel rotation, so at
'angles other than 0 or 180, lettering is reversed. (You'd
'need to approach it in blocks the size of a standard
'character in whichever screen mode you were in, to do
'writing. I wasn't going to do it all!!!)
DEFINT A-Z
DECLARE SUB RotateArray (SourceArray%(), TargetArray%(), Angle%)
'Must have the appropriate QB.QLB/QBX.QLB/VBDOS.QLB loaded
' if in the environment-link with appropriate library....
DECLARE SUB ABSOLUTE (Var%, BYVAL HowFar%, address AS INTEGER)
CONST C$ = "Created 12/01/92 by Steve Gartrell"
CONST NumBytes = 21
'$STATIC
DIM SHARED RORproc%(1 TO (NumBytes / 2))
'$DYNAMIC
DIM SHARED BitsPP%, Planes%, MaskBits%
DIM TheScreens%(1 TO 9)
offset% = VARPTR(RORproc%(1))
FOR byte% = 0 TO NumBytes - 1
READ opcode%
POKE (offset% + byte%), opcode%
NEXT byte%
TheScreens%(1) = 1
TheScreens%(2) = 2
TheScreens%(3) = 7
TheScreens%(4) = 8
TheScreens%(5) = 9
TheScreens%(6) = 11
TheScreens%(7) = 12
TheScreens%(8) = 13
KEY OFF
ScrCnt% = 8
DO
SCREEN TheScreens%(ScrCnt%)
MaskBits% = 128
SELECT CASE TheScreens%(ScrCnt%)
CASE 1 'Screen 1
MaskBits% = 192
BitsPP% = 2: Planes% = 1
ColorMod% = 3
CASE 2 'Screen 2
BitsPP% = 1: Planes% = 1
ColorMod% = 2
CASE 7 'Screen 7
BitsPP% = 1: Planes% = 4
ColorMod% = 16
CASE 8 'Screen 8
BitsPP% = 1: Planes% = 4
ColorMod% = 16
CASE 9 'Screen 9
BitsPP% = 1: Planes% = 4
ColorMod% = 16
CASE 11 'Screen 11
BitsPP% = 1: Planes% = 1
ColorMod% = 2
CASE 12 'Screen 12
BitsPP% = 1: Planes% = 4
ColorMod% = 16
CASE 13 'Screen 13
MaskBits% = 255
BitsPP% = 8: Planes% = 1
ColorMod% = 256
END SELECT
StartX% = 119: StartY% = 55: EndX% = 199: EndY% = 135
ArrayBytes& = 4 + INT(((EndX% - StartX% + 1)_
* (BitsPP%) + 7) / 8) * Planes% * ((EndY% - StartY%) + 1)
REDIM SourceArray%(0 TO ArrayBytes& \ 2)
REDIM BlankArray%(0 TO ArrayBytes& \ 2)
REDIM TargetArray%(0 TO 20)
GET (StartX%, StartY%)-(EndX%, EndY%), BlankArray%(0)
FOR TheLine% = 1 TO 24
LOCATE TheLine%, 1
FOR cnt% = 33 TO 72
SELECT CASE TheScreens%(ScrCnt%)
CASE 1, 2, 11
CASE ELSE
COLOR cnt% MOD ColorMod%
END SELECT
PRINT CHR$(cnt%);
NEXT
IF TheLine% <> 24 THEN PRINT
NEXT
GET (StartX%, StartY%)-(EndX%, EndY%), SourceArray%(0)
DO
DO: t$ = UCASE$(INKEY$): LOOP UNTIL LEN(t$)
SELECT CASE t$
CASE "Q" 'QUIT!!!!!
SCREEN 0: WIDTH 80: COLOR 7, 0: END
CASE "N" 'CHANGE SCREEN MODE!!!
ScrCnt% = ScrCnt% + 1
IF ScrCnt% = 9 THEN ScrCnt% = 1
EXIT DO
CASE ELSE 'ROTATE!!!!
Angle% = (Angle% + 90) MOD 360
RotateArray SourceArray%(), TargetArray%(), Angle%
WAIT &H3DA, 8, 8
WAIT &H3DA, 8
PUT (StartX%, StartY%), BlankArray%(0), PSET
PUT (StartX%, StartY%), TargetArray%(0), PSET
ERASE TargetArray%
END SELECT
LOOP
LOOP
RotRight:
DATA &H55 : 'push bp
DATA &H8B,&HEC : 'mov bp, sp
DATA &H51 : 'push cx
DATA &H8B,&H4E,&H06 : 'mov cx, [bp + 6]
DATA &H8B,&H5E,&H08 : 'mov bx, [bp + 8]
DATA &H8B,&H07 : 'mov ax, [bx]
DATA &HD2,&HC8 : 'ror al, cl
DATA &H89,&H07 : 'mov [bx], ax
DATA &H59 : 'pop cx
DATA &H5D : 'pop bp
DATA &HCA,&H04,&H00 : 'retf 4
REM $STATIC
DEFSNG A-Z
SUB RotateArray (SourceArray%(), TargetArray%(), Angle%)
DIM SourcePix%(1 TO 4)
DIM SourceBitsPP%, SourceBytesPerRow&, SourceRowOffset&
DIM SourceX%, SourceY%, BytePosCopy&, SourceBytePos&
DIM SourceRightMove%, SourceBitMask%, SourceToTargetDiff%
DIM TargetBitsPP%, TargetBytesPerRow&, TargetRowOffset&
DIM TargetRightMove%, TargetBytePos&, TargetX%, TargetY%
DIM WhichBits%, NumCols%, NumRows%
SELECT CASE BitsPP%
CASE 1
WhichBits% = 7
CASE 2
WhichBits% = 3
CASE 8
WhichBits% = 0
END SELECT
SourceBitsPP% = SourceArray%(0)
NumCols% = SourceBitsPP% \ BitsPP%
NumRows% = SourceArray%(1)
IF Angle% MOD 180 THEN
'Make it square if it's not!!!
SELECT CASE NumRows% - NumCols%
CASE IS < 0
NumCols% = NumRows%
CASE IS > 0
NumRows% = NumCols%
END SELECT
END IF
TargetBitsPP% = NumCols% * BitsPP%
IF TargetBitsPP% AND 7 THEN
TargetBytesPerRow& = (TargetBitsPP% \ 8 + 1) * Planes%
ELSE
TargetBytesPerRow& = (TargetBitsPP% \ 8) * Planes%
END IF
REDIM TargetArray%(0 TO ((TargetBytesPerRow& * NumRows%) \ 2) + 2)
TargetArray%(0) = TargetBitsPP%
TargetArray%(1) = NumRows%
TargetBytesPerPlane% = TargetBytesPerRow& \ Planes%
IF SourceBitsPP% MOD 8 THEN
SourceBytesPerPlane% = (SourceBitsPP% \ 8 + 1)
ELSE
SourceBytesPerPlane% = (SourceBitsPP% \ 8)
END IF
SourceBytesPerRow& = SourceBytesPerPlane% * Planes%
SourceRowOffset& = 4
SourceBytePos& = SourceRowOffset&
SourceRightMove% = 0
SourceBitMask% = MaskBits%
FOR SourceY% = 0 TO NumRows% - 1
FOR SourceX% = 0 TO NumCols% - 1
SELECT CASE Angle%
CASE 90
TargetX% = NumRows% - SourceY% - 1
TargetY% = NumCols% - SourceX% - 1
CASE 180
TargetX% = NumCols% - SourceX% - 1
TargetY% = NumRows% - SourceY% - 1
CASE 270
TargetX% = SourceY%
TargetY% = SourceX%
CASE ELSE
TargetX% = SourceX%
TargetY% = SourceY%
END SELECT
TargetRowOffset& = (TargetY% * TargetBytesPerRow&) + 4
TargetBytePos& = TargetRowOffset& + ((TargetX% * BitsPP%) \ 8)
TargetRightMove% = TargetX% AND WhichBits%
IF BitsPP% = 2 THEN
TargetRightMove% = TargetRightMove% + TargetRightMove%
END IF
SourceToTargetDiff% = (TargetRightMove% - SourceRightMove% + 8) AND 7
BytePosCopy& = SourceBytePos&
DEF SEG = VARSEG(SourceArray%(0))
FOR PlaneNum% = 1 TO Planes%
SourcePix%(PlaneNum%) = (PEEK(BytePosCopy&) AND SourceBitMask%)
BytePosCopy& = BytePosCopy& + SourceBytesPerPlane%
NEXT
IF SourceToTargetDiff% THEN
DEF SEG
RotRight% = VARPTR(RORproc%(1))
FOR PlaneNum% = 1 TO Planes%
CALL ABSOLUTE(SourcePix%(PlaneNum%), BYVAL_
SourceToTargetDiff%, RotRight%)
NEXT
END IF
DEF SEG = VARSEG(TargetArray%(0))
FOR PlaneNum% = 1 TO Planes%
POKE TargetBytePos&, PEEK(TargetBytePos&) OR SourcePix%(PlaneNum%)
TargetBytePos& = TargetBytePos& + TargetBytesPerPlane%
NEXT
DEF SEG
SourceRightMove% = (SourceRightMove% + BitsPP%) AND 7
IF SourceBitMask% AND 1 THEN
SourceBitMask% = MaskBits%
SourceBytePos& = SourceBytePos& + 1
ELSE
RotRight% = VARPTR(RORproc%(1))
CALL ABSOLUTE(SourceBitMask%, BYVAL BitsPP%, RotRight%)
END IF
NEXT
SourceRowOffset& = SourceRowOffset& + SourceBytesPerRow&
SourceBytePos& = SourceRowOffset&
SourceBitMask% = MaskBits%
SourceRightMove% = 0
NEXT
END SUB
--- D'Bridge 1.30/071082
* Origin: RadioLink! Columbus, OH (614)766-2162 HST/DS (1:226/140)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #5888
Date: 12-11-92 13:32 (Public)
From: SCOTT MAYFIELD
To: TERRY ROSSI
Subject: WORD WRAP CODE
────────────────────────────────────────────────────────────────────────────────
TR-=>A am becoming brain dead in my old age and cannot fiqure out how to
handle
TR-=>problem. I need to break a line that i read in from file A into two line
TR-=>file B, I am able to do that but I cannot fiqure out a good way to do a
wo
TR-=>wrap. Right now the software breaks the line at column 79 regardless of
w
TR-=>the word ends. I would like to have it break at the closest space to
colu
TR-=>so the the next line begins with a complete word. Anybody have any
ideas
I'll leave you to figger out most of the code ;), but here's your
algorithm...
Read in your line from file A
strip off any trailing blanks (RTRIM$())
starting at the end, locate the space character closest to the end.
FOR I% = LEN(TextFromA$) TO 1 STEP -1
IF MID$(TextFromA$, I%, 1) = " " THEN
SpaceLocation% = I%
EXIT FOR
END IF
NEXT I%
IF SpaceLoc% = 0 THEN SpaceLoc% = 79 ' No space in string, use whole
' thing...
Assign string 1 to be the left SpaceLoc%-1 characters of TextFromA$
Assign String 2 to be thr right Len(TextFromA$)-SpaceLoc% characters of
TextFromA$
write out string 1 to file B
loop back, reading next line from A and adding string 2 to the beginning
of it.
Scott @ 1:234/2
* SLMR 2.1 * On a clear disk you can seek forever
--- TMail v1.31
* Origin: Toledo's TBBS, 4+ gigs, 50,000 files 313-854-6001 (1:234/2)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #6624
Date: 12-13-92 02:03 (Public)
From: JOE NEGRON
To: BOB OEHRLE
Subject: Date$ ???
────────────────────────────────────────────────────────────────────────────────
BO> While in Dos if I call for the date I get Wed-12-12-92. If I print
> date$ in qb4.5 I get 12-12-92. Is there away that I can get the days
> to print ?? It seems that if I use Mid$ function I can't extract Wed .
> I'm trying to write a calendar routine that will alert me at start up
> every wednesday to preform a particular job.
> Bob in NJ
BASIC's DATE$ function does not return the day of the week. The
following does:
============================== Begin code ==============================
DEFINT A-Z
'$INCLUDE: 'qbx.bi'
DECLARE FUNCTION DOW$ ()
PRINT DOW$
SYSTEM
'***********************************************************************
'* FUNCTION DOW$
'*
'* PURPOSE
'* Uses DOS ISR 21H, Function 2AH (Get Date) to return the current
'* day of the week.
'*
'* EXTERNAL ROUTINE(S)
'* QBX.LIB
'* -------
'* SUB Interrupt (IntNum%, IRegs AS RegType, ORegs AS RegType)
'***********************************************************************
FUNCTION DOW$ STATIC
DIM IRegs AS RegType, ORegs AS RegType
IRegs.ax = &H2A00 'Function 2AH (Get Date)
Interrupt &H21, IRegs, ORegs 'Call DOS
al% = ORegs.ax AND &HFF 'extract al register
DOW$ = MID$("SunMonTueWedThuFriSat", (al% + 1) * 3 - 2, 3)
END FUNCTION
=============================== End code ===============================
If you are using QB 4.5, replace "'qbx.bi'" with 'qb.bi'. You must also
start QB up with the following command:
C:\>qb /l
Of course, this will only work if you want the *current* day of the
week. If you want to get the day of the week for dates other than the
current date, you need to use what are called "serial" dates; what you
do, in essence, is to convert the date into a serial ("in sequence")
number. Once you have done that, you can do all sorts of calculations
on it.
--Joe in Bay Ridge, Brooklyn, NY--
Sun 12-13-1992, 02:01
* SLMR 2.1a * Tagline Subsystem down at this time...
--- Maximus 2.01wb
* Origin: * BlueDog BBS * (212) 594-4425 * NYC FileBone Hub (1:278/709)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #6625
Date: 12-13-92 02:10 (Public)
From: JOE NEGRON
To: JOHN GALLAS
Subject: keyboard repeat speed
────────────────────────────────────────────────────────────────────────────────
JG> Is there any way I can increase the keyboard repeat speed?
Here you go:
============================== Begin code ==============================
DEFINT A-Z
'$INCLUDE: 'qbx.bi'
DECLARE SUB SetKBRate (InitDelay%, RepeatRate%)
SetKBRate 35, 250
SYSTEM
'***********************************************************************
'* SUB SetKBRate
'*
'* PURPOSE
'* Uses BIOS ISR 16H, Service 03H (Set Typematic Rate and Delay) to
'* set the typematic rate of an AT keyboard.
'*
'* EXTERNAL ROUTINE(S)
'* QBX.LIB
'* -------
'* SUB Interrupt (IntNum%, IRegs AS RegType, ORegs AS RegType)
'***********************************************************************
SUB SetKBRate (InitDelay%, RepeatRate%) STATIC
DIM IRegs AS RegType, ORegs AS RegType
IRegs.ax = &H305
IRegs.bx = InitDelay% * 256 + RepeatRate%
Interrupt &H16, IRegs, ORegs
END SUB
=============================== End code ===============================
Make sure that you start QB with the "/L" command line switch.
Note that you *must* have an AT for this routine to work.
--Joe in Bay Ridge, Brooklyn, NY--
Sun 12-13-1992, 02:10
* SLMR 2.1a * Press Esc to load the BBS, or Alt-H for IQ test.
--- Maximus 2.01wb
* Origin: * BlueDog BBS * (212) 594-4425 * NYC FileBone Hub (1:278/709)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #6626
Date: 12-13-92 02:18 (Public)
From: JOE NEGRON
To: MIKE JASKO
Subject: pause
────────────────────────────────────────────────────────────────────────────────
MJ> I would like to know how to put a simple pause in a QuickBasic
> program. For example, I want it to display a message when the program
> is ending and I want it to stay on the screen for a certin amount of
> time. Thanx in advance!!!
If you have PDS, you can use SLEEP:
SLEEP number-of-seconds
If you have QB, you can use the following:
============================== Begin code ==============================
DEFINT A-Z
DECLARE SUB Pause (Ticks&)
DECLARE FUNCTION ClockTicks& ()
'Pause for 10 seconds:
Pause 182
SYSTEM
'***********************************************************************
'* FUNCTION ClockTicks&
'*
'* PURPOSE
'* Returns the number of clock ticks since midnight.
'***********************************************************************
FUNCTION ClockTicks& STATIC
DEF SEG = &H40
ClockTicks& = PEEK(&H6C) + PEEK(&H6D) * 256& + PEEK(&H6E) * 65536
DEF SEG
END FUNCTION
'***********************************************************************
'* SUB Pause
'*
'* PURPOSE
'* Pauses a specified number of clock ticks. The clock ticks
'* approximately 18.2 times per second.
'*
'* INTERNAL ROUTINE(S)
'* FUNCTION ClockTicks& ()
'***********************************************************************
SUB Pause (Ticks&) STATIC
D& = ClockTicks& + Ticks&
IF D& > 1573038 THEN
D& = D& - 1573039
DO WHILE ClockTicks& > 1
LOOP
END IF
DO WHILE ClockTicks& < D&
IF INKEY$ > "" THEN
EXIT SUB
END IF
LOOP
END SUB
=============================== End code ===============================
The only real functional difference between these two methods is that
although PDS's SLEEP will quit if a key is pressed before the specified
period of time elapses, it will *not* remove the key from the keyboard
buffer while my Pause SUB will.
--Joe in Bay Ridge, Brooklyn, NY--
Sun 12-13-1992, 02:18
* SLMR 2.1a * You can observe a lot just by watching.
--- Maximus 2.01wb
* Origin: * BlueDog BBS * (212) 594-4425 * NYC FileBone Hub (1:278/709)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #6729
Date: 12-13-92 06:41 (Public)
From: DICK DENNISON
To: BOB OEHRLE
Subject: Date$ ???
────────────────────────────────────────────────────────────────────────────────
BO> While in Dos if I call for the date I get Wed-12-12-92. If I print
BO> date$ in qb4.5 I get 12-12-92. Is there away that I can get the days
BO> to print ?? It seems that if I use Mid$ function I can't extract Wed .
BO> I'm trying to write a calendar routine that will alert me at start up
BO> every wednesday to preform a particular job.
BO> Bob in NJ
'Try this:
'Day of Week - Dick Dennison 10/26/89
'$INCLUDE: 'qb.bi' 'load qb with the /L switch
'Interrupt 21 Function 2AH - get date
DIM InRegs AS RegType, OutRegs AS RegType
DIM Day(7) AS STRING * 3
Day$(0) = "Sun": Day$(1) = "Mon": Day$(2) = "Tue": Day$(3) = "Wed"
Day$(4) = "Thu": Day$(5) = "Fri": Day$(6) = "Sat"
CLS
InRegs.ax = &H2A * 256 '2Ah in ah
CALL INTERRUPT(&H21, InRegs, OutRegs)
' * * * cx is the year, dh is the month, dl is the date, al is the day
PRINT OutRegs.cx; " = year"
PRINT OutRegs.dx \ 256; " = month"
PRINT OutRegs.dx MOD 256; " = date"
daynum% = OutRegs.ax MOD 256
PRINT "Day of the week is "; Day$(daynum%)
--- VP [DOS] V4.09e
* Origin: The MailMan (914)374-3903 NY Quick Share Pt #7 *HST (1:272/34)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #8170
Date: 12-13-92 18:57 (Public)
From: PETER BARNEY
To: CRUZ MONCIVAIS
Subject: Loading .GIF and .PCX
────────────────────────────────────────────────────────────────────────────────
> PB> Your reply chain got tangled. You should've sent the reply to Harry
> PB> Gish. He did post some code for 256-pcx though. Did you get it?
> No I did not get that code? Is it possible to re-post?
I don't have the EXACT original code (it was written in ZBASIC, I converted
to QB), hope you don't mind Harry.
'(1127) Sat 21 Nov 92 1:56p
'By: Harry Gish
'To: All
'Re: 256 color PCX reader
'St:
'---------------------------------------------------------------------------
DEFINT A-Z
SCREEN 13
FileName$ = "256COLOR.PCX" 'fill in the blank
OPEN FileName$ FOR BINARY AS #2 LEN = 11
'Size# must be set to actual PCX file size in bytes
Size# = LOF(2)
'The first 128 bytes in the file are a header.
'Much of it is unused, or of no practical use.
'For simplicity we'll cover the important ones only.
header$ = SPACE$(128)
GET #2, , header$: CLS
'The first position is a PCX 'signature'.
Sig$ = LEFT$(header$, 1)
IF Sig$ <> CHR$(10) THEN PRINT "Invalid PCX file, no ZSoft header found": END
'The next header byte specifies the version.
'For 256 color it must be 5.
Ver$ = MID$(header$, 2, 1): Ver = ASC(Ver$)
IF Ver <> 0 AND Ver <> 2 AND Ver <> 3 AND Ver <> 5 THEN PRINT "Invalid
version number": END
'The next header byte specifies the color bits.
'For 256 color it must be 8.
ColorBits$ = MID$(header$, 4, 1): ColorBits = ASC(ColorBits$)
IF ColorBits <> 1 AND ColorBits <> 8 THEN PRINT "Invalid number of color
bits": END
'The image size is contained in 4 bytes
'starting at position 9 of the header.
XRes$ = MID$(header$, 9, 2)
XRes1$ = LEFT$(XRes$, 1): XRes2$ = RIGHT$(XRes$, 1)
XRes = ASC(XRes1$) + ASC(XRes2$) * 256 + 1
YRes$ = MID$(header$, 11, 2)
YRes1$ = LEFT$(YRes$, 1): YRes2$ = RIGHT$(YRes$, 1)
YRes = ASC(YRes1$) + ASC(YRes2$) * 256 + 1
'256 Color PCX
Bytes# = 128
Pointer = 0
'The palette information (definitions of the 256 colors)
'is contained in the last 768 bytes of the file. There
'is a "leading check-byte" of 0C (hex) preceding it.
'Here we're positioning to that check-byte.
SEEK #2, Size# - 769
a$ = " "
GET #2, , a$
'Now we read the next 768 bytes {256 x 3 for Red,
'Green and Blue definitions respectively}. Current
'paletting for PCX requires division by 4. If there
'is a "true-color" PCX format {and there may be and
'I don't know about it} I'd expect it to simply drop
'the division by 4 and make it the actual number.
FOR X = 0 TO 255
a$ = " "
GET #2, , a$
R = (ASC(MID$(a$, 1, 1)) / 4) AND 63
G = (ASC(MID$(a$, 2, 1)) / 4) AND 63
B = (ASC(MID$(a$, 3, 1)) / 4) AND 63
PALETTE X, R + G * 256 + B * 65536
NEXT
'Now we position at the 128th byte,
'which is where the data begins.
SEEK #2, 128
'Read a byte
DecodeGroup:
X$ = " "
IF EOF(2) THEN GOTO done
GET #2, , X$: X = ASC(X$): Bytes# = Bytes# + 1
'Now we must see if the byte represents a single color
'value or if it is a multiplier value. A quirk of 256
'COLOR PCX's is that a single value of the top 64 colors
'must be encoded as a multiplier of 1 times the color.
'You can't say COLOR 255, you must say 1 times 255. This
'makes many 256 color PCX files actually larger than a
'simple value dump. In this case if the byte value is
'less than 193 then it is an actual value.
'LONGIF ? - Harry, what the heck does LONGIF mean?
IF X < 193 THEN
PSET (Pointer, LineNo), X
Pointer = Pointer + 1
END IF
'Otherwise we interpret it as a multiplier.
'Multiplier value can be as large as 63.
'LONGIF ? - again?
IF X > 192 THEN
X = X - 192:
X$ = " "
GET #2, , X$: y = ASC(X$): Bytes# = Bytes# + 1
LINE (Pointer, LineNo)-(Pointer + X - 1, LineNo), y
Pointer = Pointer + X
END IF
'Pointer notes the current position in the X line scan.
'When the line is done Pointer gets reset to zero.
IF Pointer < XRes GOTO DecodeGroup
Pointer = 0
'If we're at end of line now we need to see if all lines are decoded.
'If so we end, otherwise we start processing the next line.
IF LineNo = YRes GOTO done
LineNo = LineNo + 1
GOTO DecodeGroup
done:
BEEP
WHILE INKEY$ = "": WEND
SCREEN 2, 1: SCREEN 0, 0: COLOR 15, 1, 4: CLS : END
--- FMail 0.92
* Origin: Pete's Place - Toledo, Ohio (1:234/35.1)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #8174
Date: 12-13-92 19:31 (Public)
From: PETER BARNEY
To: JOHN GALLAS
Subject: keyboard repeat speed
────────────────────────────────────────────────────────────────────────────────
> Is there any way I can increase the keyboard repeat speed?
'$INCLUDE: 'QBX.BI' or QB.BI
SUB KeySpeed (rate, delay)
'Sets the cursor typematic keyrate. Rate is the speed at which
'the keys repeat, the range is from 0 to 31, 0 being fastest.
'Delay is the amount of time in 250 millisecond parts before the
'keys begin to repeat. The range is from 0 to 3, 0 being the
'shortest wait.
DIM Regs AS RegType
Regs.ax = &H305
Regs.bx = (delay AND 3) * 256 + (rate AND 31)
CALL Interrupt(&H16, Regs, Regs)
END SUB
--- FMail 0.92
* Origin: Pete's Place - Toledo, Ohio (1:234/35.1)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #3811
Date: 12-12-92 04:23 (Public)
From: DAVE NAPLES
To: STEVE DEMO
Subject: directory tree
────────────────────────────────────────────────────────────────────────────────
│» I do have one question, Is it possible to find out what Drive and Dir
│» you are in with out doing the following:
╘═══════════════════════════════════════════════════════════════════════════
Two interrupts allow you to do these things. Remember, you have to have
the QB library loaded into the environment:
'$INCLUDE: 'QB.BI' 'Include definitions for INTERRUPT and
'INTERRUPTX
DIM regs AS RegType, regsx AS RegTypeX
'Dimension user-defined arrays
FindDir
SUB FindDir ()
regsx.ax = &H1900 'Load the value 19H into the high byte of
'the AX register
INTERRUPTX &H21, regsx, regsx
'Call the interrupt
drive = VAL("&H" + RIGHT$(HEX$(regsx.ax), 2))
'Assign the returned drive number to the
'variable «drive». 0 = A:, 1 = B:, etc.
DIM buffer AS STRING * 128
'Allocate a buffer to store the returned
'path name
regsx.ax = &H4700 'Load the high byte of the AX register with
'the value 47H
regsx.dx = drive 'Load the drive number into the low byte of
'the DX register
regsx.ds = VARSEG(buffer)
'Load the data segment address of the
'buffer into the DS register
regsx.si = VARPTR(buffer)
'Load the offset address of the buffer into
'the SI register
INTERRUPTX &H21, regsx, regsx
'Call the interrupt
IF (regsx.flags AND 1) = 0 then 'If the operation
LOCATE 1, 1: PRINT "DIRECTORY FOUND" 'was completed
ELSE 'successfully
LOCATE 1, 1: PRINT "DEVICE UNAVAILABLE"
END IF
END SUB
This should do the trick. It also goes a helluva lot faster
than shelling to DOS, writing a sequential file, then reading from the file.
Hope it helps.
The Resident Scholar
■ MegaMail 2.10 #0:"Can't we all just get along?" - G.A. Custer
--- SLMAIL v3.0/WL (#0109)
* Origin: Burleigh's BBS - 703-898-8153/898-2980 Philez,Jamez,Mzgz,K-Rad!
(1:274/6)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #3812
Date: 12-14-92 17:39 (Public)
From: DAVE NAPLES
To: MARK BUTLER
Subject: Alphabetizer FUNCTION
────────────────────────────────────────────────────────────────────────────────
│» How would you combine two string arrays? I am writing a program that
│» needs to combine the filespec matches from the current directory with
│» those found in another into one filename array and display the result
│» for a tag-list. I came up with something that halfway works but
│» looking back over my spaghetti pile of code I figgered "there has to
│» be any easier, cleaner way than this!" ... you know of an easy way to
│» append two such arrays?
╘═══════════════════════════════════════════════════════════════════════════
Try this fer size:
DIM array1(100), array2(100), array3(200)
:
:
:
:
:program code
:
:
:
:
FOR A = 1 TO 200
FOR B = 1 TO 100
array3(A) = array1(B)
NEXT B
FOR C = 1 TO 100
array3(A) = array2(C)
NEXT C
NEXT A
Kind of a kludge, but it'll work ...
The Resident Scholar
■ MegaMail 2.10 #0:Fer pete's sake, don't try this tagline at home!
--- SLMAIL v3.0/WL (#0109)
* Origin: Burleigh's BBS - 703-898-8153/898-2980 Philez,Jamez,Mzgz,K-Rad!
(1:274/6)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #3817
Date: 12-14-92 17:57 (Public)
From: DAVE NAPLES
To: JOHN WOODGATE
Subject: Looking for code
────────────────────────────────────────────────────────────────────────────────
│»I know 3 ways to get that information, here's the pathetic way.
╘═══════════════════════════════════════════════════════════════════════════
The NON-pathetic way runs thusly (remember, ya gotta have
QB.LIB ta run this:)
'$INCLUDE: 'qb.bi'
DIM regs AS RegType, regsx AS RegTypeX
regsx.ax = &H1A00
INTERRUPTX &H10, regsx, regsx
vmode = VAL("&H" + RIGHT$(HEX$(regsx.bx), 2))
SELECT CASE vmode
CASE 0
monitor$ = "No card installed"
CASE 1
monitor$ = "MDA Display"
CASE 2
monitor$ = "CGA Display"
CASE 4
monitor$ = "EGA or EGA Mutlisync Display"
CASE 5
monitor$ = "EGA Mono Display"
CASE 7
monitor$ = "VGA Analog Mono Display"
CASE 8
monitor$ = "VGA Analog or VGA Analog Multisync Display"
CASE 255
monitor$ = "Unknown Video Card Type"
END SELECT
That does the trick. Hope it helps.
The Resident Scholar
■ MegaMail 2.10 #0:"Do me WILD, baby!" - P. Schlafly
--- SLMAIL v3.0/WL (#0109)
* Origin: Burleigh's BBS - 703-898-8153/898-2980 Philez,Jamez,Mzgz,K-Rad!
(1:274/6)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #4053
Date: 12-17-92 11:27 (Public)
From: CORIDON HENSHAW
To: ERIC B. FORD
Subject: *.MSG
────────────────────────────────────────────────────────────────────────────────
Hello Eric!
In a msg of <15 Dec 92>, Eric B. Ford writes to Coridon Henshaw:
>> For storing data that isn't in the header, use a kluge
>> line. The only "rule" is that they start with a
>> CHR$(1) and have no CR or LF on the end. Here's two
>> examples from your message:
>> EBF> @MSGID: 1:3632/1.6 ab175def
EBF> Ok, but how to I have a carrage return if I don't put one in?
Hold your questions. I'm posting the FTSC standard for messages. 200+ lines
folow.
===Chop===
[...]
4. Data Description
A language specific notation was avoided. Please help stamp out
environmental dependencies. Only you can prevent PClone market
dominance. Don't panic, there are rectangular record layouts too.
(* non-terminals *)
UpperCaseName - to be defined further on
(* literals *)
"ABC" - ASCII character string, no termination implied
nnH - byte in hexadecimal
(* terminals *)
someName - 16-bit integer, low order byte first (8080 style)
someName[n] - field of n bytes
someName[.n] - field of n bits
someName(n) - Null terminated string allocated n chars (incl Null)
someName{max} - Null terminated string of up to max chars (incl Null)
(* punctuation *)
a b - one 'a' followed by one 'b'
( a | b ) - either 'a' or 'b', but not both
{ a } - zero or more 'a's
[ b ] - zero or one 'b'
(* comment *) - ignored
(* predeclared constant *)
Null = 00H
[...]
1. Application Layer Data Definition : a Stored Message
Stored Message
Offset
dec hex
.-----------------------------------------------.
0 0 | |
~ fromUserName ~
| 36 bytes |
+-----------------------+-----------------------+
36 24 | |
~ toUserName ~
| 36 bytes |
+-----------------------+-----------------------+
72 48 | |
~ subject ~
| 72 bytes |
+-----------------------+-----------------------+
144 90 | |
~ dateTime ~
| 20 bytes |
+-----------------------+-----------------------+
164 A4 | timesRead (low order) | timesRead (high order)|
+-----------------------+-----------------------+
166 A6 | destNode (low order) | destNode (high order) |
+-----------------------+-----------------------+
168 A8 | origNode (low order) | origNode (high order) |
+-----------------------+-----------------------+
170 AA | cost (low order) | cost (high order) |
+-----------------------+-----------------------+
172 AC | origNet (low order) | origNet (high order) |
+-----------------------+-----------------------+
174 AE | destNet (low order) | destNet (high order) |
+-----------------------+-----------------------+
176 B0 | fill |
~ 8 bytes ~
+-----------------------+-----------------------+
184 B8 | replyTo (low order) | replyTo (high order) |
+-----------------------+-----------------------+
186 BA | Attribute (low order) | Attribute (high order)|
+-----------------------+-----------------------+
188 BC | nextReply (low order) | nextReply (high order)|
+-----------------------+-----------------------+
190 BE | text |
~ unbounded ~
| null terminated |
`-----------------------------------------------'
4
Message = fromUserName(36) (* Null terminated *)
toUserName(36) (* Null terminated *)
subject(72) (* see FileList below *)
DateTime (* message body was last edited *)
timesRead
destNode (* of message *)
origNode (* of message *)
cost (* in lowest unit of originator's
currency *)
origNet (* of message *)
destNet (* of message *)
fill[8]
replyTo (* msg to which this replies *)
AttributeWord
nextReply (* msg which replies to this *)
text(unbounded) (* Null terminated *)
DateTime = (* a character string 20 characters long *)
(* 01 Jan 86 02:34:56 *)
DayOfMonth " " Month " " Year " "
" " HH ":" MM ":" SS
Null
DayOfMonth = "01" | "02" | "03" | ... | "31" (* Fido 0 fills *)
Month = "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun" |
"Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"
Year = "01" | "02" | .. | "85" | "86" | ... | "99" | "00"
HH = "00" | .. | "23"
MM = "00" | .. | "59"
SS = "00" | .. | "59"
AttributeWord bit meaning
--- --------------------
0 + Private
1 + s Crash
2 Recd
3 Sent
4 + FileAttached
5 InTransit
6 Orphan
7 KillSent
8 Local
9 s HoldForPickup
10 + unused
11 s FileRequest
12 + s ReturnReceiptRequest
13 + s IsReturnReceipt
14 + s AuditRequest
15 s FileUpdateReq
s - this bit is supported by SEAdog only
+ - this bit is not zeroed before packeting
Bits numbers ascend with arithmetic significance of bit position.
----------------------------------------------------------
---------------------
Message Text
Message text is unbounded and null terminated (note exception below).
A 'hard' carriage return, 0DH, marks the end of a paragraph, and must
be preserved.
So called 'soft' carriage returns, 8DH, may mark a previous
processor's automatic line wrap, and should be ignored. Beware that
they may be followed by linefeeds, or may not.
All linefeeds, 0AH, should be ignored. Systems which display message
text should wrap long lines to suit their application.
If the first character of a physical line (e.g. the first character of
the message text, or the character immediately after a hard carriage
return (ignoring any linefeeds)) is a ^A (<control-A>, 01H), then that
line is not displayed as it contains control information. The
convention for such control lines is:
o They begin with ^A
o They end at the end of the physical line (i.e. ignore soft <cr>s).
o They begin with a keyword followed by a colon.
o The keywords are uniquely assigned to applications.
o They keyword/colon pair is followed by application specific data.
Current ^A keyword assignments are:
o TOPT <pt no> - origin point address
o FMPT <pt no> - origin point address
o INTL <dest z:n/n> <orig z:n/n> - used for inter-zone address
In order to provide minimal support for NAPLPS graphics, applications
should display without interpretation any bytes found between ????,
??H, and ????, ??H. The surrounded data bytes may be any eight bit
characters with the exception of the terminating byte, ??H. Do not
strip carriage returns, soft or hard, or linefeeds.
----------------------------------------------------------
---------------------
File Specifications
If one or more of FileAttached, FileRequest, or FileUpdateReq are
asserted in an AttributeWord, the subject{72} field is interpreted as
a list of file specifications which may include wildcards and other
system-dependent data. This list is of the form
FileList = [ FileSpec { Sep FileSpec } ] Null
FileSpec = (* implementation dependent file specification. may
not contain Null or any of the characters in Sep. *)
Sep = ( " " | "," ) { " " }
There are deviations from and additions to these specifications
1 - Fido does not necessarily terminate the message text with a Null,
but uses an empty line (0DH 0AH 0DH 0AH)
2 - SEAdog zeros the message cost field when building a message.
4 - SEAdog uses a different format for dates, e.g.
DateTime = (* a character string 20 characters long *)
(* SEAdog format Mon 1 Jan 86 02:34 *)
DayOfWk " " DayOfMo " " Month " " Year "
" HH ":" MM Null
DayOfWeek = "Mon" | "Tue" | "Wed" | "Thu" | "Fri" | "Sat" | "Sun"
DayOfMon = " 1" | " 2" | " 3" | ... | "31" (* blank fill *)
===CHOP===
Coridon Henshaw
Sirrus| /
--*--
/ |Software
...Taco Bell is not a Mexican phone company.
--- GEcho 1.00
* Origin: TCS Concordia - Mail Only - Toronto, Ontario (1:250/820)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #4365
Date: 12-17-92 20:50 (Public)
From: STEVE DEMO
To: ANDY C. OLIVER
Subject: DIRECTORY TREE
────────────────────────────────────────────────────────────────────────────────
-=> Quoting Andy C. oliver to Steve Demo <=-
ACo> You might try a Library, such as Tom Hanlin's PBCLONE. PBCLONE17 is
ACo> the latest to date (as far as I know), and it has such routines. As
ACo> do many other good libraries.
ACo> ACO
Hello,
I have used Pbclone before just was curious if QB could do it by it's self.
I would like to learn all about QB with out useing any libarys. But I did
get some code to do it . This was Given to me By Rick Cooper.
==========================<cut here>========================================
DECLARE FUNCTION CurrentDir$ ()
FUNCTION CurrentDir$
DEFSNG A-Z
DIM InRegs AS RegTypeX, OutRegs AS RegTypeX
'====================================================================
' This Function Will Return The Current Path With A Complete Path Spec
' Including Drive And Trailing "\"
' If You Don't Want The trailing "\" Then Use A Left$ Statement To
'Remove It... E.G. Dir$ = Left$(CurrentDir$,Len(CurrentDir$) - 1)
'===================================================================
InRegs.ax = &H1900 'Use Dos Function To Get
CALL INTERRUPTX(&H21, InRegs, OutRegs) 'Current Drive
drive% = (OutRegs.ax AND &HFF) + 1 'Function Returns 0 Based
'Drive Number And Next
'Function needs A 1 Based
'Number So We Add 1 To Result
drive$ = CHR$(64 + drive%) 'Create String Representation
'In Uppercase, Of Current
'Drive Number
DIRECTORY$ = SPACE$(64) 'Create Scratch Buffer
InRegs.ax = (256 * &H47) + 0 'Load Function Number
InRegs.dx = (256 * 0) + drive% 'Load Drive Number
InRegs.ds = VARSEG(DIRECTORY$) 'Pointer To A 64 Byte
InRegs.si = SADD(DIRECTORY$) 'Scratch Buffer
CALL INTERRUPTX(&H21, InRegs, OutRegs) 'Call Dos Int. 21 Func. 47
spot = INSTR(DIRECTORY$, CHR$(0)) 'Function Returns An ASCIIZ
IF spot <> 0 THEN 'String And We Don't Want The
DIRECTORY$ = LEFT$(DIRECTORY$, spot - 1) 'Terminating Null Character
END IF 'So This Removes It And
'Trailing Spaces
IF LEN(DIRECTORY$) > 1 THEN 'If It Isn't The Root Then
'We Add A Trailing "\"
CurrentDir$ = drive$ + ":\" + DIRECTORY$ + "\"
ELSE 'If It Is The Root We Don't
CurrentDir$ = drive$ + ":\" + RTRIM$(LTRIM$(DIRECTORY$))
END IF 'Done!
END FUNCTION
========================<cut here>==========================================
Just thought I would share what was given to me.
Take it easy,
Steve Demo
... Pardon Me, But Would You Have Any Blue Poupon?
--- Blue Wave/QBBS v2.11 [NR]
* Origin: Just For The Heck Of It II -=(Fort Wayne In)=- (1:236/16.0)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #8229
Date: 12-21-92 15:43 (Public)
From: TONY ELLIOTT
To: STEVE PERRY
Subject: FCB's
────────────────────────────────────────────────────────────────────────────────
Steve,
SP> This is probably a dumb question, but here it goes. I need to get the
SP> size of a file. I'm currently doing a shell command and directing it
SP> to a file that I open and then search for the needed data. I was
SP> looking through a interrupts book and it shows that interrupt 21h with
SP> ah = 23h and ds:dx = pointer to an unopened file control block. Can
SP> this be done in PDS? If so how? How do you access a FCB anyway?
SP> Any and all help would be appreciated!
The easiest way is to open the file for input and look at LOF:
OPEN "ThisFile.Dat" FOR INPUT AS #1
Length& = LOF(1)
CLOSE #1
If you are going to use an interrupt call instead, I'd recommend the
Find First function (4Eh) instead. That'll load the DTA area with
with the file length, date, time, and attribute. Such code could be
easily modified to get directory names, volume labels, and even to load
an array with a list of files based on a filespec. Here's some code to
get some info about a specific file. You'll need to load the standard
QBX.QLB when starting the IDE. If you are using QB4.x instead, change
the $INCLUDE to "QB.BI":
DEFINT A-Z
REM $INCLUDE: 'QBX.BI'
TYPE Dta
Dummy1 AS STRING * 21
Attr AS STRING * 1
FTime AS INTEGER
FDate AS INTEGER
FLen AS LONG
FilName AS STRING * 13
END TYPE
FUNCTION FileInfo% (FileName$, FilDate$, FilTime$, Attr%, Length&)
DIM LclDta AS Dta, Reg AS RegTypeX
DIM TempFil AS STRING * 68
'Get the current DTA address and save it.
Reg.AX = &H2F00
CALL InterruptX(&H21, Reg, Reg)
OldDtaSeg = Reg.ES
OldDtaOfs = Reg.BX
'Change the DTA to avoid screwing up any work BASIC may be
'doing when this function was invoked (DIR$, for example).
Reg.AX = &H1A00
Reg.DS = VARSEG(LclDta) 'Point DTA to our structure
Reg.DX = VARPTR(LclDta)
CALL InterruptX(&H21, Reg, Reg)
'We use a fixed-length string to hold an ASCIZ copy of the file
' name. We don't use a convention string because then the code
' would have to be customized for QB/PDS/VBDOS. This way, one
' version works with all.
TempFil = FileName$ + CHR$(0)
Reg.AX = &H4E00 'Find First
Reg.CX = 32 'Normal and "archive" files
Reg.DS = VARSEG(TempFil) 'Address of our FL ASCIZ string
Reg.DX = VARPTR(TempFil)
CALL InterruptX(&H21, Reg, Reg)
IF Reg.Flags AND 1 THEN
Status% = Reg.AX
ELSE
Status% = 0
Yr$ = LTRIM$(STR$((PEEK(VARPTR(LclDta.FDate) + 1) AND &HFE) \ 2 +
1980))
Mon$ = LTRIM$(STR$((LclDta.FDate AND &H1E0) \ 32))
Dy$ = LTRIM$(STR$(LclDta.FDate AND &H1F))
FileDate$ = Mon$ + "/" + Dy$ + "/" + Yr$
Sec$ = LTRIM$(STR$((LclDta.FTime AND &H1F) * 2))
Min$ = LTRIM$(STR$((LclDta.FTime AND &H7E0) \ 32))
Hr$ = LTRIM$(STR$((PEEK(VARPTR(LclDta.FTime) + 1) AND &HF8) \ 8))
FileTime$ = Hr$ + ":" + Min$ + ":" + Sec$
Attr = ASC(LclDta.Attr)
Length& = LclDta.FLen
END IF
Reg.AX = &H1A00 'Restore the old DTA address
Reg.DS = OldDtaSeg
Reg.DX = OldDtaOfs
CALL InterruptX(&H21, Reg, Reg)
END FUNCTION
To use it, just:
DECLARE FUNCTION FileInfo%(FileName$, FilDate$, FilTime$, Attr%, Length&)
Status% = FileInfo%("\AUTOEXEC.BAT", FilDate$, FilTime$, Attr%, Length&)
IF Status% THEN
PRINT "DOS Error";Status%;"occurred!"
ELSE
PRINT FilDate$,FilTime$,FilAttr%,Length&
END IF
--- Blue Wave/Max v2.10 [NR]
* Origin: Oakland BBS - McDonough, GA - (404) 954-0071 (1:133/706.0)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #5565
Date: 12-24-92 15:38 (Public)
From: LUIS ESPINOZA
To: JEFFERY FOY
Subject: 4DOS and detecting it
────────────────────────────────────────────────────────────────────────────────
On (21 Dec 92) Jeffery Foy wrote to All...
JF> I'd like to add 4DOS support in a program that I'm writing. How can
JF> you
JF> detect it from BASIC? Is there a special call or something? I thought
JF> about just looking for 4DOS.COM in the PATH but that seems a bit
JF> tacky.
JF>
Try something like:
a$=Environ$("COMSPEC")
if instr(a$,"4DOS") then FFos=1 else FFos=0
Luis
--- PPoint 1.33
* Origin: The Rubber Room (1:207/213.5)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #6645
Date: 12-27-92 12:27 (Public)
From: DIK COATES
To: CORIDON HENSHAW
Subject: scroll part 1 of 3
────────────────────────────────────────────────────────────────────────────────
>>>> QUOTING Coridon Henshaw to Dik Coates <<<<
DC> You talkin' text mode, or graphics mode... Text mode, I have a series
DC> of routines I will upload if you want...
CH> I'd like to see that. Both upward and downward, please ;>
Here goes... Will set it up in three chunks...
The first file converts a normal ASCII file to one that can be read
as a binary file.
- - - - - - - - - - - - Cut on Dashed Line - - - - - - - - - - - - -
DECLARE FUNCTION FILEEXIST% (filename$)
DECLARE SUB CommandLine (narg%, arg$())
REDIM arg$(32)
CALL CommandLine(narg%, arg$())
CLS
IF narg% <> 0 THEN
REDIM PRESERVE arg$(narg%)
IF narg% > 2 THEN
LOCATE 12, 25
PRINT "Too many arguments on Command Line"
LOCATE 23, 21
PRINT ">>>>> Press Any Key to Exit to DOS <<<<<";
DO
a$ = INKEY$
LOOP UNTIL LEN(a$)
CLS
END
END IF
IF narg% < 2 THEN
LOCATE 12, 25
PRINT "Insufficient arguments on Command Line"
LOCATE 23, 21
PRINT ">>>>> Press Any Key to Exit to DOS <<<<<";
DO
a$ = INKEY$
LOOP UNTIL LEN(a$)
CLS
END
END IF
IF NOT FILEEXIST%(arg$(1)) THEN
LOCATE 12, 25
PRINT "Text File does not Exist"
LOCATE 23, 21
PRINT ">>>>> Press Any Key to Exit to DOS <<<<<";
DO
a$ = INKEY$
LOOP UNTIL LEN(a$)
CLS
END
ELSE
filenum1% = FREEFILE
OPEN arg$(1) FOR INPUT AS #filenum1%
filenum2% = FREEFILE
OPEN arg$(2) FOR BINARY AS #filenum2%
DO WHILE NOT EOF(filenum1%)
LINE INPUT #filenum1%, strdummy$
count% = count% + 1
LOOP
CLOSE #filenum1%
PUT #filenum2%, , count%
filenum1% = FREEFILE
OPEN arg$(1) FOR INPUT AS #filenum1%
FOR c% = 1 TO count%
LINE INPUT #filenum1%, strdummy$
lendummy% = LEN(strdummy$)
PUT #filenum2%, , lendummy%
PUT #filenum2%, , strdummy$
NEXT c%
END IF
ELSE
CLS
LOCATE 12, 25
PRINT "USAGE: FASC2BIN textfile binfile"
LOCATE 23, 21
PRINT ">>>>> Press Any Key to Exit to DOS <<<<<";
DO
a$ = INKEY$
LOOP UNTIL LEN(a$)
END IF
CLS
END
- - - - - - - - - - - - Cut on Dashed Line - - - - - - - - - - - - -
... That tagline is TRUE -> <- That tagline is FALSE
___ Blue Wave/QWK v2.10
--- Maximus 2.00
* Origin: Durham Systems (ONLINE!) (1:229/110)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #6646
Date: 12-27-92 12:27 (Public)
From: DIK COATES
To: CORIDON HENSHAW
Subject: scroll part 2 of 3
────────────────────────────────────────────────────────────────────────────────
This is the second bunch.... of 3
It has routines used with the first listing...
- - - - - - - - - - - - - - Cut on Dashed Line - - - - - - - - - - -
'************************************************************ SUB CommandLine
'
' Procedure returns command line arguments. Arguments must be separated by
' spaces, tabs, or "/". A maximum of 32 arguments can be returned in a
' array. The array must be declared as a dynamic array from the calling
' program.
'
' ARG: NUL
' RET: narg% - number of arguments on the command line
' arg$() - string array listing arguments
' COMP: MS BASIC 7.1
' REV: 91-10-28 header format
'
'****************************************************************************
'
SUB CommandLine (narg%, arg$())
cl$ = COMMAND$
l% = LEN(cl$)
FOR c% = 1 TO l%
temp$ = MID$(cl$, c%, 1)
IF temp$ = " " OR temp$ = CHR$(9) OR temp$ = "/" THEN
flag% = 0
ELSE
IF NOT flag% THEN
narg% = narg% + 1
flag% = -1
END IF
arg$(narg%) = arg$(narg%) + UCASE$(temp$)
END IF
NEXT c%
END SUB' CommandLine
'******************************************************** FUNCTION FILEEXIST%
'
' Procedure determines if a file exists. If file exists, then a -1 is
' returned, otherwise a 0 is returned. Procedure avoids using ON ERROR call.
'
' CALL: FILEEXIST% (filename$)
'
' ARG: filename$ - full path and filename of file to be tested
'
' COMP: MS Basic 7.1
'
' REV: 91-10-30
'
'****************************************************************************
'
FUNCTION FILEEXIST% (filename$)
FILEEXIST% = -1
IF LEN(DIR$(filename$)) = 0 THEN
FILEEXIST% = 0
END IF
END FUNCTION
'******************************************************** SUBPROGRAM ScrollDn
'
' Procedure scrolls the display window specified by the top and bottom rows
' and the left and right columns down by a number of declared rows. The
' space left behind is changed to the colour attribute of the background.
'
' CALL: ScrollDn (trow%, icol%, brow%, fcol%, numrow%, bga%)
'
' ARG: trow% = top row of window to be scrolled
' icol% = initial column of window
' brow% = bottom row of window
' fcol% = final column of window
' numrow% = number of rows to be scrolled down
' bga% = background colour attribute
'
' USES: Interrupt()
'
' COMP: MS Basic 7.1
'
' LIB: DOS.LIB/QLB
'
' REV: 91-11-13
'
'****************************************************************************
'
SUB ScrollDn (trow%, icol%, brow%, fcol%, numrow%, bga%)
DIM InReg AS RegType, OutReg AS RegType
tr% = trow% - 1
ic% = icol% - 1
br% = brow% - 1
fc% = fcol% - 1
temp% = bga%
IF temp% < 0 OR temp% > 15 THEN
temp% = 0
END IF
temp% = temp% * 16
InReg.ax = 1792 + numrow%
InReg.bx = temp% * 256
InReg.cx = tr% * 256 + ic%
InReg.dx = br% * 256 + fc%
CALL Interrupt(&H10, InReg, OutReg)
END SUB 'ScrollDn
'******************************************************** SUBPROGRAM ScrollUp
'
' Procedure scrolls the display window specified by the top and bottom rows
' and the left and right columns up by a number of declared rows. The
' space left behind is changed to the colour attribute of the background.
'
' CALL: ScrollUp (trow%, icol%, brow%, fcol%, numrow%, bga%)
'
' ARG: trow% = top row of window to be scrolled
' icol% = initial column of window
' brow% = bottom row of window
' fcol% = final column of window
' numrow% = number of rows to be scrolled up
' bga% = background colour attribute
'
' USES: Interrupt()
'
' COMP: MS Basic 7.1
'
' LIB: DOS.LIB/QLB
'
' REV: 91-11-13
'
'****************************************************************************
'
SUB ScrollUp (trow%, icol%, brow%, fcol%, numrow%, bga%)
DIM InReg AS RegType, OutReg AS RegType
tr% = trow% - 1
ic% = icol% - 1
br% = brow% - 1
fc% = fcol% - 1
temp% = bga%
IF temp% < 0 OR temp% > 15 THEN
temp% = 0
END IF
temp% = temp% * 16
InReg.ax = 1536 + numrow%
InReg.bx = temp% * 256
InReg.cx = tr% * 256 + ic%
InReg.dx = br% * 256 + fc%
CALL Interrupt(&H10, InReg, OutReg)
END SUB 'ScrollUp
- - - - - - - - - - - - - - Cut on Dashed Line - - - - - - - - - - -
... Thesaurus: An ancient reptile with an excellent vocabulary.
___ Blue Wave/QWK v2.10
--- Maximus 2.00
* Origin: Durham Systems (ONLINE!) (1:229/110)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #6647
Date: 12-27-92 12:27 (Public)
From: DIK COATES
To: CORIDON HENSHAW
Subject: scroll part 3 of 3
────────────────────────────────────────────────────────────────────────────────
This is the last of the installments... Part 3 of 3
- - - - - - - - - - - - Cut on Dashed Line - - - - - - - - - - - - -
'****************************************************** SUBPROGRAM ScrollText
'
' Procedure prints to screen WARNING MESSAGES returned from the various
' program screens. The messages if greater in number than the permitted
' number of lines on the screen can be scrolled down and up for viewing.
'
' CALL: ScrollText (a$(), srow%, scol%, frow%, fcol%, txtfga%, txtbga%,
' tartln%)
'
' ARG: a$() - text array to be printed to screen
' srow% - start row of the active screen area
' scol% - start column of the active screen area
' frow% - end row of the active screen area
' fcol% - end column of the active screen area
' txtfga% - text foreground attribute
' txtbga% - text background attribute
' startln%- starting line of the text array to be printed
'
' USES: ClearScrollText()
' ScrollDn()
' ClearScrollLine()
' ScrollUp()
'
' COMP: MS Basic 7.1
'
' REV: 91-03-23
' 91-11-14 header revised
'
'****************************************************************************
'
SUB ScrollText (a$(), srow%, scol%, frow%, fcol%, textfga%, textbga%,
startln%)
COLOR textfga%, textbga%
scrwidth% = fcol% - scol% + 1
linesperscreen% = frow% - srow% + 1 'OK
lenoffile% = UBOUND(a$, 1) 'OK
IF linesperscreen% >= lenoffile% THEN 'single screen
CALL ClearScrollText(srow%, scol%, frow%, fcol%, textfga%, textbga%)
FOR c% = 1 TO lenoffile% 'print screen
LOCATE srow% - 1 + c%, scol%
PRINT a$(c%);
NEXT c%
DO 'exit single screen on escape only
DO
key$ = INKEY$
LOOP UNTIL LEN(key$)
IF LEN(key$) = 2 THEN
BEEP
ELSEIF LEN(key$) = 1 THEN
IF ASC(key$) = 27 THEN
EXIT SUB
ELSE
BEEP
END IF
END IF
LOOP
ELSE 'multiple screens
maxtoprow% = lenoffile% - linesperscreen% + 1 'OK initialize
IF startln% + linesperscreen% > lenoffile% THEN
oldtoprow% = maxtoprow%
oldbotrow% = lenoffile%
ELSE
oldtoprow% = startln%
oldbotrow% = startln% + linesperscreen% - 1
END IF
FOR c% = 1 TO linesperscreen% 'print screen
LOCATE srow% - 1 + c%, scol%
PRINT a$(oldtoprow% - 1 + c%);
NEXT c%
DO
DO
key$ = INKEY$
LOOP UNTIL LEN(key$)
IF LEN(key$) = 2 THEN
temp% = ASC(RIGHT$(key$, 1))
SELECT CASE temp%
CASE 71 'home
scrollflag% = 0
oldtoprow% = 1
oldbotrow% = linesperscreen%
CASE 72 AND oldbotrow% <= linesperscreen% 'cursor up
scrollflag% = 2
CASE 72 AND oldbotrow% > linesperscreen%
scrollflag% = 1
oldtoprow% = oldtoprow% - 1
oldbotrow% = oldbotrow% - 1
CASE 73 AND oldtoprow% <= linesperscreen% 'page up
scrollflag% = 0
oldtoprow% = 1
oldbotrow% = linesperscreen%
CASE 73 AND oldtoprow% > linesperscreen%
scrollflag% = 0
oldtoprow% = oldtoprow% - linesperscreen%
oldbotrow% = oldbotrow% - linesperscreen%
CASE 79 'end
scrollflag% = 0
oldtoprow% = maxtoprow%
oldbotrow% = lenoffile%
CASE 80 AND oldtoprow% < maxtoprow% 'cursor down
scrollflag% = -1
oldtoprow% = oldtoprow% + 1
oldbotrow% = oldbotrow% + 1
CASE 80 AND oldtoprow% = maxtoprow%
scrollflag% = 2
CASE 81 AND oldbotrow% >= maxtoprow%'page down
scrollflag% = 0
oldtoprow% = maxtoprow%
oldbotrow% = lenoffile%
CASE 81 AND oldbotrow% < maxtoprow%
scrollflag% = 0
oldtoprow% = oldtoprow% + linesperscreen%
oldbotrow% = oldbotrow% + linesperscreen%
CASE ELSE
BEEP
END SELECT
IF scrollflag% = 1 THEN 'movement up
CALL ScrollDn(srow%, scol%, frow%, fcol%, 1, textbga%)
CALL ClearScrollLine(srow%, scol%, fcol%, textfga%, textbga%)
LOCATE srow%, scol%
PRINT a$(oldtoprow%);
ELSEIF scrollflag% = -1 THEN 'movement down
temp% = srow% + linesperscreen% - 1
CALL ScrollUp(srow%, scol%, frow%, fcol%, 1, textbga%)
CALL ClearScrollLine(temp%, scol%, fcol%, textfga%, textbga%)
LOCATE temp%, scol%
PRINT a$(oldbotrow%);
ELSEIF scrollflag% = 0 THEN 'print screen
CALL ClearScrollText(srow%, scol%, frow%, fcol%, textfga%, textbga%)
FOR c% = 1 TO linesperscreen%
LOCATE srow% - 1 + c%, scol%
PRINT a$(oldtoprow% - 1 + c%);
NEXT c%
END IF
scrollflag% = 0
ELSE
temp% = ASC(key$)
SELECT CASE temp%
CASE 27 'escape
EXIT SUB
CASE ELSE
BEEP
END SELECT
END IF
LOOP
END IF
END SUB 'ScrollText
'********************************************************* SUB TextFile2Array
'
' The procedure copies a BINARY text file to a string array. The format of
' binary file is: (size%, LENstring1%, string1$, LENstring2%, string2$,...)
' Error handling must be done in the calling program.
'
' CALL: TextFile2Array (filename$, a$())
'
' ARG: filename$ - name of the BINARY file to be copied
'
' RET: a$() - string array containing contents of binary file
'
' COMP: MS Basic 7.1
'
' REV: 91-10-30
'
'****************************************************************************
'
SUB TextFile2Array (filename$, a$())
filenum% = FREEFILE
OPEN filename$ FOR BINARY AS filenum%
GET filenum%, , size%
REDIM a$(size%)
FOR c% = 1 TO size%
GET filenum%, , dummy%
a$(c%) = INPUT$(dummy%, filenum%)
NEXT c%
CLOSE filenum%
END SUB' TextFile2Array
- - - - - - - - - - - - Cut on Dashed Line - - - - - - - - - - - - -
It's possible to get a smooth scroll... one row of pixels at a time...
but only from graphics mode... I can provide code for this also... but
will take a bit to unravel it from an application... also, done in
assembly... the only way to do graphics... Regards Dik
... AAAAA - American Association Against Acronym Abuse
___ Blue Wave/QWK v2.10
--- Maximus 2.00
* Origin: Durham Systems (ONLINE!) (1:229/110)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #7266
Date: 12-27-92 06:19 (Public)
From: RICH GELDREICH
To: ALL
Subject: Bload Compressor/1
────────────────────────────────────────────────────────────────────────────────
I'll get directly to the point: if you use BSAVE and BLOAD to
compress SCREEN 13 images, then this program should be a great help. The
purpose of this program is to compress SCREEN 13 (320x200x256) images to
a BLOAD'able file. To decompress the file, you call a VERY FAST assembly
language decompressor that quickly sets the palette and writes the image
to the screen. It used to be small, until I documented it... Ooops.
'Page 1 of ENCODE13.BAS begins here.
'SCREEN 13 (320x200x256) Screen Compressor (SP1.BAS)
'Public Domain By Rich Geldreich, December 26, 1992
'Anyone may use this program in anything they want, as long as the
'original author(me, duh) is given credit where credit is due...
'Thanks. I'd appreciate a little cash on the side if you make any
'money off a product that uses this program... :-) If you make any
'neat modifications/optimizations to this program or the ASM decoder,
'I would really like to seem them!
'Description:
' This simple SCREEN 13 compression program uses an LZ77 variant
'to compress SCREEN 13 images. A FAST assembly subroutine is used to
'decompress the image back to the screen. The compression should
'always beat PCX, and should come fairly close or beat out GIF under
'most cases.
'
' The assembly decompressor's speed is several magnitudes faster
'than the quickest GIF decoder I've seen, VPIC 5.1. (Look how simple
'it is and you'll know why!) BTW- The output stage of this program
'was optimized for decoding speed, not for compression. Several
'optimizations could be added to increase this program's compression
'performance, such as entropy encoding on the distance & length
'tokens(which would slow the decoder down immensely), increasing the
'sizes of the sliding dictionary and look ahead buffers, and further
'optimizing the non-greedy aspect of this LZ77 implementation to
'choose the best character/match combinations to store in the output
'stream.
'
' The assembly subroutine is for 286's and above, only. This
'program does NOT work under QuickBASIC, only PDS and VB/DOS because
'of the use of BYVAL.
'
' Any questions, cash/and or death threats call me at
'(609)-742-8752 2:30pm - 11:30pm eastern time or send a self
'addressed stamped evelope (SASE) to:
'
' Rich Geldreich
' 410 Market St.
' Gloucester City, NJ 08030
'
'Possible uses of this program: Use a GIF or PCX converter(or SHELL
'out to VPIC) to display the image you want to use in your
'application on SCREEN 13. Then encode the image with this program.
'You can then instantly recall the image using the fast Decom13
'assembly language subroutine.
DEFINT A-Z
'Declaration for the assembly decompressor. If the area of memory
'passed does not start with "RG", the compressed image's signature,
'then this routine will just return without doing anything. This
'prevents your machine from hanging when you pass it a bum pointer.
DECLARE SUB Decom13 (BYVAL InSegment, BYVAL InOffset)
CONST True = -1, False = 0
'A larger buffer size would surely increase compression.
CONST BufferSize = 4096, HashSize = 4096
CONST Null = BufferSize, Threshold = 2, MaxMatch = 273
CONST MaxCompares = 300 'Controls compression ratio vs. speed
'Arrays for LZ77 style compression with multiple linked lists
DIM SHARED RingBuffer((BufferSize + MaxMatch - 1) - 1)
DIM SHARED NextCell((BufferSize + HashSize + 1) - 1)
DIM SHARED LastCell((BufferSize + HashSize + 1) - 1)
'Temp. holding buffer for compression tokens
DIM SHARED CodeBuffer(16 * 3 - 1)
'Misc. stuff
DIM SHARED DoneFlag, xp, yp, xl, yl, xh, yh
DIM SHARED Match.Length, Match.Position, Match.Distance
DIM SHARED IOBuffer$, IOPointer
DIM SHARED CodePointer, CodeCounter, OrMask AS LONG, BitAccum AS LONG
SCREEN 13
'**COMPRESSION EXAMPLE**
RANDOMIZE TIMER
FOR a = 1 TO 100 'draw us some garbage
x = RND * 319: y = RND * 199: c = RND * 255
CIRCLE (x, y), RND * 60, c: PAINT (x, y), RND * 255, c
NEXT
FOR a = 1 TO 200: LINE -(RND * 319, RND * 199), RND * 255: NEXT
Compress13 "coolfile.bci" 'compress the screen to coolfile.bci
'**DECOMPRESSION EXAMPLE**
'Allocate 64,000 bytes for a worst case scenario, decrease this of
'course to match the image's compressed size in bytes...
'Continued on page 2
--- MsgToss 2.0b
* Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #7267
Date: 12-27-92 06:20 (Public)
From: RICH GELDREICH
To: ALL
Subject: Bload Compressor/2
────────────────────────────────────────────────────────────────────────────────
'Page 2 of ENCODE13.BAS begins here.
REDIM image(32000): DEF SEG = VARSEG(image(0))
BLOAD "coolfile.bci", VARPTR(image(0)) 'Load the compressed data.
PRINT "Press a key to decompress.": B$ = INPUT$(1): SCREEN 13
'Call the asm routine to decompress the image.
Decom13 VARSEG(image(0)), VARPTR(image(0)): B$ = INPUT$(1)
'Compresses a SCREEN 13 image to a BLOADable file. Use the ASM sub
'Decom13 to decompress the image back to the screen. This routine
'currently crawls, because I didn't optimize it that much.
'The entire palette is also saved to the compressed file,
SUB Compress13 (F$)
OPEN F$ FOR OUTPUT AS #1: CLOSE : OPEN F$ FOR BINARY AS #1
'Store the BLOAD header and image signature.
a$ = CHR$(&HFD) + CHR$(0) + CHR$(&HA0) + STRING$(4, 0) + "RG"
PUT #1, , a$
'Initialize a 4k disk output buffer
IOBuffer$ = SPACE$(4096): IOPointer = 1
CodePointer = 0: CodeCounter = 0: OrMask = 1: BitAccum = 0
'Write the screen's palette.
OUT &H3C7, 0: FOR a = 0 TO 767: WriteByte INP(&H3C9): NEXT
DoneFlag = False: xl = 0: yl = 0: xh = 319: yh = 199
xp = xl: yp = yl 'coordinate of next point to compress
InitRingBuffer 'clear the ring buffer
InitLZ77 'initialize the linked list pool
'prime the look ahead buffer
S = 0: R = BufferSize - MaxMatch
FOR LookAheadLength = 0 TO MaxMatch - 1
IF DoneFlag THEN
EXIT FOR
ELSE
RingBuffer(R + LookAheadLength) = GetPixel
END IF
NEXT
'find first string
FindString R
DO
'if match too small(less than 3 chars), the just output
'a single character
IF Match.Length <= Threshold THEN
OutputChar RingBuffer(R): Last.Match.Length = 1
ELSE
'output a string match token
Last.Match.Length = Match.Length
'Send the match's distance, instead of its position in
'the ring buffer, because the decompressor is not using a
'ring buffer to store the decompressed data.
Match.Distance = (R - Match.Position) AND (BufferSize - 1)
OutputMatch
END IF
'prime the look ahead buffer with more characters
FOR a = 0 TO Last.Match.Length - 1
IF DoneFlag THEN EXIT FOR 'exit this loop if no more chars
'delete string at S, then store a new char at S
DeleteString S: RingBuffer(S) = GetPixel
'keep a "ghost buffer" at the end of the ring buffer to
'avoid using a logical AND on all of our buffer pointers
IF S < (MaxMatch - 1) THEN
RingBuffer(S + BufferSize) = RingBuffer(S)
END IF
S = (S + 1) AND (BufferSize - 1)
R = (R + 1) AND (BufferSize - 1)
'if not last time through loop then just add string to the
'linked list pool, otherwise add it and find a match
'(this could be optimized so the IF/THEN conditional is
'removed from inside this loop)
IF a = (Last.Match.Length - 1) THEN
FindString R
ELSE
MakeString R
END IF
NEXT
FOR a = a TO Last.Match.Length - 1
'this loop is active when no more characters are available
'from the input stream
'Kill string at S, not sure if this is needed because
'we're not storing any characters in its place. I see
'no reason to do it, but this is one of those little
'quirks that all LZSS implementations I've seen have... ?
DeleteString S
S = (S + 1) AND (BufferSize - 1)
R = (R + 1) AND (BufferSize - 1)
LookAheadLength = LookAheadLength - 1
IF LookAheadLength THEN
IF a = (Last.Match.Length - 1) THEN
FindString R
ELSE
'Continued on page 3
--- MsgToss 2.0b
* Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #7268
Date: 12-27-92 06:21 (Public)
From: RICH GELDREICH
To: ALL
Subject: Bload Compressor/3
────────────────────────────────────────────────────────────────────────────────
'Page 3 of ENCODE13.BAS begins here.
MakeString R
END IF
'Limit match length because the look ahead buffer
'is growing smaller. This is another little oddity
'I've seen amoung the LZSS compressors, they all do
'this check outside this loop before they output a
'character/match token... There's no reason to
'check outside the loop because the string search
'function always limits the match length to the
'look ahead buffer's size. We only check when the
'look ahead buffer starts to get smaller.
IF Match.Length > LookAheadLength THEN
Match.Length = LookAheadLength
END IF
END IF
NEXT
LOOP WHILE LookAheadLength 'loop while still more chars to encode
OutputEOF
WriteFlush
'get (compressed size)-header
a& = LOF(1) - 7: SCREEN 0: WIDTH 80
IF a& > 64000 THEN
PRINT "Image could not be compressed."
CLOSE #1: KILL F$
ELSE
PRINT "Image compressed to"; a&; "bytes."
IF a& > 32767 THEN a& = a& - 65536
'store the compressed size so BLOAD loads everything in
a = a&: PUT #1, 6, a: CLOSE #1
END IF
END SUB
'Deletes the string at S from the linked list pool.
SUB DeleteString (BYVAL S)
NextCell = NextCell(S): LastCell = LastCell(S)
NextCell(LastCell) = NextCell: LastCell(NextCell) = LastCell
NextCell(S) = Null
END SUB
'Attempts to find a match at R+1 that is larger than the match found
'at R, to get rid of some of the encoder's "greedy" characteristics.
FUNCTION FindAlternate (BYVAL R, BYVAL MatchLength)
B1 = RingBuffer(R): B2 = RingBuffer(R + 1): B3 = RingBuffer(R + 2)
'hash out the first three characters of the string to locate
P = (BufferSize + 1) + ((B1 * 14096& XOR B2 * 77 XOR B3) MOD _
HashSize)
MatchChar = RingBuffer(R + MatchLength)
FOR x = 1 TO MaxCompares
P = NextCell(P) 'traverse linked list P for a match
'if we struck bottom then search failed
IF P = Null THEN FindAlternate = False: EXIT FUNCTION
'compare string P to string R
IF RingBuffer(P) = B1 AND RingBuffer(P + 1) = B2 AND RingBuffer_
(P + 2) = B3 AND RingBuffer(P + MatchLength) = MatchChar THEN
FOR SearchLength = 3 TO (MaxMatch - 1) - 1
IF RingBuffer(R + SearchLength) <> RingBuffer(P + _
SearchLength) THEN EXIT FOR
NEXT
'if we find a longer match then exit with success
IF SearchLength > MatchLength THEN FindAlternate = True: _
EXIT FUNCTION
END IF
NEXT
FindAlternate = False
END FUNCTION
'Attempts to locate a match in the linked list pool for R. Most
'other LZ77/LZSS implementations I've seen use a binary tree to
'locate string matches. In this implementation, I use a pool of
'linked lists to locate strings. Each linked list contains strings
'which all start with the same 3 characters. (Well, usually. Since
'hash collisions can occur, sometimes a linked list contains two or
'more different strings. This isn't cool, and can't be eliminated
'unless another approach to collision handling is used.)
'
' To locate a string, its linked list is located through a simple
'hashing formula(which was home brewed, BTW, so it may not be that
'optimal), and then each string in the list is compared against our
'target string until we either find a string which matches perfectly
'or the "bombout" variable is decremented to zero. The bombout rate
'defines the number of string compares which may be performed until
'the algorithm stops searching and settles with what it has. This
'decreases compression slightly, but greatly increases compression
'speed, especially when the input stream contains large runs of
'repeated data. (ARJ adjusts its bombout rate with command line
'options: options -m4 to -m0 vary the number of compares it does
'against its string directionary, therefore "dialing" in compression
'speed vs. compression ratio. PKZIP 1.93a does this also.
'Normally, PKZIP 1.93a will set its bombout rate to 50 compares. The
'Continued on page 4
--- MsgToss 2.0b
* Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
Area: QuickBasic
Msg: #7269
Date: 12-27-92 06:22 (Public)
From: RICH GELDREICH
To: ALL
Subject: Bload Compressor/4
────────────────────────────────────────────────────────────────────────────────
'Page 4 of ENCODE13.BAS begins here.
'-s option brings this down to 10-7 compares(can't remember exactly),
'and the -ex option increases the bombout rate to 500 compares.
'Obviously, the -ex option slows down PKZIP 1.93a because it can do
'up to ten times more string compares than usual.)
'
' One optimization that I have not seen anywhere yet speeds up the
'string search by skipping strings which can't possibly be larger
'than the largest string found up to that point...
'
' For instance, let's say we are searching for the string "the
'president eats peanuts". Let's also say the largest match we've
'found so far is "the president ", or 14 characters. The next string
'to compare against our target is "the president finds coolness in
'compression". Since the whole point of searching is to look for the
'largest match, there's no use in doing a whole string compare if the
'match will be smaller/equal to our current match. A quick compare
'of the character that must match for the match length to be larger
'will tell us if the string *may* be larger. If the character
'matches, we must do the compare. If it doesn't, then there is no
'use in doing the string compare because the match cannot possibly be
'longer. Since the 15th character of our target string is "e", and
'the 15th character of our search string is "f", it can instantly be
'discarded because the match cannot possibly be larger than 14
'characters. This especially speeds up the search when large string
'matches are found in the input stream(such as in text files). And
'since the optimization is relatively trivial, it shouldn't slow down
'the string search loop much at all when input stream is not very
'compressable.
'
' Finally, using the linked list pool to find string matches makes
'finding the closest AND longest match very simple(finding the
'closest match aids entropy encoding in attaining more compression
'because it can favor close matches over far ones). Since new
'strings are always inserted as the first string in its pool, the
'entire list is already sorted in order of distance from our current
'position in the ring buffer.
SUB FindString (BYVAL R)
B1 = RingBuffer(R): B2 = RingBuffer(R + 1): B3 = RingBuffer(R + 2)
'hash the first 3 characters of the string to find
LinkHead = (BufferSize + 1) + ((B1 * 14096& XOR B2 * 77 XOR B3) _
MOD HashSize)
Match.Length = 0: MatchChar = B1: P = LinkHead
FOR x = 1 TO MaxCompares 'MaxCompares is the bombout rate
'traverse linked list P for match
P = NextCell(P): IF P = Null THEN EXIT FOR
'If first 3 characters match, and the character at
'P+MatchLength=R+MatchLength, then compare strings.
IF RingBuffer(P) = B1 AND RingBuffer(P + 1) = B2 AND RingBuffer_
(P + 2) = B3 AND RingBuffer(P + Match.Length) = MatchChar THEN
FOR SearchLength = 3 TO (MaxMatch - 1) - 1
IF RingBuffer(R + SearchLength) <> RingBuffer(P + _
SearchLength) THEN EXIT FOR
NEXT
'if matchsize=maxmatch then take it and run
'(MaxMatch-1) because our look ahead buffer is one
'character longer than the maximum match length.
IF SearchLength >= (MaxMatch - 1) THEN
Match.Length = (MaxMatch - 1)
Match.Position = P
EXIT FOR
END IF
'if we find a longer match then take it
IF SearchLength > Match.Length THEN
Match.Length = SearchLength
Match.Position = P
MatchChar = RingBuffer(R + Match.Length)
END IF
END IF
NEXT
'make the new string the first entry in its linked list pool
'so we always find the closest match
a = NextCell(LinkHead): NextCell(LinkHead) = R
LastCell(a) = R: LastCell(R) = LinkHead: NextCell(R) = a
'Attempt to find a longer match at R+1. If there is a longer
'match, then set the match length to zero so the current match
'is ignored.
IF (Match.Length <> 0) AND (Match.Length <> (MaxMatch - 1)) THEN
IF FindAlternate(R + 1, Match.Length) THEN Match.Length = 0
END IF
END SUB
'Returns one pixel from the display.
FUNCTION GetPixel
GetPixel = POINT(xp, yp): xp = xp + 1
IF xp > xh THEN
LINE (xl, yp)-(xh, yp), 0
xp = xl: yp = yp + 1: DoneFlag = yp > yh
END IF
END FUNCTION
'Initializes the linked list pool arrays
'Continued on page 5
--- MsgToss 2.0b
* Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)
------------------------------------------------------------------------
The QuickBASIC Scrapbook
Vol 1, Issue 1 January 1993
------------------------------------------------------------------------
That's it! Thank you for reading The QuickBASIC Scrapbook.
Comments:
Messages captured using Harvey Parisien's OFFLINE v1.50.
The QuickBASIC Scrapbook is Copyright 1992 by Quauntum Software.
All Rights Reserved.