home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
magazine
/
qbnewsl
/
qbnws202
/
asciiart
/
asciiart.bas
next >
Wrap
BASIC Source File
|
1991-05-08
|
34KB
|
550 lines
'ASCIIART.BAS Copyright 1991 by
'Charles Graham, POB 58634, St. Louis, MO 63158
'All rights reserved
'FUNCTION dir$, by David Cleary, has been
'modified for use in this program.
'ASCIIART.BAS displays ASCII (text) files as
'color images on EGA or color CGA systems.
'To execute properly, QuickBASIC must be
'invoked with the /l option: i.e., QB/L.
'$INCLUDE: 'qb.bi' 'Include the QB help
' file for interrupts
DEFINT A-Z 'Variables are type INTEGER
' unless otherwised declared
DECLARE SUB capturecodes (printercode$) 'Get printer codes
DECLARE SUB checkprinter () 'Is printer available?
DECLARE SUB clearbox () 'Clear monitor window
DECLARE FUNCTION dir$ (filespec$) 'Finds *.ASC files
'The next SUB draws a window
DECLARE SUB frame (upperrow, leftcolumn, lowerrow, rightcolumn, foreground)
DECLARE SUB getmonitor (monitortype$) 'Is it EGA or CGA?
DECLARE SUB getprinter (printertype$) 'What kind of printer?
DECLARE SUB heading () 'Print heading
DECLARE SUB loadarray (monitortype$) 'Set color attributes
DECLARE SUB printnames () 'Print file names
DECLARE SUB printpicture (n$) 'Print picture
DECLARE SUB viewpicture (monitortype$, n$, scrn) 'View picture
ON ERROR GOTO enditall 'Just in case
DIM SHARED forecolor(255) 'Dimension array
DIM SHARED inreg AS regtype, outreg AS regtype 'Define inreg and outreg
'as regtype
DIM SHARED dos 'Used with FUNCTION dir$
DIM SHARED dta AS STRING * 44 'Used with FUNCTION dir$
DIM SHARED findfirst 'Used with FUNCTION dir$
DIM SHARED findnext 'Used with FUNCTION dir$
DIM SHARED null$ 'Used with FUNCTION dir$
DIM SHARED regs AS regtypex 'Used with FUNCTION dir$
DIM SHARED setdta 'Used with FUNCTION dir$
dos = &H21 'Used with FUNCTION dir$
findfirst = &H4E00 'Used with FUNCTION dir$
findnext = &H4F00 'Used with FUNCTION dir$
null$ = CHR$(0) 'Used with FUNCTION dir$
setdta = &H1A00 'Used with FUNCTION dir$
COLOR 7, 0 'White on black
CLS 'Clear screen
CALL getmonitor(monitortype$) 'Is it EGA or CGA?
CALL loadarray(monitortype$) 'Set color attributes
CALL getprinter(printertype$) 'What kind of printer?
CALL printnames 'Print file names
DO WHILE n$ <> "DIANE" AND n$ <> "FRANCES" AND n$ <> "OTHER"
n$ = "" 'Initialize file name to null
IF scrn <> 0 THEN 'SCREEN mode not 0?
CLS ' Clear screen
IF monitortype$ = "C" THEN ' CGA?
WIDTH 80, 25 ' Invoke 80x25 text mode
END IF '
SCREEN 0 ' Invoke SCREEN mode 0
scrn = 0 ' Set indicator to 0
CALL frame(4, 12, 21, 66, 13) ' Draw a window
CALL heading ' Print heading
CALL printnames ' Print file names
ELSE 'SCREEN mode is 0
LOCATE 19, 13, 0 ' Position cursor
PRINT SPACE$(52); ' Clear line
END IF '
COLOR 15 'Bright white
LOCATE 19, 27, 1 'Position cursor
PRINT "Name of picture? "; 'Ask user for file name
COLOR 13 'Bright magenta
LINE INPUT ; ""; n$ 'Null prompt
IF n$ = "" THEN 'File name null?
EXIT DO ' T-T-That's all folks
ELSE 'File name not null
n$ = UCASE$(n$) ' Convert name to upper case
END IF '
IF n$ = "DIANE" OR n$ = "FRANCES" OR n$ = "OTHER" THEN
CLOSE 'CLOSE any open files
OPEN n$ + ".ASC" FOR INPUT AS 1 'OPEN selected file
IF printertype$ <> "N" THEN 'Printer selected?
LOCATE 19, 13, 0 ' Position cursor
PRINT SPACE$(52); ' Clear line
LOCATE 19, 29, 1 ' Position cursor
COLOR 15 ' Bright white
PRINT "Print or View [P/V]? "; ' Print it or display it?
selection$ = "" ' Initialize to null
WHILE selection$ <> "P" AND selection$ <> "V" 'Wait for P or V
selection$ = UCASE$(INKEY$) ' Make it upper case
WEND ' Got it
PRINT selection$; ' Show user
IF selection$ = "P" THEN ' Print it?
CALL printpicture(n$) ' Print picture
ELSE ' View it?
CALL viewpicture(monitortype$, n$, scrn)'View picture
END IF '
ELSE 'No printer selected
CALL viewpicture(monitortype$, n$, scrn)'View picture
END IF '
END IF '
n$ = "" 'Initialize file name to null
LOOP '
enditall: 'Just in case
IF scrn <> 0 THEN 'SCREEN mode not 0?
SCREEN 0 ' Set SCREEN mode to 0
COLOR 7, 0 ' White on black
CLS ' Clear screen
ELSE 'SCREEN mode 0
LOCATE 19, 13, 0 ' Position cursor
PRINT SPACE$(52); ' Clear line
END IF '
COLOR 31, 0 'Blink bright white on black
SELECT CASE ERR 'Any errors?
CASE 0 ' No?
SELECT CASE printertype$ ' What type of printer?
CASE "C" ' Custom?
printercode$ = "" ' Initialize to null
CALL clearbox ' Clear monitor window
LOCATE 12, 21, 0 ' Position cursor
COLOR 14 ' Bright yellow
PRINT "Enter the numeric ASCII value of each"
LOCATE 13, 20 ' Position cursor
PRINT "character you want sent to your printer."
LOCATE 14, 22 ' Position cursor
PRINT "Press the RETURN key after each one."
LOCATE 16, 27 ' Position cursor
PRINT "To quit sending characters"
LOCATE 17, 23 ' Position cursor
PRINT "enter Q and press the RETURN key."'
LOCATE 19, 26, 1 ' Position cursor
COLOR 15 ' Bright white
PRINT "Enter numeric ASCII value: ";
CALL capturecodes(printercode$) ' Get printer codes
LPRINT printercode$; ' Send control codes
LOCATE 19, 13 ' Position cursor
PRINT SPACE$(52); ' Clear the line
COLOR 31, 0 _
' Blink bright white on black
CASE "D" ' Datasouth 220?
LPRINT CHR$(27) + "[" + "1" + "z"; ' Begin 6 LPI
LPRINT CHR$(27) + "U" + "0"; _
' Bi-directional printing
LPRINT CHR$(27) + "$" + "1" + "0" + "M"; '10 CPI, draft mode
CASE "I" ' IBM Proprinter?
LPRINT CHR$(27) + "A" + CHR$(12); ' Store 6 LPI
LPRINT CHR$(27) + "2"; ' Begin stored LPI
LPRINT CHR$(27) + "U" + CHR$(0);_
' Cancel uni-directional
LPRINT CHR$(27) + "H"; ' Cancel NLQ mode
LPRINT CHR$(18); _
' Cancel condensed mode
END SELECT '
LOCATE 19, 37 ' Position cursor
PRINT "Bye!"; ' Bid user farewell
CASE 24, 25 ' Printer problem?
LOCATE 19, 29 ' Position cursor
PRINT "Check printer status!"; ' Have user check printer
CASE ELSE ' Other problem?
LOCATE 19, 28 ' Position cursor
PRINT "Error type"; ERR; "occurred!"; ' Tell user the problem
END SELECT '
COLOR 7, 0 'White on black
WIDTH "lpt1:", 80 'Reset printer width
WIDTH 80, 25 'Restore 80x25 text mode
LOCATE 23, 1, 1 'Position cursor
CLOSE 'Close any open files
END 'T-T-That's all folks!
'The following DATA are ASCII codes for various characters.
'The codes are read in SUB loadarray where color attributes
'are set. If a user specifies an EGA system all six lines
'of DATA are significant. For CGA systems, only the first
'three lines are significant. Characters in insignificant
'lines and characters not referenced at all default to black
'except character 32 (a space or blank) which defaults to
'bright white on EGA systems and white on CGA systems.
'Users that want to experiment with ASCIIART.BAS can alter
'the DATA below and SUB loadarray to alter the colors
'associated with various characters. As originally published,
'the color attributes associated with each line are as follows.
' EGA color CGA color
' 7 white 3 white
DATA 33, 34, 39, 44, 45, 46, 94, 95, 96
' 14 bright yellow 1 cyan
DATA 40, 41, 43, 47, 58, 60, 62, 63, 92
' 12 bright red 2 magenta
DATA 49, 55, 59, 61, 73, 76, 84, 89, 91, 93
' 8 grey 0 black
DATA 37, 42, 48, 52, 54, 57, 67, 70, 74, 75, 80, 86, 88, 90
' 6 brown 0 black
DATA 36, 38, 50, 51, 53, 64, 65, 68, 69, 72, 79, 82, 83, 85
' 8 grey 0 black
DATA 35, 56, 66, 71, 77, 78, 81, 87
SUB capturecodes (printercode$) 'Get printer codes
DO '
LOCATE 19, 54 'Position cursor
PRINT " " 'Clear the area
LOCATE 19, 54 'Position cursor
asciicode$ = "" 'Initialize acode to null
DO '
character$ = "" ' Initialize char to null
DO ' Wait for digit, "Q",
character$ = UCASE$(INKEY$) ' backspace or return
LOOP UNTIL (character$ >= "0" AND character$ <= "9") OR _
character$ = "Q" OR character$ = CHR$(8) OR character$ = CHR$(13)
SELECT CASE character$ ' See what we got
CASE "0" TO "9" ' Digit?
IF LEN(asciicode$) <= 2 THEN ' If valid, add it to
IF VAL(asciicode$ + character$) <= 255 THEN ' asciicode
asciicode$ = asciicode$ + character$ ' and
PRINT character$; ' print it
END IF '
END IF '
CASE "Q" ' "Q"?
IF LEN(asciicode$) = 0 THEN ' If asciicode null
asciicode$ = character$ ' make asciicode "Q"
PRINT character$; ' and print it
END IF '
CASE CHR$(13) ' Return?
IF asciicode$ = "Q" THEN ' If asciicode is "Q"
EXIT SUB ' we're outtahere
ELSE ' If not "Q" but is
' is valid, add it to
' printercode
IF LEN(asciicode$) AND VAL(asciicode$) <= 255 THEN
printercode$ = printercode$ + CHR$(VAL(asciicode$))
END IF '
END IF '
CASE CHR$(8) ' Backspace?
LOCATE 19, 54 ' Position cursor
PRINT " "; ' Clear the area
LOCATE 19, 54 ' Position cursor
IF LEN(asciicode$) <= 1 THEN ' If asciicode 1 char,
asciicode$ = "" ' make it null
ELSE ' If longer, shorten it
asciicode$ = LEFT$(asciicode$, LEN(asciicode$) - 1) 'by
PRINT asciicode$; ' 1 char and print it
END IF '
END SELECT '
LOOP UNTIL character$ = CHR$(13) ' End loop on return key
LOOP '
END SUB '
SUB checkprinter 'Is printer available?
inreg.ax = &H200 'Set AH = 2; AL = 0
CALL interrupt(&H17, inreg, outreg) 'Call DOS interrupt &H17 (23)
p = outreg.ax 'Capture AX
IF ((ABS(p / 256) AND 8) = 0) THEN 'Printer on?
IF ((ABS(p / 256) AND 64) = 64) THEN ' Printer on line?
EXIT SUB ' We're OK; let's go
END IF '
END IF '
ERROR 24 'Simulate error
END SUB '
SUB clearbox 'Clear monitor window
FOR x = 11 TO 20 'Work on lines 11 through 20
LOCATE x, 13, 0 ' Position cursor
PRINT SPACE$(52); ' Clear the area
NEXT x '
END SUB '
FUNCTION dir$ (filespec$) STATIC 'Finds *.ASC files
regs.ax = setdta 'Set DTA function
regs.dx = VARPTR(dta) 'DS:DX points to our DTA
regs.ds = -1 'Use current value for DS
interruptx dos, regs, regs 'Do the interrupt
IF LEN(filespec$) THEN 'Filespec$ isn't null?
' Find first matching file
filespecz$ = filespec$ + null$ ' Make filespec$ into an
' ASCIIZ string
regs.ax = findfirst ' Perform a FindFirst
regs.cX = 0 ' Only look for normal files
regs.dx = SADD(filespecz$) _
' DS:DX points to ASCIIZ file
regs.ds = -1 ' Use current DS
ELSE 'Filespec$ is null?
regs.ax = findnext ' Find next matching file
END IF '
interruptx dos, regs, regs 'Do the interrupt
IF regs.flags AND 1 THEN 'No files found?
dir$ = "" ' Return null string
ELSE 'Found one?
null = INSTR(31, dta, null$) ' Get the filename found
dir$ = MID$(dta, 31, null - 30) ' It's an ASCIIZ string
END IF ' starting at offset 30
END FUNCTION ' of the DTA
SUB frame (upperrow, leftcolumn, lowerrow, rightcolumn, foreground)
'This SUB draws a window
COLOR foreground 'Set color of window frame
LOCATE upperrow, leftcolumn, 0 'Position cursor
'Next line prints top line
PRINT CHR$(201) + STRING$(rightcolumn - leftcolumn - 2, 205) + CHR$(187);
FOR ct = upperrow + 1 TO lowerrow - 1 'Print sides of frame
LOCATE ct, leftcolumn ' Position cursor
' Next line prints sides
PRINT CHR$(186) + SPACE$(rightcolumn - leftcolumn - 2) + CHR$(186);
NEXT ct '
LOCATE lowerrow, leftcolumn 'Position cursor
'Next line print bottom line
PRINT CHR$(200) + STRING$(rightcolumn - leftcolumn - 2, 205) + CHR$(188);
END SUB
SUB getmonitor (monitortype$) 'Is it EGA or CGA?
CALL frame(4, 12, 21, 66, 13) 'Draw a window
CALL heading 'Print heading
LOCATE 14, 36 'Position cursor
COLOR 11 'Bright cyan
PRINT "Enter"; '
LOCATE 15, 30 'Position cursor
COLOR 15 'Bright white
PRINT "C "; '
COLOR 14 'Bright yellow
PRINT "for a "; '
COLOR 15 'Bright white
PRINT "CGA "; '
COLOR 14 'Bright yellow
PRINT "system"; '
COLOR 11 'Bright cyan
LOCATE 16, 37 'Position cursor
PRINT "or"; '
LOCATE 17, 29 'Position cursor
COLOR 15 '
PRINT "E "; '
COLOR 14 'Bright yellow
PRINT "for an "; '
COLOR 15 'Bright white
PRINT "EGA "; '
COLOR 14 'Bright yellow
PRINT "system."; '
LOCATE 19, 29, 1 'Position cursor
COLOR 15 '
PRINT "Your choice [C/E]? "; 'Ask user
WHILE monitortype$ <> "C" AND monitortype$ <> "E"'Wait for "C" or "E"
monitortype$ = UCASE$(INKEY$) ' change to upper case
WEND '
PRINT monitortype$; 'Tell user
END SUB '
SUB getprinter (printertype$) 'What kind of printer?
CALL clearbox 'Clear monitor window
LOCATE 15, 28, 0 'Position cursor
COLOR 15 'Bright white
PRINT "Select printer option:" '
LOCATE 16, 30 'Position cursor
COLOR 14 'Bright yellow
PRINT "IBM"; '
LOCATE 16, 42 'Position cursor
PRINT "Custom" '
LOCATE 17, 29 'Position cursor
PRINT "DS220"; '
LOCATE 17, 43 'Position cursor
PRINT "None" '
COLOR 15 'Bright white
LOCATE 19, 27, 1 'Position curwor
PRINT "Your choice [C/D/I/N]? "; 'Ask user
printertype$ = "" 'Initialize to null
'Wait for C, D, I or N
WHILE printertype$ <> "C" AND printertype$ <> "D" AND _
printertype$ <> "I" AND printertype$ <> "N"
printertype$ = UCASE$(INKEY$) ' Convert to upper case
WEND '
PRINT printertype$; 'Tell user
SELECT CASE printertype$ 'Whadda we got?
CASE "I" ' IBM Proprinter?
pc$ = CHR$(15) ' Condensed mode
pc$ = pc$ + CHR$(27) + "G" ' Near Letter Quality mode
pc$ = pc$ + CHR$(27) + "U" + "1" ' Uni-directional printing
pc$ = pc$ + CHR$(27) + "A" + CHR$(7) ' 7/72nds" line spacing
pc$ = pc$ + CHR$(27) + "2" ' Begin line spacing
printercode$ = pc$ '
CALL checkprinter ' Printer available?
LPRINT printercode$; ' Send control codes
CASE "D" ' Datasouth 220?
pc$ = CHR$(27) + "$" + "1" + "1" + "M" ' Begin 16 CPI spacing
pc$ = pc$ + CHR$(27) + "U" + "1" ' Uni-directional printing
pc$ = pc$ + CHR$(27) + "A" + CHR$(7) ' 7/7nds" line spacing
printercode$ = pc$ '
CALL checkprinter ' Printer available?
LPRINT printercode$; ' Send control codes
CASE "C" ' User wants to customize?
printercode$ = "" ' Initialize to null
CALL clearbox ' Clear monitor window
LOCATE 12, 21, 0 ' Position cursor
COLOR 14 ' Bright yellow
PRINT "Enter the numeric ASCII value of each"'Tell user what to do
LOCATE 13, 20 ' Position cursor
PRINT "character you want sent to your printer."
LOCATE 14, 22 ' Position cursor
PRINT "Press the RETURN key after each one." '
LOCATE 16, 27 ' Position cursor
PRINT "To quit sending characters" '
LOCATE 17, 23 ' Position cursor
PRINT "enter Q and press the RETURN key."'
LOCATE 19, 26, 1 ' Position cursor
COLOR 15 ' Bright white
PRINT "Enter numeric ASCII value: "; '
CALL capturecodes(printercode$) ' Get printer codes
CALL checkprinter ' Printer available?
LPRINT printercode$; ' Send control codes
END SELECT '
WIDTH "lpt1:", 255 ' Disable line folding
END SUB '
SUB heading 'Print heading
COLOR 12 'Bright red
LOCATE 6, 35 'Position cursor
PRINT "ASCIIART" '
COLOR 11 'Bright cyan
LOCATE 8, 23 'Position cursor
PRINT "Copyright 1991 by Charles Graham" '
LOCATE 9, 24 'Position cursor
PRINT "POB 58634, St. Louis, MO 63158" '
LOCATE 10, 29 'Position cursor
PRINT "All rights reserved" '
END SUB '
SUB loadarray (monitortype$) 'Set color attributes
FOR y = 1 TO 9 'Read 9 ASCII values
READ x '
IF monitortype$ = "E" THEN ' EGA?
forecolor(x) = 7 ' Store white
ELSE ' CGA?
forecolor(x) = 3 ' Store white
END IF '
NEXT y '
FOR y = 1 TO 9 'Read 9 ASCII values
READ x '
IF monitortype$ = "E" THEN ' EGA?
forecolor(x) = 14 ' Store bright yellow
ELSE ' CGA?
forecolor(x) = 1 ' Store cyan
END IF '
NEXT y '
FOR y = 1 TO 10 'Read 10 ASCII values
READ x '
IF monitortype$ = "E" THEN ' EGA?
forecolor(x) = 12 ' Store bright red
ELSE ' CGA?
forecolor(x) = 2 ' Store magenta
END IF '
NEXT y '
FOR y = 1 TO 14 'Read 14 ASCII values
READ x '
IF monitortype$ = "E" THEN ' EGA?
forecolor(x) = 8 ' Store grey
END IF '
NEXT y '
FOR y = 1 TO 14 'Read 14 ASCII values
READ x '
IF monitortype$ = "E" THEN ' EGA?
forecolor(x) = 6 ' Store brown
END IF '
NEXT y '
FOR y = 1 TO 8 'Read 8 ASCII values
READ x '
IF monitortype$ = "E" THEN ' EGA?
forecolor(x) = 8 ' Store grey
END IF '
NEXT y '
IF monitortype$ = "E" THEN 'EGA?
forecolor(32) = 15 ' Store bright white
ELSE 'CGA?
forecolor(32) = 3 ' Store white
END IF '
END SUB '
SUB printnames 'Print file names
CALL clearbox 'Clear monitor window
COLOR 14 'Bright yellow
LOCATE 13, 17, 0 'Position cursor
PRINT "To end, press RETURN key without picture name"; 'Tell user
COLOR 13 'Light magenta
LOCATE 15, 29 'Position cursor
filespec$ = "*.asc" 'Set find argument to *.asc
found$ = dir$(filespec$) 'Find matching file names
WHILE LEN(found$) 'While there are any left
picture$ = LEFT$(found$, INSTR(found$, ".") - 1) 'Format and PRINT name
PRINT LEFT$(picture$, 1) + LCASE$(MID$(picture$, 2, LEN(picture$) - 1)),
found$ = dir$("") ' Reinitialize found$
WEND '
END SUB '
SUB printpicture (n$) 'Print picture
LOCATE 19, 13, 0 'Position cursor
PRINT SPACE$(52); 'Clear the area
n$ = LEFT$(n$, 1) + LCASE$(RIGHT$(n$, LEN(n$) - 1))'Format file name
LOCATE 19, INT((78 - LEN("Printing " + n$)) / 2), 1'Position cursor
PRINT "Printing " + n$; 'Tell user
a$ = "" 'Initialize to null
a$ = INKEY$ 'Grab keystroke, if any
WHILE (NOT EOF(1)) AND (NOT LEN(a$)) 'Print 'til end or keystroke
LINE INPUT #1, pictureline$ ' Grab a line of text file
LPRINT pictureline$ ' Print it
a$ = INKEY$ ' Check for keystroke
WEND '
CLOSE 'Close any open files
LPRINT CHR$(12); 'Send form feed to printer
END SUB '
SUB viewpicture (monitortype$, n$, scrn) 'View picture
IF monitortype$ = "E" THEN 'EGA?
SCREEN 8 ' Invoke SCREEN mode 8
scrn = 8 ' Store screen mode info
columnstart = 275 ' Set x coord for display
rowincrement = 1 ' Set y increment for disp
ELSE 'CGA?
SCREEN 1 ' Invoke SCREEN mode 1
scrn = 1 ' Store screen mode info
columnstart = 115 ' Set x coord for display
rowincrement = 2 ' Set y increment for disp
END IF '
LOCATE 23, 17, 0 'Position cursor
row = 0 'Initialize row to 0
WHILE NOT EOF(1) AND row <= 199 'Until end of pic or 200 lines
LINE INPUT #1, pictureline$ ' Grab a line from file
row = row + rowincrement ' Increment row
x = 1 ' Initialize x to 1
' Find 1st non-blank char
DO UNTIL MID$(pictureline$, x, 1) <> " " OR x >= LEN(pictureline$)
x = x + 1 ' Record its position
LOOP '
FOR y = x TO LEN(pictureline$) ' From there to end of line
' Turn on pixel
PSET (columnstart + y, row), forecolor(ASC(MID$(pictureline$, y, 1)))
NEXT y '
WEND '
a$ = "" 'Initialize to null
WHILE a$ = "" 'Wait for keystroke
a$ = INKEY$ ' Grab keystroke
WEND '
END SUB '