The program code is all in text readable BAS files using CHAIN. Full of code examples and SUBs and Functions you can copy. Also displays actual working code examples! Unzip the files to a folder that has QB 4.5 installed.
This message has been edited by burger2227 on Jul 27, 2009 3:27 PM This message has been edited by burger2227 on Jul 7, 2009 5:46 PM This message has been edited by burger2227 on Jul 7, 2009 5:40 PM This message has been edited by burger2227 on Jul 7, 2009 5:28 PM This message has been edited by burger2227 on Jul 16, 2008 1:17 PM
Bitmap Color Editor and BSAVE program for Screen 12
July 16 2008, 12:20 PM
'BMPCOLOR.BAS 'Program to change 1,4 or 24 Bit(Screen 12) Bitmap Colors to default or Custom colors ' Requires the Library is loaded for QuickBasic4 and up! ' Uses the mouse to find the color attributes used in the bitmap and allows ' you to change them to another attribute. Also useful to convert bitmaps to the ' standard attributes so that you do not need to set the color settings. ' Ted Weissgerber 2008, Burger2227@gmail.com
' Thanks to Bob Seguin for his assistance on this project!
DEFINT A-Z DECLARE SUB GetInfo () DECLARE SUB FourBit (Custom()) DECLARE SUB OneBIT (Custom()) DECLARE SUB TrueColor24 (Custom()) DECLARE SUB CLine () DECLARE SUB MouseDriver (AX, BX, CX, DX, LB, RB, EX) DECLARE SUB GetRGB (Array()) DECLARE SUB Painter () DECLARE SUB BMPColors (Custom(), Normal()) DECLARE SUB AutoClr (Custom()) DECLARE SUB Settings () DECLARE SUB CustomColor (Custom(), Normal()) DECLARE SUB Tint (Custom()) DECLARE SUB BSaver () DECLARE SUB BSaveOne () DECLARE SUB Delay (Dlay!) DECLARE SUB Closing () DECLARE SUB Border (Colr) DECLARE SUB SetAll (AllSet, Custom(), Normal()) DECLARE SUB Check15 (Custom())
TYPE BMPHeaderType 'BITMAP HEADER TYPE ID AS STRING * 2 'File ID is "BM" size AS LONG 'Size of the data file Res1 AS INTEGER 'Reserved 1 should be 0 Res2 AS INTEGER 'Reserved 2 should be 0 Offset AS LONG 'Position of start of pixel data Hsize AS LONG 'Information header size PWidth AS LONG 'Image width PDepth AS LONG 'Image height Planes AS INTEGER 'number of planes BPP AS INTEGER 'Bits per pixel, 4 for Screen 12, 16 color image Compress AS LONG 'Compression ImageBytes AS LONG 'Width * Height ,ImageSIZE Xres AS LONG 'Width in PELS per metre Yres AS LONG 'depth in PELS per metre NumColors AS LONG 'Number of COLORS SigColors AS LONG 'Significant COLORs END TYPE
DIM SHARED BMPHead AS BMPHeaderType DIM SHARED Image(26000) DIM SHARED Changed(0 TO 15) DIM SHARED AreaColors(0 TO 15) DIM Normal(0 TO 47) DIM Custom(0 TO 47) DIM SHARED mouse$ DIM SHARED CX, BX, DX, LB, RB, SetOld, SetNew, SaveName$, Clr, FileErr, Trun
ON ERROR GOTO Handler 'MAIN PROGRAM SCREEN 12
GetRGB Normal() 'find default QB color settings GetInfo 'bitmap file and header info
SELECT CASE BMPHead.BPP 'save color settings and load bitmap to screen CASE 1: OneBIT Custom() 'Black and white bitmaps or fonts CASE 4: FourBit Custom(): Check15 Custom(): BMPColors Custom(), Normal() '16 color CASE 24: TrueColor24 Custom() '16 Greyscale END SELECT
FOR i = 0 TO 15: COLOR i: LOCATE i + 12, 79: PRINT STRING$(2, 219): NEXT '16 color attribs SetOld = -1: SetNew = -1 COLOR Clr DO: Key$ = UCASE$(INKEY$) ' Main Program DO loop 'LOCATE 1, 60: PRINT CX; DX MouseDriver 3, BX, CX, DX, LB, RB, 0 'read mouse position IF prevCX <> CX OR prevDX <> DX THEN 'when mouse is moved only MouseDriver 2, BX, CX, DX, LB, RB, 0 'hide mouse for Point PixAttr = POINT(CX, DX): prevCX = CX: prevDX = DX MouseDriver 1, BX, CX, DX, LB, RB, 0 'show mouse END IF IF DX > 433 AND DX < 443 AND CX > 584 THEN IF RB THEN SetAll AllSet, Custom(), Normal() ELSE IF LB THEN SetOld = PixAttr IF RB THEN SetNew = PixAttr END IF SELECT CASE Key$ CASE "A": 'Add default setting IF SetNew > -1 THEN Changed(SetNew) = 1 LOCATE 30, 1: PRINT " Added"; SetNew; SetNew = -1: SetOld = -1 END IF CASE "B": BMPColors Custom(), Normal() 'set unchanged to original BMP Colors CASE "C": CustomColor Custom(), Normal() 'user creates a custom color CASE "D": PALETTE 'set to default QB colors CASE "P": IF SetOld > -1 AND SetNew > -1 AND SetOld <> SetNew THEN Painter 'point old and pset new CASE "Q": EXIT DO 'BSAVEs the Bitmap CASE "R": 'Remove default setting IF SetNew > -1 THEN Changed(SetNew) = 0 LOCATE 30, 1: PRINT "Removed"; SetNew; SetNew = -1: SetOld = -1 END IF CASE "S": Settings 'Displays default attribute settings used CASE "T": IF BMPHead.BPP = 24 AND Trun = 0 THEN Tint Custom() 'Tints greyscale to R, G, or B END SELECT COLOR Clr: LOCATE 30, 53: PRINT "Old ="; SetOld; : LOCATE 30, 62: PRINT "New ="; SetNew; LOCATE 30, 13: PRINT "Norm ="; Normal(3 * PixAttr); Normal(3 * PixAttr + 1); Normal(3 * PixAttr + 2); " "; LOCATE 30, 33: PRINT "Cust ="; Custom(3 * PixAttr); Custom(3 * PixAttr + 1); Custom(3 * PixAttr + 2); " "; LOCATE 30, 71: PRINT "Attr ="; PixAttr; LOOP UNTIL Key$ = CHR$(27) 'escape key exit IF Key$ = CHR$(27) THEN Closing: SYSTEM MouseDriver 2, BX, CX, DX, LB, RB, 0 'hide Mouse for GET image BMPColors Custom(), Normal() 'get final color settings
IF BMPHead.PDepth > 464 THEN BMPHead.PDepth = 464 'cut off menu text IF BMPHead.PWidth > 623 AND BMPHead.PDepth > 190 THEN BMPHead.PWidth = 623
IF BMPHead.PWidth * BMPHead.PDepth <= 102400 THEN BSaveOne 'one file ELSE : BSaver '2 or 3 files END IF
SLEEP ' DO: LOOP UNTIL INKEY$ <> "" Closing SYSTEM
Handler: ' BEEP FileErr = -1 RESUME NEXT ' Data for mouse DATA 55,89,E5,8B,5E,0C,8B,07,50,8B,5E,0A,8B,07,50,8B DATA 5E,08,8B,0F,8B,5E,06,8B,17,5B,58,1E,07,CD,33,53 DATA 8B,5E,0C,89,07,58,8B,5E,0A,89,07,8B,5E,08,89,0F DATA 8B,5E,06,89,17,5D,CA,08,00
SUB AutoClr (Custom()) 'sets bottom menu color FOR i = 0 TO 47 STEP 3 clrtot = Custom(i) + Custom(i + 1) + Custom(i + 2) IF clrtot > 90 AND clrtot <> Custom(0) + Custom(1) + Custom(2) THEN Clr = i \ 3 COLOR Clr: LOCATE 11, 75: PRINT "BPP "; LTRIM$(STR$(BMPHead.BPP)) LOCATE 28, 74: PRINT "Set ALL" LOCATE 29, 2: PRINT "Keys: Add/Rem def, Custom, Default/Bitmap, Paint, Quit, Settings"; IF BMPHead.BPP = 24 THEN PRINT ", Tint"; EXIT SUB END IF NEXT END SUB
SUB BMPColors (Custom(), Normal()) 'Resets to bitmap color values plus defaults set OUT &H3C8, 0 FOR i = 0 TO 47 STEP 3 IF Changed(i \ 3) = 0 THEN OUT &H3C9, Custom(i): Image(i) = Custom(i) OUT &H3C9, Custom(i + 1): Image(i + 1) = Custom(i + 1) OUT &H3C9, Custom(i + 2): Image(i + 2) = Custom(i + 2) ELSE OUT &H3C9, Normal(i): Image(i) = Normal(i) OUT &H3C9, Normal(i + 1): Image(i + 1) = Normal(i + 1) OUT &H3C9, Normal(i + 2): Image(i + 2) = Normal(i + 2) END IF NEXT END SUB
SUB Border (Colr) COLOR Colr FOR row = 1 TO 30 LOCATE row, 1: PRINT CHR$(179); LOCATE row, 80: PRINT CHR$(179); NEXT row FOR col = 1 TO 80 LOCATE 1, col: PRINT CHR$(196); LOCATE 30, col: PRINT CHR$(196); NEXT col LOCATE 1, 1: PRINT CHR$(218); LOCATE 1, 80: PRINT CHR$(191); LOCATE 30, 1: PRINT CHR$(192); LOCATE 30, 80: PRINT CHR$(217); END SUB
SUB BSaveOne DEF SEG = VARSEG(Image(0)) GET (0, 0)-(BMPHead.PWidth - 1, BMPHead.PDepth - 1), Image(48) 'indexed for 16 colors LINE (0, 0)-(BMPHead.PWidth, BMPHead.PDepth), Clr, B FOR a& = 26000 TO 0 STEP -1 IF Image(a&) THEN ArraySize& = a&: EXIT FOR NEXT SaveFile$ = SaveName$ + ".BCS" BSAVE SaveFile$, VARPTR(Image(0)), (2 * ArraySize&) + 200 '51,600 or 65543 DEF SEG CLine COLOR Clr: LOCATE 30, 30: PRINT "Saved as "; SaveFile$; END SUB
SUB BSaver DEF SEG = VARSEG(Image(0)) IF LEN(SaveName$) > 7 THEN SaveName$ = MID$(SaveName$, 1, 7) FOR y = 0 TO 320 STEP 160 'save into up to 3 files IF y + 159 <= BMPHead.PDepth - 1 THEN 'Full GET GET (0, y)-(BMPHead.PWidth - 1, y + 159), Image(48) 'indexed for 16 colors LINE (0, y)-(BMPHead.PWidth, y + 159), Clr, B IF y + 159 = BMPHead.PDepth - 1 THEN nobsave = -1 ELSE GET (0, y)-(BMPHead.PWidth - 1, BMPHead.PDepth - 1), Image(48) 'Partial GET ends loop LINE (0, y)-(BMPHead.PWidth, BMPHead.PDepth), Clr, B nobsave = -1 END IF FOR a& = 26000 TO 0 STEP -1 IF Image(a&) THEN ArraySize& = a&: EXIT FOR 'find array size needed NEXT num = num + 1: 'change file name by number 1,2,3 SaveFile$ = SaveName$ + LTRIM$(STR$(num)) + ".BCS" BSAVE SaveFile$, VARPTR(Image(0)), (2 * ArraySize&) + 200 '51,600 or 65543 IF nobsave THEN EXIT FOR NEXT y DEF SEG CLine COLOR Clr: LOCATE 30, 25: PRINT "Saved as "; SaveFile$; " as"; num; "Files."; END SUB
SUB Check15 (Custom()) 'change mouse pointer color if black IF Custom(45) + Custom(46) + Custom(47) = 0 THEN Custom(45) = 63: Custom(46) = 63: Custom(47) = 63 END IF END SUB
SUB CLine LOCATE 30, 1: PRINT SPACE$(79); END SUB
SUB Closing CLS IF Clr > 0 THEN COLOR Clr ELSE COLOR 11 LOCATE 15, 30: PRINT "Ted Weissgerber 2008" LOCATE 17, 30: PRINT "burger2227@gmail.com" SLEEP 3 END SUB
SUB CustomColor (Custom(), Normal()) IF SetNew = -1 THEN EXIT SUB CLine IF Changed(SetNew) = 1 THEN COLOR Clr: LOCATE 30, 25: PRINT SetNew; "Set to Default Attribute!"; Delay 2: CLine SetNew = -1: EXIT SUB END IF BMPColors Custom(), Normal() up$ = CHR$(17): dwn$ = CHR$(16) COLOR Clr: LOCATE 30, 2: PRINT "Custom"; " = Red: "; up$; " "; dwn$; ", Grn: "; up$; " "; dwn$; ", Blu: "; up$; " "; dwn$; ". Click up or down!"; LOCATE 30, 9: PRINT SetNew; Red = Custom(SetNew * 3): LOCATE 30, 22: PRINT Red; Grn = Custom((SetNew * 3) + 1): LOCATE 30, 37: PRINT Grn; Blu = Custom((SetNew * 3) + 2): LOCATE 30, 52: PRINT Blu;
IF LB AND DX > 464 THEN SELECT CASE CX CASE 151 TO 160: IF Red < 63 THEN Red = Red + 1: LOCATE 30, 22: PRINT Red; CASE 206 TO 215: IF Red > 0 THEN Red = Red - 1: LOCATE 30, 22: PRINT Red; CASE 270 TO 279: IF Grn < 63 THEN Grn = Grn + 1: LOCATE 30, 37: PRINT Grn; CASE 326 TO 335: IF Grn > 0 THEN Grn = Grn - 1: LOCATE 30, 37: PRINT Grn; CASE 390 TO 399: IF Blu < 63 THEN Blu = Blu + 1: LOCATE 30, 52: PRINT Blu; CASE 447 TO 455: IF Blu > 0 THEN Blu = Blu - 1: LOCATE 30, 52: PRINT Blu; END SELECT OUT &H3C8, SetNew: OUT &H3C9, Red: OUT &H3C9, Grn: OUT &H3C9, Blu Delay .2 LOCATE 30, 60: PRINT "Save settings?(Y/N)"; END IF
LOOP UNTIL save$ = "Y" OR save$ = "N" IF save$ = "Y" THEN Custom(SetNew * 3) = Red Custom((SetNew * 3) + 1) = Grn Custom((SetNew * 3) + 2) = Blu ELSE : BMPColors Custom(), Normal() END IF SetNew = -1: SetOld = -1 CLine END SUB
SUB Delay (Dlay!) start! = TIMER DO WHILE start! + Dlay! >= TIMER IF start! > TIMER THEN start! = start! - 86400 LOOP END SUB
SUB FourBit (Custom()) 'from Bob Seguin's Winbit routine with minor changes IF BMPHead.PWidth MOD 8 <> 0 THEN ZeroPAD$ = SPACE$((8 - BMPHead.PWidth MOD 8) \ 2) 'prevents slanted bitmap
a$ = " " FOR Colr = 0 TO 15 'read 16 bitmap RGB colors OUT &H3C8, Colr GET #1, , a$: Blu = ASC(a$) \ 4 GET #1, , a$: Grn = ASC(a$) \ 4 GET #1, , a$: Red = ASC(a$) \ 4 OUT &H3C9, Red 'set color values OUT &H3C9, Grn OUT &H3C9, Blu GET #1, , a$ '--- unused byte NEXT Colr
GetRGB Custom() 'get bitmap color settings AutoClr Custom() 'autoset menu color
o$ = " " GET #1, BMPHead.Offset, o$ 'get picture pixel data
y = BMPHead.PDepth - 1 a$ = " "
DO: x = 0 'reset x each row DO GET #1, , a$ HiNIBBLE = ASC(a$) \ &H10 '4 bit uses 2 nibbles LoNIBBLE = ASC(a$) AND &HF
PSET (x, y), HiNIBBLE
x = x + 1 PSET (x, y), LoNIBBLE
x = x + 1 LOOP WHILE x < BMPHead.PWidth 'stop loop if past width
GET #1, , ZeroPAD$ 'get padder if needed y = y - 1 'work from bottom up LOOP UNTIL y = -1 CLOSE #1 END SUB
SUB GetInfo 'get filename and display bitmap settings
Border 11 COLOR 11: LOCATE 3, 21: PRINT "BMPCOLOR Screen 12 Bitmap Color Editor" COLOR 10: LOCATE 5, 5: PRINT "This program allows you to edit bitmap color settings and create images " LOCATE 6, 5: PRINT "that use just the default QB colors. It uses BSAVE to create files that" LOCATE 7, 5: PRINT "use the .BCS extension. Color settings are indexed in a graphics array " LOCATE 8, 5: PRINT "from Array(0) to Array(47). The image is PUT from Array(48) to the screen" LOCATE 9, 5: PRINT "using up to 3 numbered files. The numbers are at the end of the file's" LOCATE 10, 5: PRINT "first name and MUST be loaded sequencially if the image is quite large." COLOR 15: LOCATE 14, 5: PRINT " The program allows you to do the following for any bitmap image:" COLOR 13: LOCATE 16, 5: PRINT " 1) Right Click any attribute to Change colors to Default or Bitmap" LOCATE 17, 5: PRINT " (Includes Add, Remove, Custom settings or Set All button)" LOCATE 18, 5: PRINT " 2) Swap the color attributes for one color to another in full image" LOCATE 19, 5: PRINT " or a limited boxed area (Key P). Boxed area changes can be undone!" LOCATE 20, 5: PRINT " Left click Old color attribute and Right click New attribute first." LOCATE 21, 5: PRINT " 3) Create Custom colors by changing the RGB settings (Key C)" LOCATE 22, 5: PRINT " 4) Toggle between Default and the Bitmap's colors with B and D keys." LOCATE 23, 5: PRINT " 5) Can be used with 1, 4, or 24 BPP (2, 16 or 16 grey color) bitmaps"
COLOR 14: LOCATE 25, 16: PRINT " You are personally responsible for entering the" LOCATE 26, 16: PRINT "proper path and file name(program will add the .BMP)"
COLOR 11: LOCATE 29, 35: PRINT "Press any Key!"; DO: LOOP UNTIL INKEY$ <> "" CLS : COLOR 11 FILES "*.bmp" SOUND 500, 3 COLOR 14: LOCATE 28, 5: INPUT "Select Bitmap File Name from above (Enter Quits): ", FileName$ CLS IF LEN(FileName$) > 0 AND LEN(FileName$) < 9 THEN '1 to 8 character name SaveName$ = UCASE$(FileName$) FileName$ = UCASE$(FileName$) + ".BMP" OPEN FileName$ FOR INPUT AS #1 'check if file exists CLOSE #1 ELSEIF LEN(FileName$) = 0 THEN Closing: SYSTEM ELSE : COLOR 12: LOCATE 15, 31: PRINT "Invalid File Name!": SLEEP 2: Closing: SYSTEM END IF
IF FileErr = 0 THEN 'check for file error OPEN FileName$ FOR BINARY AS #1 ELSE : COLOR 12: LOCATE 15, 33: PRINT "File Not Found!": SLEEP 2: Closing: SYSTEM END IF GET #1, , BMPHead IF BMPHead.ID <> "BM" THEN COLOR 12: LOCATE 15, 30: PRINT "File is Not a bitmap!": SLEEP 2: Closing: SYSTEM IF BMPHead.BPP = 8 THEN COLOR 12: LOCATE 15, 32: PRINT "Bitmap is 8 BPP!": SLEEP 2: Closing: SYSTEM
Border 11 COLOR 11: LOCATE 2, 20: PRINT "Bitmap Header Information for "; FileName$ COLOR 14 LOCATE 4, 25: PRINT "File Type ID = "; BMPHead.ID LOCATE 5, 25: PRINT "File Data Size ="; BMPHead.size LOCATE 6, 25: PRINT "Offset of Pixel Data ="; BMPHead.Offset LOCATE 7, 25: PRINT "Header Size ="; BMPHead.Hsize LOCATE 8, 25: PRINT "Picture Width ="; BMPHead.PWidth LOCATE 9, 25: PRINT "Picture Depth ="; BMPHead.PDepth LOCATE 10, 25: PRINT "Number of Planes ="; BMPHead.Planes LOCATE 11, 25: PRINT "Bits Per Pixel ="; BMPHead.BPP; " (1, 4, or 24 bit)" LOCATE 12, 25: PRINT "Compression ="; BMPHead.Compress; " (0 = not compressed)" LOCATE 13, 25: PRINT "Image Byte Size ="; BMPHead.ImageBytes LOCATE 14, 25: PRINT "Width in PELS ="; BMPHead.Xres LOCATE 15, 25: PRINT "Depth in PELs ="; BMPHead.Yres LOCATE 16, 25: PRINT "Number of COLORS ="; BMPHead.NumColors; " (normally 0) " LOCATE 17, 25: PRINT "Significant Colors ="; BMPHead.SigColors; " (normally 0)"
COLOR 10: LOCATE 19, 5: PRINT "Use the following actions to edit the bitmap colors using bottom readings." COLOR 11: LOCATE 20, 5: PRINT " Press D to view all default QB colors. B to view the bitmap colors left." COLOR 13: LOCATE 21, 5: PRINT " Left Click to select Old color. Right Click for New color. Then:" COLOR 14: LOCATE 22, 5: PRINT " Press P to change Old color to the New Attribute in an area or full!" COLOR 10: LOCATE 23, 3: PRINT "To Add or Remove a Default color or Customize a color, Right Click it then:" COLOR 15: LOCATE 24, 5: PRINT " Press A to add a new QB Default attribute to the color settings" LOCATE 25, 5: PRINT " Press R to remove a set QB Default attribute from the color settings" COLOR 13: LOCATE 26, 5: PRINT " Press C to customize the RGB color settings of a New attribute selected" COLOR 11: LOCATE 27, 5: PRINT " Press S to view the current default QB attributes set." COLOR 14: LOCATE 28, 5: PRINT " Press Q to save the image to BCS file(s). ESC key Aborts all edits!"
COLOR 11: LOCATE 30, 27: PRINT " Press any key to view Bitmap."; DO: LOOP UNTIL INKEY$ <> "" CLS END SUB
SUB GetRGB (Array()) 'puts the RGB settings into a Custom or Normal array FOR c = 0 TO 15 OUT &H3C7, c 'set attribute to read Array(3 * c) = INP(&H3C9) 'get RGB color settings Array((3 * c) + 1) = INP(&H3C9) Array((3 * c) + 2) = INP(&H3C9) NEXT c END SUB
SUB MouseDriver (AX, BX, CX, DX, LB, RB, EX) IF EX% = 1 THEN mouse$ = SPACE$(57) FOR i = 1 TO 57 READ a$ H$ = CHR$(VAL("&H" + a$)) MID$(mouse$, i, 1) = H$ NEXT i END IF DEF SEG = VARSEG(mouse$) CALL Absolute(AX, BX, CX, DX, SADD(mouse$)) LB = ((BX AND 1) <> 0) RB = ((BX AND 2) <> 0)
END SUB
SUB OneBIT (Custom()) 'Black and White bitmaps/fonts BitsOver = BMPHead.PWidth MOD 32 IF BitsOver THEN ZeroPAD$ = SPACE$((32 - BitsOver) \ 8)
'Hop$ = SPACE$(8) 'GET #1, , Hop$ 'bypass color table
y = BMPHead.PDepth - 1
o$ = " " GET #1, BMPHead.Offset, o$
GetRGB Custom() 'get bitmap color settings AutoClr Custom() 'autoset menu color
a$ = " "
DO x = 0
DO
GET #1, , a$ CharVAL = ASC(a$)
Bit = 128 FOR BitCOUNT = 1 TO 8 IF CharVAL AND Bit THEN PSET (x, y), 15 ELSE PSET (x, y), 0 Bit = Bit / 2 x = x + 1 NEXT BitCOUNT
LOOP WHILE x < BMPHead.PWidth
GET #1, , ZeroPAD$ y = y - 1
LOOP UNTIL y = -1 END SUB
SUB Painter 'changes attribute from old to new all over or in a boxed area COLOR Clr: SOUND 600, 3: CLine LOCATE 30, 20: PRINT "Paint Full bitmap area or Boxed area? (F/B) "; DO: Area$ = UCASE$(INKEY$): LOOP UNTIL Area$ = "F" OR Area$ = "B" PRINT Area$; IF Area$ = "F" THEN MouseDriver 2, BX, CX, DX, LB, RB, 0 'hide mouse for attribute change C1 = 0: C2 = BMPHead.PWidth - 1 'cols R1 = 0: R2 = BMPHead.PDepth - 1 'rows ELSE : C1 = -1: R1 = -1: BoxClr = 0: CLine LOCATE 30, 5: PRINT "Box Area of Small(10 X 10), Medium(20 X 20) or Large(50 X 50)? (S/M/L) "; DO: Area$ = UCASE$(INKEY$): LOOP UNTIL Area$ = "S" OR Area$ = "M" OR Area$ = "L" PRINT Area$; SELECT CASE Area$ CASE "S": size = 10 CASE "M": size = 20 CASE "L": size = 50 END SELECT CLine LOCATE 30, 5: PRINT "Left click where Top Left corner of box area will be located!"; DO: MouseDriver 3, BX, CX, DX, LB, RB, 0 'read mouse position IF LB AND CX < BMPHead.PWidth - 1 AND DX < BMPHead.PDepth - 1 THEN C1 = CX: R1 = DX LOOP UNTIL C1 > -1 AND R1 > -1 C2 = C1 + size: R2 = R1 + size IF C2 > BMPHead.PWidth - 1 THEN C2 = BMPHead.PWidth - 1 IF R2 > BMPHead.PDepth - 1 THEN R2 = BMPHead.PDepth - 1 MouseDriver 2, BX, CX, DX, LB, RB, 0 'Hide mouse for GET GET (C1, R1)-(C2, R2), Image(48) FOR x = C1 TO C2 'find colors used in area FOR y = R1 TO R2 AreaColors(POINT(x, y)) = 1 NEXT NEXT FOR a = 1 TO 15 IF AreaColors(a) = 0 THEN BoxClr = a 'choose an unused color NEXT LINE (C1, R1)-(C2, R2), BoxClr, B SOUND 500, 3: ERASE AreaColors: CLine LOCATE 30, 10: PRINT "Accept the current Box Area to swap color"; SetOld; "with"; SetNew; "? (Y/N) "; DO: Area$ = UCASE$(INKEY$): LOOP UNTIL Area$ = "Y" OR Area$ = "N" PRINT Area$; PUT (C1, R1), Image(48), PSET END IF IF Area$ = "F" OR Area$ = "Y" THEN FOR x = C1 TO C2 FOR y = R1 TO R2 IF POINT(x, y) = SetOld THEN PSET (x, y), SetNew NEXT y NEXT x END IF IF Area$ = "Y" THEN SOUND 600, 3: CLine: LOCATE 30, 25: PRINT "UNDO the Box Area Color changes? (Y/N)"; DO: UnDo$ = UCASE$(INKEY$): LOOP UNTIL UnDo$ <> "" IF UnDo$ = "Y" THEN PUT (C1, R1), Image(48), PSET END IF SetOld = -1: SetNew = -1 MouseDriver 1, BX, CX, DX, LB, RB, 0 'Show mouse again CLine END SUB
SUB SetAll (AllSet, Custom(), Normal()) COLOR Clr: LOCATE 30, 1: IF AllSet = 0 THEN FOR i = 0 TO 15: Changed(i) = 1: NEXT AllSet = 1: PALETTE PRINT "All Default"; ELSE : FOR i = 0 TO 15: Changed(i) = 0: NEXT AllSet = 0: BMPColors Custom(), Normal() PRINT "All Bitmap "; END IF DO: MouseDriver 3, BX, CX, DX, LB, RB, 0: LOOP UNTIL RB = 0 END SUB
SUB Settings CLine COLOR Clr: LOCATE 30, 1: PRINT " Defaults Set:"; IF Changed(0) = 1 THEN PRINT 0; FOR i = 1 TO 15 IF Changed(i) = 1 THEN set = 1: COLOR i: PRINT i; NEXT IF set = 0 THEN PRINT " None"; PRINT ", Any Key!"; DO: LOOP UNTIL INKEY$ <> "" CLine END SUB
SUB Tint (Custom()) CLine COLOR Clr: LOCATE 30, 20: PRINT "Enter tint color (Red, Green, or Blue)"; DO: tnt$ = UCASE$(INKEY$): LOOP UNTIL tnt$ = "R" OR tnt$ = "G" OR tnt$ = "B" R = 6: G = 6: B = 6 SELECT CASE tnt$ CASE "R": R = 0: tin$ = "Red" CASE "G": G = 0: tin$ = "Green" CASE "B": B = 0: tin$ = "Blue" END SELECT FOR i = 1 TO 15 OUT &H3C8, i OUT &H3C9, Custom(3 * i) - R OUT &H3C9, Custom((3 * i) + 1) - G OUT &H3C9, Custom((3 * i) + 2) - B NEXT LOCATE 30, 20: PRINT "You selected a "; tin$; " tint. Save the tint?(Y/N)"; DO: Tn$ = UCASE$(INKEY$): LOOP UNTIL Tn$ = "Y" OR Tn$ = "N" IF Tn$ = "Y" THEN FOR t = 1 TO 15 Custom(3 * t) = Custom(3 * t) - R Custom((3 * t) + 1) = Custom((3 * t) + 1) - G Custom((3 * t) + 2) = Custom((3 * t) + 2) - B NEXT Trun = 1 END IF CLine END SUB
SUB TrueColor24 (Custom()) 'screen 12 ************************greyscale 24 bit IF ((BMPHead.PWidth * 3) MOD 4) <> 0 THEN ZeroPAD$ = SPACE$((4 - ((BMPHead.PWidth * 3) MOD 4))) END IF
n = 3 FOR Colr = 0 TO 15 'set greyscale shades OUT &H3C8, Colr OUT &H3C9, n OUT &H3C9, n OUT &H3C9, n n = n + 4 NEXT Colr
y = BMPHead.PDepth - 1
GetRGB Custom() 'get bitmap color settings AutoClr Custom() 'autoset menu color
o$ = " " GET #1, BMPHead.Offset, o$
a$ = " " B$ = " " c$ = " "
DO x = 0 DO GET #1, , a$ GET #1, , B$ GET #1, , c$ a = ASC(a$) B = ASC(B$) c = ASC(c$) d = (a + B + c) \ 48
PSET (x, y), d x = x + 1
LOOP WHILE x < BMPHead.PWidth
GET #1, , ZeroPAD$ y = y - 1
LOOP UNTIL y = -1 END SUB
'Ted
This message has been edited by burger2227 on Jul 16, 2008 1:32 PM This message has been edited by burger2227 on Jul 16, 2008 1:08 PM
This message has been edited by burger2227 on Dec 8, 2008 8:35 PM This message has been edited by burger2227 on Jul 17, 2008 3:56 PM This message has been edited by burger2227 on Jul 16, 2008 8:08 PM This message has been edited by burger2227 on Jul 16, 2008 4:30 PM
I tried a couple bitmaps - both SCREEN 12. When prompted, I entered 12 and the bitmap was displayed. I then pressed "B" to BSAVE the image and after a few moments got the message "Bitmap not saved". Not sure what the problem was (???). FYI, the first bitmap was small enough to be saved in a single file, the second would need 3 files.
I just tried it and it worked fine. I would not post it here if it was not tested. I use it all the time. Try it again. Perhaps it has something to do with your keypresses. Or it could be a formatting problem here! Let me know.
A large bitmap takes longer to POINT the used colors. That info is necessary as you know and it is displayed after the B or anykey press to display the bitmap color info.
Thanks,
Ted
This message has been edited by burger2227 on Jul 16, 2008 7:33 PM This message has been edited by burger2227 on Jul 16, 2008 7:24 PM
I followed instructions, and waited a long time so I wouldn't interfere with anything the program was doing. After a minute or so, I pressed a key and got the "Bitmap not saved" message again.
I'll have a look at the code and see what I might have done wrong -- but actually, the program should respond to incorrect key presses, etc. For example, if you interrupt a process, the message might read "program terminated early -- bitmap was not saved" (or similar). BTW, the SCREEN 12 image I used was a 4-bit image. What was the one you tested with?
Found a couple of sizing errors, but nothing with pressing B
July 16 2008, 8:17 PM
I changed the code. Damn, sometimes I think QB changes my code! I swear. I used it for months and all of a sudden it was cropping off parts of the image. I found that the width and depth were somehow swapped. The main code is easy to troubleshoot, but B works for me. I use Key$ = UCASE$(INKEY$) there. I even clear the key buffer. Press B AFTER it displays.
I don't want to print anything on the area, but I could print something when it is done scanning with point. If you could see it............like if not fullscreen. I assumed finally seeing the image would be good enough. Today BEEP may not even work on some PC's LOL.
Perhaps it is DOSBOX creating problems. I want to fix that too if possible!
Ted
This message has been edited by burger2227 on Jul 16, 2008 10:24 PM This message has been edited by burger2227 on Jul 16, 2008 8:31 PM This message has been edited by burger2227 on Jul 16, 2008 8:19 PM
BEEP in screen 13 sounds a pc speaker beep on my computer
July 17 2008, 8:31 AM
On my Windows XP, in full screen BEEP sounds a beep through the PC speaker. But when QBASIC is runnning in a window, BEEP plays a WAV file which is the setting for "Default Beep".
Naturally 4 bit, Bob, but I have added a BEEP to it
July 17 2008, 5:00 PM
Apparently large bitmaps take longer to scan with POINT so that I can set any unused colors to default. So I added a beep and made some other small changes. I found a large bitmap and it DID take a while to scan it. Perhaps there is a better way, but I really like the default colors set when bitmaps just set them to 0 RGB. I found that happens a lot! Especially with attribute 15 that a mouse pointer uses.
Try it again Bob. If you can think of a way to speed it up, I am all ears! I hope BEEP works in DOSBOX.
Thanks for your input,
Ted
This message has been edited by burger2227 on Jul 17, 2008 5:02 PM
It is sent through my sound card. Unfortunately, the program still states "Bitmap not saved" after the scan is complete. Not sure what the problem is (I'd just as soon let you figure it out, since you know the program and I don't).
FYI: I ran the program, the files were listed, chose one and displayed it. I then clicked "B". For the small one (200x140) it beeped within a couple of seconds, for the large one (500x480) it beeped after about half a minute. Then nothing happened. I waited. Finally, I pressed a key and got the "not saved" message. (???).
I think I will add the "Press B to BSAVE" after an image is ready to BSAVE. If the PRINT is within the area of the bitmap, I can GET that area first and save it to restore the image if "B" is pressed then. Normally, the area would not be used by most bitmaps anyhow. If it is, then I can PUT it back. I just have to add another SUB and make the instructions clearer.
The 26K array is just sitting there mostly empty before the BSAVE anyhow.
July 17 2008, 7:06 PM
I can go by the scr (screen mode) value and NumColors to know where the colors are set. Might as well use it before the BSAVE to hold the part of the bitmap for the PUT if needed. I can check the BMP depth to see if I need to do that.
I don't want to overload the memory in Qbasic as it does not seem to work as well as QB4.5. Some of my image programs will not BLOAD as well in QB1. However the programs ARE too big to compile in 4.5. Are you using QBasic1? I hope that can work also.
Well, I guess I have something more to play with LOL. And here I was getting ready to make a monochrome SAVER for Screen 2. I don't think there is a huge demand for it though. I also might try to convert 12 to 9, but those darn DAC settings are a pain.
Ted
This message has been edited by burger2227 on Jul 17, 2008 7:13 PM
You can also use Bob's fonts if you want. It will convert any screen 12 image to screen 2 if you squash it 42% before hand. The main problem is having a decent Editor for the images to make the size and Palette adjustments. I use PaintShop Pro 8.
I could also allow BSAVE files from screen 12 if necessary. Let me know if there is an interest in this idea. I did not see much QB code used from the links. Saw a lot of batch files however. Screen 2 is not a big seller in QB.
'BSAVER.BAS 2008 by Ted Weissgerber. Saves 1, 4, 8 or 24 BPP bitmaps to BSAVE File(s). 'NOTE: Screen 12 may require up to 3 BSV numbered files for fullscreen. Will add 1, 2 or 3 to the filename. ' Screen 13 will save almost fullscreen into one BSV file. If not adds 5 and 6 to filename ' BEST Bitmap colors are in 4 bit(Screen 12) or 8 bit(Screen 13)! 24 bit color is simulated.
DEFINT A-Z DECLARE SUB GetInfo (TC$) DECLARE SUB FourBIT () DECLARE SUB OneBIT () DECLARE SUB TrueColor () DECLARE SUB GetRGB (Array()) DECLARE SUB ScanBMP (Changed(), Image()) DECLARE SUB EightBIT () DECLARE SUB BMPColors (Custom(), Normal()) DECLARE SUB BSaveOne () DECLARE SUB BSaver () DECLARE SUB AutoClr (Custom()) DECLARE SUB Show15 () DECLARE SUB TrueGrey () DECLARE SUB Border (Colr) DECLARE SUB Closing ()
TYPE BMPHeaderType 'BITMAP HEADER TYPE ID AS STRING * 2 'File ID is "BM" Size AS LONG 'Size of the data file Res1 AS INTEGER 'Reserved 1 should be 0 Res2 AS INTEGER 'Reserved 2 should be 0 Offset AS LONG 'Position of start of pixel data Hsize AS LONG 'Information header size PWidth AS LONG 'Image width PDepth AS LONG 'Image height Planes AS INTEGER 'number of planes BPP AS INTEGER 'Bits per pixel, 8 for Screen 13, 256 color image Compress AS LONG 'Compression ImageBytes AS LONG 'Width * Height ,ImageSIZE Xres AS LONG 'Width in PELS per metre Yres AS LONG 'depth in PELS per metre NumColors AS LONG 'Number of COLORS SigColors AS LONG 'Significant COLORs END TYPE
DIM SHARED BMPHead AS BMPHeaderType DIM SHARED Image(26000) DIM SHARED Changed(0 TO 255) DIM SHARED FileName$, SaveName$, Scr, NumColors, Clr
'MAIN PROGRAM ON ERROR GOTO Handler GetInfo TC$ 'gets filename errors, bitmap info and determines screen mode
IF Scr = 12 THEN NumColors = 16 REDIM Normal(0 TO 47) REDIM Custom(0 TO 47) ELSEIF Scr = 13 THEN NumColors = 256 REDIM Normal(0 TO 767) REDIM Custom(0 TO 767) END IF GetRGB Normal() 'Default QB color settings SELECT CASE BMPHead.BPP CASE 1: OneBIT '12 or 13 CASE 4: FourBIT '12 or 13 CASE 8: EightBIT '13 only CASE 24: IF Scr = 13 AND TC$ = "C" THEN TrueColor ELSE TrueGrey '12 greyscale only END SELECT GetRGB Custom() 'custom color settings from BMP AutoClr Custom() 'find a visible color ScanBMP Changed(), Image() 'find colors actually used by image BMPColors Custom(), Normal() 'set used and default colors to Image array
DO: LOOP UNTIL INKEY$ = "" DO: key$ = UCASE$(INKEY$): LOOP UNTIL key$ <> "" COLOR Clr IF key$ <> "B" THEN IF Scr = 13 THEN LOCATE 25, 15 ELSE LOCATE 30, 30 PRINT "Bitmap not Saved!"; : Show15: SLEEP: Closing: SYSTEM END IF IF Scr = 12 THEN PUT (232, 463), Image(48), PSET IF BMPHead.PWidth * BMPHead.PDepth <= 102400 THEN BSaveOne ELSE BSaver 'up to full screen in 12 ELSEIF Scr = 13 THEN PUT (112, 190), Image(768), PSET IF BMPHead.PWidth * BMPHead.PDepth <= 50400 THEN BSaveOne ELSE BSaver 'up to full screen in 13 END IF IF Scr = 12 THEN LOCATE 30, 25 ELSE LOCATE 25, 10 PRINT "File BSaved as "; SaveName$; Show15 SLEEP Closing
SYSTEM 'END of Main Program
Handler: 'check if file entry error or other error BEEP FileErr = -1 RESUME NEXT
SUB AutoClr (Custom()) 'sets bottom menu color FOR i = 3 TO (3 * NumColors) - 1 STEP 3 clrtot = Custom(i) + Custom(i + 1) + Custom(i + 2) IF clrtot > 100 AND clrtot <> Custom(0) + Custom(1) + Custom(2) THEN Clr = i \ 3: EXIT SUB NEXT END SUB
SUB BMPColors (Custom(), Normal()) 'Resets to bitmap color values plus defaults set OUT &H3C8, 0 FOR i = 0 TO (3 * NumColors) - 1 STEP 3 IF Changed(i \ 3) = 1 THEN OUT &H3C9, Custom(i): Image(i) = Custom(i) OUT &H3C9, Custom(i + 1): Image(i + 1) = Custom(i + 1) OUT &H3C9, Custom(i + 2): Image(i + 2) = Custom(i + 2) ELSE OUT &H3C9, Normal(i): Image(i) = Normal(i) OUT &H3C9, Normal(i + 1): Image(i + 1) = Normal(i + 1) OUT &H3C9, Normal(i + 2): Image(i + 2) = Normal(i + 2) END IF NEXT END SUB
SUB Border (Colr) COLOR Colr FOR row = 1 TO 30 LOCATE row, 1: PRINT CHR$(179); LOCATE row, 80: PRINT CHR$(179); NEXT row FOR col = 1 TO 80 LOCATE 1, col: PRINT CHR$(196); LOCATE 30, col: PRINT CHR$(196); NEXT col LOCATE 1, 1: PRINT CHR$(218); LOCATE 1, 80: PRINT CHR$(191); LOCATE 30, 1: PRINT CHR$(192); LOCATE 30, 80: PRINT CHR$(217); END SUB
SUB BSaveOne 'Bsave Screen 12 or 13 into One file SaveName$ = FileName$ + ".BSV" DEF SEG = VARSEG(Image(0)) GET (0, 0)-(BMPHead.PWidth - 1, BMPHead.PDepth - 1), Image(NumColors * 3) 'indexed for 16 colors LINE (0, 0)-(BMPHead.PWidth, BMPHead.PDepth), Clr, B FOR a& = 26000 TO 0 STEP -1 IF Image(a&) THEN ArraySize& = a&: EXIT FOR NEXT BSAVE SaveName$, VARPTR(Image(0)), (2 * ArraySize&) + 200 '51,600 or 65543 DEF SEG
END SUB
SUB BSaver 'Bsave multiple files in screen 12 or 13 SaveFile$ = MID$(FileName$, 1, 7) IF Scr = 12 THEN Num = 0: Limit = 320: Spot = 159 ELSE : Num = 4: Limit = 100: Spot = 99 END IF DEF SEG = VARSEG(Image(0))
FOR y = 0 TO Limit STEP Spot + 1 'save into 3 files IF y + Spot <= BMPHead.PDepth - 1 THEN GET (0, y)-(BMPHead.PWidth - 1, y + Spot), Image(3 * NumColors) 'Full GET LINE (0, y)-(BMPHead.PWidth, y + Spot), Clr, B IF y + Spot = BMPHead.PDepth - 1 THEN nobsave = -1 ELSE GET (0, y)-(BMPHead.PWidth - 1, BMPHead.PDepth - 1), Image(3 * NumColors) 'Partial GET ends loop LINE (0, y)-(BMPHead.PWidth, BMPHead.PDepth), Clr, B nobsave = -1 END IF FOR a& = 26000 TO 0 STEP -1 IF Image(a&) THEN ArraySize& = a&: EXIT FOR NEXT Num = Num + 1 'change file name by number 1, 2, 3 (12) or 5, 6 (13) SaveName$ = SaveFile$ + LTRIM$(STR$(Num)) + ".BSV" BSAVE SaveName$, VARPTR(Image(0)), (2 * ArraySize&) + 200 '51,600 or 65543 IF nobsave THEN EXIT FOR NEXT y DEF SEG
END SUB
SUB Closing CLS IF Clr = 0 THEN COLOR 15 ELSE COLOR Clr IF Scr = 12 OR Scr = 0 THEN LOCATE 15, 30 ELSE LOCATE 12, 10 PRINT "Ted Weissgerber 2008" IF Scr = 12 OR Scr = 0 THEN LOCATE 17, 30 ELSE LOCATE 14, 10 PRINT "burger2227@gmail.com" SLEEP 3 END SUB
SUB EightBIT '************** 8 Bit Screen 13 Only 'Bob's Winbit
IF BMPHead.PWidth MOD 4 THEN ZeroPAD$ = SPACE$(4 - (BMPHead.PWidth MOD 4))
a$ = " " u$ = " "
OUT &H3C8, 0 FOR Colr = 0 TO 255 GET #1, , a$: Blu = ASC(a$) \ 4 GET #1, , a$: Grn = ASC(a$) \ 4 GET #1, , a$: Red = ASC(a$) \ 4 OUT &H3C9, Red OUT &H3C9, Grn OUT &H3C9, Blu GET #1, , u$ '--- unused byte NEXT Colr
y = BMPHead.PDepth - 1
o$ = " " GET #1, BMPHead.Offset, o$
p$ = " "
DO: x = 0 DO GET #1, , p$ PSET (x, y), ASC(p$) x = x + 1 LOOP WHILE x < BMPHead.PWidth
GET #1, , ZeroPAD$ y = y - 1
LOOP UNTIL y = -1
END SUB
SUB FourBIT '********************* 4 bit color screen 12 or 13 'Bob's Winbit
IF BMPHead.PWidth MOD 8 THEN ZeroPAD$ = SPACE$((8 - BMPHead.PWidth MOD 8) \ 2)
a$ = " " FOR Colr = 0 TO NumColors - 1 OUT &H3C8, Colr GET #1, , a$: Blu = ASC(a$) \ 4 GET #1, , a$: Grn = ASC(a$) \ 4 GET #1, , a$: Red = ASC(a$) \ 4 OUT &H3C9, Red OUT &H3C9, Grn OUT &H3C9, Blu GET #1, , a$ '--- unused byte NEXT Colr
o$ = " " GET #1, BMPHead.Offset, o$ y = BMPHead.PDepth - 1
a$ = " "
DO x = 0 DO GET #1, , a$
HiNIBBLE = ASC(a$) \ &H10 LoNIBBLE = ASC(a$) AND &HF
PSET (x, y), HiNIBBLE x = x + 1 PSET (x, y), LoNIBBLE x = x + 1 LOOP WHILE x < BMPHead.PWidth
GET #1, , ZeroPAD$ y = y - 1
LOOP UNTIL y = -1
END SUB
SUB GetInfo (TC$) 'get filename and display bitmap settings SCREEN 12 Border 11 COLOR 13: LOCATE 4, 17: PRINT "BitMaP Full Screen BSAVER for Screens 12 or 13" COLOR 10: LOCATE 7, 5: PRINT "This program loads Bitmaps to the screen according to the Color settings" LOCATE 8, 5: PRINT "determined by the bitmap header BPP setting. It then converts the screen" LOCATE 9, 5: PRINT "into a BSAVE file with the color settings indexed from the start of the" LOCATE 10, 5: PRINT "image array created with GET. In Screen 12 the image is then indexed to" LOCATE 11, 5: PRINT "Array(48) and Screen 13 is placed at Array(768). When the files are loaded" LOCATE 12, 5: PRINT "using BLOAD, the graphics array holds the image after the color settings." LOCATE 13, 5: PRINT "Just use PUT(x, y), Array(48) in Screen 12 or PUT(x, y), Array(768) in 13" LOCATE 14, 5: PRINT "Load the image and use OUT &H3C9 to load the color settings of the BMP." COLOR 12: LOCATE 17, 5: PRINT " Bitmap sizes limited to 640 X 480 in 12 and 320 X 200 in 13! " COLOR 14: LOCATE 20, 5: PRINT "You are personally responsible for entering the proper name and path! " LOCATE 21, 5: PRINT " This program will add the .BMP extension." COLOR 11: LOCATE 24, 5: PRINT " After the image is loaded, wait for color scan." LOCATE 25, 5: PRINT " Then press B key to BSAVE! Anther key Aborts!" COLOR 13: LOCATE 29, 35: PRINT "Press any Key!"; DO: LOOP UNTIL INKEY$ <> ""
CLS : COLOR 11 FILES "*.bmp" SOUND 700, 3 COLOR 14: INPUT " Enter First part of a file name (Enter Quits): ", FileName$ CLS IF LEN(FileName$) > 0 AND LEN(FileName$) < 9 THEN '1 to 8 character name OpenName$ = UCASE$(FileName$) + ".BMP" OPEN OpenName$ FOR INPUT AS #1 'check if file exists CLOSE #1 ELSE : COLOR 12: LOCATE 15, 31: PRINT "Invalid File Name!": SLEEP: Closing: SYSTEM END IF
IF FileErr = 0 THEN 'check for file exist error OPEN OpenName$ FOR BINARY AS #1 ELSE : COLOR 12: LOCATE 15, 33: PRINT "File Not Found!": SLEEP: Closing: SYSTEM END IF GET #1, , BMPHead IF BMPHead.ID <> "BM" THEN COLOR 12: LOCATE 15, 30: PRINT "File is Not a bitmap!": SLEEP: Closing: SYSTEM Border 11 COLOR 11: LOCATE 2, 20: PRINT "Bitmap Header Information for "; FileName$ COLOR 14 LOCATE 4, 20: PRINT "File Type ID = "; BMPHead.ID LOCATE 5, 20: PRINT "Data file Size ="; BMPHead.Size LOCATE 6, 20: PRINT "Offset of Pixel Data ="; BMPHead.Offset LOCATE 7, 20: PRINT "Header Size ="; BMPHead.Hsize LOCATE 8, 20: PRINT "Picture Width ="; BMPHead.PWidth LOCATE 9, 20: PRINT "Picture Depth ="; BMPHead.PDepth LOCATE 10, 20: PRINT "Number of Planes ="; BMPHead.Planes LOCATE 11, 20: PRINT "Bits Per Pixel ="; BMPHead.BPP; " (1, 4, 8 or 24 bit)" LOCATE 12, 20: PRINT "Compression ="; BMPHead.Compress; " (0 = not compressed)" LOCATE 13, 20: PRINT "Image Byte Size ="; BMPHead.ImageBytes LOCATE 14, 20: PRINT "Width in PELS ="; BMPHead.Xres LOCATE 15, 20: PRINT "Depth in PELs ="; BMPHead.Yres LOCATE 16, 20: PRINT "Number of COLORS ="; BMPHead.NumColors; " (normally 0) " LOCATE 17, 20: PRINT "Significant Colors ="; BMPHead.SigColors; " (normally 0)"
IF BMPHead.BPP = 8 THEN IF BMPHead.PWidth > 320 OR BMPHead.PDepth > 200 THEN CLS : COLOR 12: LOCATE 15, 30: PRINT "Bitmap too large!": SLEEP 3: SYSTEM COLOR 11: LOCATE 20, 32: PRINT "Screen 13 Bitmap": Scr = 13 ELSE IF BMPHead.PWidth <= 640 AND BMPHead.PDepth <= 480 THEN 'check for Screen 12 size Scr = 12: COLOR 11: LOCATE 20, 30: PRINT "Screen 12 Bitmap" ELSE : CLS : COLOR 12: LOCATE 15, 30: PRINT "Bitmap too large!": SLEEP 3: SYSTEM END IF IF BMPHead.PWidth <= 320 AND BMPHead.PDepth <= 200 THEN 'check for Screen 13 size SOUND 400, 3: COLOR 11: LOCATE 20, 30: PRINT "Screen 12 or 13? "; DO: Scrn$ = INKEY$ IF Scrn$ = "1" AND used = 0 THEN PRINT "1": used = 1 IF Scrn$ = "2" OR Scrn$ = "3" THEN EXIT DO 'filter for 2 or 3 entry only LOOP Scr = VAL(Scrn$) + 10 COLOR 11: LOCATE 20, 30: PRINT "Screen"; Scr; "Bitmap " END IF IF BMPHead.BPP = 24 AND Scr = 13 THEN SOUND 400, 3 COLOR 15: LOCATE 22, 18: PRINT "TrueColor Bitmap in Color or Greyscale? (C/G) "; DO: TC$ = UCASE$(INKEY$): LOOP UNTIL TC$ = "C" OR TC$ = "G" PRINT TC$ END IF END IF COLOR 10: LOCATE 25, 15: PRINT "Note: Once Displayed, Press B to BSAVE the bitmap!" COLOR 13: LOCATE 28, 27: PRINT "Press any key to view Bitmap." DO: SLEEP: LOOP UNTIL INKEY$ <> "" CLS SCREEN Scr 'set bitmap screen
END SUB
SUB GetRGB (Array()) 'puts the RGB settings into an Array(0 to 47 or 767) FOR c = 0 TO NumColors - 1 OUT &H3C7, c 'set attribute to read Array(3 * c) = INP(&H3C9) 'get RGB color settings Array((3 * c) + 1) = INP(&H3C9) Array((3 * c) + 2) = INP(&H3C9) NEXT c END SUB
SUB OneBIT '********* Black and White can be tinted 'Winbit BitsOver = BMPHead.PWidth MOD 32 IF BitsOver THEN ZeroPAD$ = SPACE$((32 - BitsOver) \ 8)
y = BMPHead.PDepth - 1 o$ = " " GET #1, BMPHead.Offset, o$ a$ = " "
DO x = 0 DO GET #1, , a$ CharVAL = ASC(a$) Bit = 128 FOR BitCOUNT = 1 TO 8 IF CharVAL AND Bit THEN PSET (x, y), 15 ELSE PSET (x, y), 0 Bit = Bit / 2 x = x + 1 NEXT BitCOUNT LOOP WHILE x < BMPHead.PWidth GET #1, , ZeroPAD$ y = y - 1 LOOP UNTIL y = -1
END SUB
SUB ScanBMP (Changed(), Image()) 'scans bitmap colors used DIM xx AS LONG, yy AS LONG ScanWidth& = BMPHead.PWidth ScanDepth& = BMPHead.PDepth IF Scr = 12 THEN IF ScanWidth& > 640 THEN ScanWidth& = 640 IF ScanDepth& > 480 THEN ScanDepth& = 480 GET (232, 463)-(376, 479), Image(48) COLOR Clr: LOCATE 30, 30: PRINT "Scanning..."; ELSEIF Scr = 13 THEN IF ScanWidth& > 320 THEN ScanWidth& = 320 IF ScanDepth& > 200 THEN ScanDepth& = 200 GET (112, 190)-(248, 199), Image(768) COLOR Clr: LOCATE 25, 15: PRINT "Scanning..."; END IF FOR yy = 0 TO ScanDepth& - 1 FOR xx = 0 TO ScanWidth& - 1 Changed(POINT(xx, yy)) = 1 NEXT NEXT IF Scr = 12 THEN LOCATE 30, 30: PRINT "Press B to BSAVE!"; IF Scr = 13 THEN LOCATE 25, 15: PRINT "Press B to BSAVE!";
END SUB
SUB Show15 FOR i = 1 TO 15 IF Scr = 12 THEN LOCATE 12 + i, 76 ELSE LOCATE 9 + i, 37 COLOR i: PRINT i; NEXT END SUB
SUB TrueColor 'screen 13*****************Color 24 bit
IF ((BMPHead.PWidth * 3) MOD 4) THEN ZeroPAD$ = SPACE$((4 - ((BMPHead.PWidth * 3) MOD 4)))
OUT &H3C8, 0 'Ildurest's color palette FOR i = 0 TO 251 OUT &H3C9, (i MOD 6) * 63 \ 5 OUT &H3C9, ((i \ 36) MOD 7) * 63 \ 6 OUT &H3C9, ((i \ 6) MOD 6) * 63 \ 5 NEXT
y = BMPHead.PDepth - 1
o$ = " " GET #1, BMPHead.Offset, o$
a$ = " " B$ = " " c$ = " "
DO x = 0
DO GET #1, , a$ GET #1, , B$ GET #1, , c$ a = ASC(a$) B = ASC(B$) c = ASC(c$) 'Ildurest's formulas
'OPTION 1 FORMULA: Light colors REM d = c * 5 \ 255 + (b * 6 \ 255) * 36 + (a * 5 \ 255) * 6
SUB TrueGrey 'screen 12 or 13 ****** greyscale 24 bit Bob's Winbit
IF ((BMPHead.PWidth * 3) MOD 4) THEN ZeroPAD$ = SPACE$((4 - ((BMPHead.PWidth * 3) MOD 4)))
IF Scr = 13 THEN FOR Colr = 0 TO 255 STEP 4 FOR Reps = 0 TO 3 OUT &H3C8, Colr + Reps OUT &H3C9, n OUT &H3C9, n OUT &H3C9, n NEXT Reps n = n + 1 NEXT Colr div = 3 ELSEIF Scr = 12 THEN n = 3 FOR Colr = 0 TO 15 OUT &H3C8, Colr OUT &H3C9, n OUT &H3C9, n OUT &H3C9, n n = n + 4 NEXT Colr div = 48 END IF
y = BMPHead.PDepth - 1
o$ = " " GET #1, BMPHead.Offset, o$
a$ = " " B$ = " " c$ = " "
DO: x = 0 DO GET #1, , a$ GET #1, , B$ GET #1, , c$ a = ASC(a$) B = ASC(B$) c = ASC(c$) d = (a + B + c) \ div
PSET (x, y), d x = x + 1
LOOP WHILE x < BMPHead.PWidth
GET #1, , ZeroPAD$ y = y - 1
LOOP UNTIL y = -1
END SUB
'Added a "Press B to BSAVE" when Color Scanning is done. Removed BEEP.
I used the exact same two bitmaps I'd been testing with -- one requiring only one file, the second, three. They both worked great!
Only suggestion is that when you put your saved line with a multiple file BSAVE, it should say, for example: "Saved to 3 files: Image1.BSV, Image2.BSV, Image3.BSV". I just got "Saved as Image3.BSV". Naturally I understood the message, but someone not familiar with the program might not.
I can probably add the list of filenames also. I made a BLOADANY program that automatically looks for the numbers 1, 2 and/or 3 in 12 and 5 and 6 in 13, so I never had a problem. It can also BLOAD your XMSTREE1, 2, and 3 after you enter the 12 screen mode. You can select to load all 3 or just the file name you typed in. It also works with any extension you request.
There is always room for improvements! Thus programmers never "finish" a program. Did you notice my TrueGrey SUB? I adapted it from your old TrueColor SUB to use either 12 or 13 modes. I used Ildurests coloring trick in the new TrueColor SUB. I had a lot of trial and error to do adapting these programs from Winbit. Another problem I might have to address is using a filename extension for 12 or 13 BSV files, as they can overwrite each other presently. I gotta mull that over........
Use a Bitmap or Picture Editing program to set the bitmap's palette to 1 BPP. Edit the bitmap height to 42% of original keeping the width at 100%. Then load it using this program. Do NOT type the .BMP extension for the Bitmap file name entry. The program will add that.
DEFINT A-Z DECLARE SUB OneBIT () DECLARE SUB GetInfo () DECLARE SUB Closing (clr) DECLARE SUB MakeData () DECLARE SUB ReadData () DECLARE SUB BSaveOne () DECLARE SUB Border (clr)
TYPE BMPHeaderType 'BITMAP HEADER TYPE ID AS STRING * 2 'File ID is "BM" Size AS LONG 'Size of the data file Res1 AS INTEGER 'Reserved 1 should be 0 Res2 AS INTEGER 'Reserved 2 should be 0 Offset AS LONG 'Position of start of pixel data Hsize AS LONG 'Information header size PWidth AS LONG 'Image width PDepth AS LONG 'Image height Planes AS INTEGER 'number of planes BPP AS INTEGER 'Bits per pixel, 8 for Screen 13, 256 color image Compress AS LONG 'Compression ImageBytes AS LONG 'Width * Height ,ImageSIZE Xres AS LONG 'Width in PELS per metre Yres AS LONG 'depth in PELS per metre NumColors AS LONG 'Number of COLORS SigColors AS LONG 'Significant COLORs END TYPE
DIM SHARED BMPHead AS BMPHeaderType DIM SHARED Image(10000) DIM SHARED FileName$, SaveName$, FileErr
'MAIN PROGRAM ON ERROR GOTO Handler
SCREEN 12 GetInfo OneBIT 'Screen 12 MakeData COLOR 11: LOCATE 29, 20: PRINT "Screen 12 Monochrome Data Saved! Press any Key"; DO: SLEEP: LOOP UNTIL INKEY$ <> "" CLS : SCREEN 2 'Screen 2 monochrome ReadData BSaveOne LOCATE 25, 25: PRINT "BSAVED as "; UCASE$(FileName$); ".BS2 in Screen 2." DO: SLEEP: LOOP UNTIL INKEY$ <> "" Closing 11 'END PROGRAM
Handler: 'check if file entry error or other error BEEP FileErr = -1 RESUME NEXT
SUB Border (clr) COLOR clr FOR row = 1 TO 30 LOCATE row, 1: PRINT CHR$(179); LOCATE row, 80: PRINT CHR$(179); NEXT row FOR col = 1 TO 80 LOCATE 1, col: PRINT CHR$(196); LOCATE 30, col: PRINT CHR$(196); NEXT col LOCATE 1, 1: PRINT CHR$(218); LOCATE 1, 80: PRINT CHR$(191); LOCATE 30, 1: PRINT CHR$(192); LOCATE 30, 80: PRINT CHR$(217); END SUB
SUB BSaveOne 'Screen 2 SaveName$ = FileName$ + ".BS2" DEF SEG = VARSEG(Image(0)) GET (0, 0)-(BMPHead.PWidth - 1, BMPHead.PDepth - 1), Image(0) 'NOT indexed LINE (0, 0)-(BMPHead.PWidth, BMPHead.PDepth), 0, B
FOR a& = 10000 TO 0 STEP -1 IF Image(a&) THEN ArraySize& = a&: EXIT FOR NEXT BSAVE SaveName$, VARPTR(Image(0)), (2 * ArraySize&) + 200 'FileSize DEF SEG END SUB
SUB Closing (clr) SCREEN 12: CLS Border clr LOCATE 15, 30: PRINT "Ted Weissgerber 2008" LOCATE 17, 30: PRINT "burger2227@gmail.com" SLEEP 3 SYSTEM END SUB
SUB GetInfo
CLS : COLOR 11 FILES "*.bmp" SOUND 700, 3 COLOR 14: INPUT " Enter First part of a file name (Enter Quits): ", FileName$ CLS IF LEN(FileName$) > 0 AND LEN(FileName$) < 9 THEN '1 to 8 character name OpenName$ = UCASE$(FileName$) + ".BMP" OPEN OpenName$ FOR INPUT AS #1 'check if file exists CLOSE #1 ELSE : COLOR 12: LOCATE 15, 31: PRINT "Invalid File Name!": SLEEP: Closing 11 END IF
IF FileErr = 0 THEN 'check for file exist error OPEN OpenName$ FOR BINARY AS #1 ELSE : COLOR 12: LOCATE 15, 33: PRINT "File Not Found!": SLEEP: Closing 11 END IF GET #1, , BMPHead IF BMPHead.ID <> "BM" THEN COLOR 12: LOCATE 15, 30: PRINT "File is Not a bitmap!": SLEEP 3: Closing 11 Border 11 COLOR 11: LOCATE 2, 20: PRINT "Bitmap Header Information for "; UCASE$(FileName$); ".BMP" COLOR 14 LOCATE 4, 20: PRINT "File Type ID = "; BMPHead.ID LOCATE 5, 20: PRINT "Data file Size ="; BMPHead.Size LOCATE 6, 20: PRINT "Offset of Pixel Data ="; BMPHead.Offset LOCATE 7, 20: PRINT "Header Size ="; BMPHead.Hsize LOCATE 8, 20: PRINT "Picture Width ="; BMPHead.PWidth LOCATE 9, 20: PRINT "Picture Depth ="; BMPHead.PDepth LOCATE 10, 20: PRINT "Number of Planes ="; BMPHead.Planes LOCATE 11, 20: PRINT "Bits Per Pixel ="; BMPHead.BPP; " (1, 4, 8 or 24 bit)" LOCATE 12, 20: PRINT "Compression ="; BMPHead.Compress; " (0 = not compressed)" LOCATE 13, 20: PRINT "Image Byte Size ="; BMPHead.ImageBytes LOCATE 14, 20: PRINT "Width in PELS ="; BMPHead.Xres LOCATE 15, 20: PRINT "Depth in PELs ="; BMPHead.Yres LOCATE 16, 20: PRINT "Number of COLORS ="; BMPHead.NumColors; " (normally 0) " LOCATE 17, 20: PRINT "Significant Colors ="; BMPHead.SigColors; " (normally 0)"
IF BMPHead.BPP <> 1 THEN CLS : COLOR 12: LOCATE 15, 25: PRINT "File Must be saved as One Bit Color!": SLEEP 3: Closing 11 IF BMPHead.PDepth > 200 OR BMPHead.PWidth > 640 THEN CLS : COLOR 12: LOCATE 15, 30: PRINT "Bitmap over 640 X 200!": SLEEP 3: Closing 11 COLOR 11: LOCATE 29, 30: PRINT " Press any Key!"; DO: SLEEP: LOOP UNTIL INKEY$ <> "" CLS END SUB
SUB MakeData DIM xx AS LONG, yy AS LONG OPEN "B&WData.DAT" FOR OUTPUT AS #3 'pixel data file Screen 12 FOR xx = 0 TO BMPHead.PWidth FOR yy = 0 TO BMPHead.PDepth Colr = POINT(xx, yy) IF Colr <> 0 THEN Colr = 1 ELSE Colr = 0 WRITE #3, Colr NEXT yy NEXT xx CLOSE #3 END SUB
SUB OneBIT '********* Black and White from Winbit BitsOver = BMPHead.PWidth MOD 32 IF BitsOver THEN ZeroPAD$ = SPACE$((32 - BitsOver) \ 8)
y = BMPHead.PDepth - 1 o$ = " " GET #1, BMPHead.Offset, o$ a$ = " "
DO x = 0 DO GET #1, , a$ CharVAL = ASC(a$) Bit = 128 FOR BitCOUNT = 1 TO 8 IF CharVAL AND Bit THEN PSET (x, y), 15 ELSE PSET (x, y), 0 Bit = Bit / 2 x = x + 1 NEXT BitCOUNT LOOP WHILE x < BMPHead.PWidth GET #1, , ZeroPAD$ y = y - 1 LOOP UNTIL y = -1 END SUB
SUB ReadData DIM xx AS LONG, yy AS LONG OPEN "B&WData.DAT" FOR INPUT AS #4 'convert data to Screen 2 FOR xx = 0 TO BMPHead.PWidth FOR yy = 0 TO BMPHead.PDepth INPUT #4, Colr PSET (xx, yy), Colr NEXT yy NEXT xx CLOSE #4
KILL "B&WData.DAT" 'optional delete of data file END SUB
Ted
This message has been edited by burger2227 on Jul 22, 2008 6:40 PM This message has been edited by burger2227 on Jul 22, 2008 6:39 PM This message has been edited by burger2227 on Jul 20, 2008 2:12 PM
I just tried it with a small 100x80 pix. graphic and despite the result looks a bit strange on my CTR monitor (a bit scattered, on certain borders), the look at the CGA screen from the palmtop is absolutely perfect :) And foremost it is fast (bload), much faster than the font routine i tried this afternoon :) A great step toward a fine reader. Thanks a lot !
You can also try Bitmap BSAVEs directly in Screen 2 (Code)
July 20 2008, 3:50 PM
'BSAVE2.bas July, 2008. By Ted Weissgerber 'Enter Bitmap File name withOUT the .BMP extension. 'Screen 2 is limited to 640 widths and 200 depths. Squash vertical depth by 42%. 'Width 100%. Set the bitmap palette to 1 BPP for Black and White monochrome ONLY! 'BSAVE file will use bitmap name with the .B2S extension. You can save up to 'fullscreen to one BSAVE file with sizes up to 640 X 200 bitmaps. 'Do NOT exceed that size or an error will close the program!
DEFINT A-Z
DECLARE SUB Border () DECLARE SUB GetInfo () DECLARE SUB OneBIT () DECLARE SUB BSaveOne () DECLARE SUB Closing ()
TYPE BMPHeaderType 'BITMAP HEADER TYPE ID AS STRING * 2 'File ID is "BM" Size AS LONG 'Size of the data file Res1 AS INTEGER 'Reserved 1 should be 0 Res2 AS INTEGER 'Reserved 2 should be 0 Offset AS LONG 'Position of start of pixel data Hsize AS LONG 'Information header size PWidth AS LONG 'Image width PDepth AS LONG 'Image height Planes AS INTEGER 'number of planes BPP AS INTEGER 'Bits per pixel, 8 for Screen 13, 256 color image Compress AS LONG 'Compression ImageBytes AS LONG 'Width * Height ,ImageSIZE Xres AS LONG 'Width in PELS per metre Yres AS LONG 'depth in PELS per metre NumColors AS LONG 'Number of COLORS SigColors AS LONG 'Significant COLORs END TYPE
DIM SHARED BMPHead AS BMPHeaderType DIM SHARED Image(0 TO 10000) DIM SHARED FileName$, SaveName$, FileErr
ON ERROR GOTO Handler
SCREEN 2 'Main PROGRAM GetInfo OneBIT LOCATE 25, 30: PRINT "BSAVE image? (Y/N)"; DO: K$ = UCASE$(INKEY$): LOOP UNTIL K$ = "Y" OR K$ = "N" IF K$ = "Y" THEN BSaveOne LOCATE 25, 25: PRINT "Image BSAVED AS: "; SaveName$; DO: SLEEP: LOOP UNTIL INKEY$ <> "" Closing ELSE : Closing END IF 'END Program
Handler: 'check if file entry error or other error BEEP FileErr = -1 RESUME NEXT
SUB Border FOR row = 1 TO 25 LOCATE row, 1: PRINT CHR$(179); LOCATE row, 80: PRINT CHR$(179); NEXT row FOR col = 1 TO 80 LOCATE 1, col: PRINT CHR$(196); LOCATE 25, col: PRINT CHR$(196); NEXT col LOCATE 1, 1: PRINT CHR$(218); LOCATE 1, 80: PRINT CHR$(191); LOCATE 25, 1: PRINT CHR$(192); LOCATE 25, 80: PRINT CHR$(217); END SUB
SUB BSaveOne 'Screen 2 SaveName$ = FileName$ + ".B2S" DEF SEG = VARSEG(Image(0)) GET (0, 0)-(BMPHead.PWidth - 1, BMPHead.PDepth - 1), Image(0) 'NOT indexed LINE (0, 0)-(BMPHead.PWidth, BMPHead.PDepth), 0, B
FOR a& = 10000 TO 0 STEP -1 IF Image(a&) THEN ArraySize& = a&: EXIT FOR NEXT BSAVE SaveName$, VARPTR(Image(0)), (2 * ArraySize&) + 200 'FileSize DEF SEG END SUB
SUB Closing CLS Border LOCATE 13, 30: PRINT "Ted Weissgerber 2008" LOCATE 14, 30: PRINT "burger2227@gmail.com" SLEEP 3 SYSTEM END SUB
SUB GetInfo CLS FILES "*.bmp" SOUND 700, 3 INPUT " Enter First part of a file name (Enter Quits): ", FileName$ CLS IF LEN(FileName$) > 0 AND LEN(FileName$) < 9 THEN '1 to 8 character name OpenName$ = UCASE$(FileName$) + ".BMP" OPEN OpenName$ FOR INPUT AS #1 'check if file exists CLOSE #1 ELSE : LOCATE 15, 31: PRINT "Invalid File Name!": SLEEP 3: Closing END IF
IF FileErr = 0 THEN 'check for file exist error OPEN OpenName$ FOR BINARY AS #1 ELSE : LOCATE 15, 33: PRINT "File Not Found!": SLEEP 3: Closing END IF GET #1, , BMPHead IF BMPHead.ID <> "BM" THEN LOCATE 15, 30: PRINT "File is Not a bitmap!": SLEEP 3: Closing
IF BMPHead.BPP <> 1 THEN CLS : LOCATE 13, 25: PRINT "File Must be saved as One Bit Color!": SLEEP 3: Closing IF BMPHead.PDepth > 200 OR BMPHead.PWidth > 640 THEN CLS : LOCATE 13, 30: PRINT "Bitmap over 640 X 200!": SLEEP 3: Closing LOCATE 24, 30: PRINT " Press any Key!"; DO: SLEEP: LOOP UNTIL INKEY$ <> "" CLS END SUB
SUB OneBIT 'Black and White 1 BPP Screens 2, 11, 12, 13 ' from Winbit BitsOver = BMPHead.PWidth MOD 32 IF BitsOver THEN ZeroPAD$ = SPACE$((32 - BitsOver) \ 8)
y = BMPHead.PDepth - 1 o$ = " " GET #1, BMPHead.Offset, o$ a$ = " "
DO x = 0 DO GET #1, , a$ CharVAL = ASC(a$) Bit = 128 FOR BitCOUNT = 1 TO 8 IF CharVAL AND Bit THEN PSET (x, y), 15 ELSE PSET (x, y), 0 Bit = Bit / 2 x = x + 1 NEXT BitCOUNT LOOP WHILE x < BMPHead.PWidth GET #1, , ZeroPAD$ y = y - 1 LOOP UNTIL y = -1
END SUB
This message has been edited by burger2227 on Jul 22, 2008 6:42 PM This message has been edited by burger2227 on Jul 22, 2008 6:34 PM This message has been edited by burger2227 on Jul 21, 2008 1:47 AM
'BLOADANY.BAS loads bitmap BSAVE files saved in BSAVER (BSV) or BMPCOLOR.(BCS) 'or any other file extension you wish to use. Just change the file extension 'used.BLOADANY will ask for a 3 letter file extension and list the current 'ones available. ' ' AUTO SCREEN MODE DETECTION 'It detects the Screen Mode used as 12 or 13 only. It does this by checking 'the Bsave File that you enter for the number of color settings at the start 'of the file. If there are no color settings found, the QB Default palette is 'used with the Bload procedure. 'Also the program will prompt you for a screen mode if it cannot be determined. ' ' Automatically finds number of Files Needed 'The BSAVER program creates numbered files if it cannot create just one file. 'SCREEN 12 files may use numbers 1, 2, and 3. SCREEN 13 may use 5 and 6 only. 'This program looks for those file numbers in a file name you enter and will 'load all three if found or just two if necessary. If no other files are 'found, it just loads the file you requested. All file entries are checked to 'make sure they Exist! Single Files may use the .B12 or .B13 file extensions 'created by BSAVER program. This allows saves in either screen mode ' ' Bsaved files not properly formatted and saved may not load at all! ' ' Ted Weissgerber, 2008, Burger2227@Gmail.com '
DEFINT A-Z DECLARE SUB CheckNumFiles () DECLARE SUB AutoClr (Clr) DECLARE SUB CheckScreen () DECLARE SUB BloadOne () DECLARE SUB Bloader () DECLARE SUB GetNumColors (Colors(), NColors) DECLARE SUB Closing () DECLARE SUB Border (Colr)
DIM SHARED Image(27000) 'graphics array holds BSV information DIM Colors(0 TO 255) 'holds colors used by picture DIM SHARED file$, Filename$, Scr, NumF, Ext$, NoExist, MaxColors, PWidth, PDepth, NColors ON ERROR GOTO Handler 'BEGIN PROGRAM SCREEN 12 Border 11 COLOR 11: LOCATE 2, 20: PRINT "BLOADANY: BSAVE IMAGE FILE LOADER" COLOR 10: LOCATE 5, 5: PRINT "This program loads bitmaps saved with color settings indexed or with the" LOCATE 6, 5: PRINT "QB default colors only. Finds sequencially numbered files for large BMPs" LOCATE 7, 5: PRINT "in Screen 12 (numbered 1 to 3) or Screen 13 (numbered 5 and 6) if needed." COLOR 13: LOCATE 9, 5: PRINT " When entering a file name, the program will add the extension!" SOUND 700, 4: COLOR 14 LOCATE 15, 10: INPUT "Enter 3 letter file type Extension(no dot) to search: ", Ext$ IF LEN(Ext$) <> 3 OR LEFT$(Ext$, 1) = "." THEN Closing: SYSTEM Ext$ = UCASE$(Ext$)
PALETTE: COLOR 11 FILES "* ." + Ext$ SOUND 700, 3 COLOR 14: INPUT " Enter file first name from above (Enter Quits): ", file$ IF LEN(file$) < 1 OR LEN(file$) > 8 OR RIGHT$(file$, 1) = "." THEN Closing: SYSTEM
CheckNumFiles 'check if filename exists and if other ones found
IF NumF = 0 THEN CLS COLOR 12: LOCATE 15, 24: PRINT "The Entered filename does NOT exist!" SLEEP 2: GOTO 100 END IF
CLS : Border 11
CheckScreen 'find screen mode and number of colors in BSAVE file IF Scr = 0 THEN GOTO 100
IF NumF > 1 THEN COLOR 11: LOCATE 20, 12: PRINT "Found"; NumF; "sequencially numbered files using Screen Mode"; Scr COLOR 14: LOCATE 25, 26: PRINT "Open "; Filename$; " only? (Y/N): "; DO: only$ = UCASE$(INKEY$): LOOP UNTIL only$ = "Y" OR only$ = "N" PRINT only$ IF only$ = "Y" THEN NumF = 1 ELSE : COLOR 11: LOCATE 15, 18: PRINT "Found that "; Filename$; " exists using Sreen Mode"; Scr NumF = 1 END IF COLOR 13: LOCATE 29, 35: PRINT "Press any Key!"; DO: SLEEP: LOOP UNTIL INKEY$ <> ""
IF NumF = 1 THEN BloadOne ELSEIF NumF > 1 THEN Bloader ELSE : SYSTEM END IF
AutoClr Clr 'find a viewable color
GetNumColors Colors(), NColors
DO: LOOP UNTIL INKEY$ = "" DO: a$ = INKEY$: SLEEP 1: LOOP UNTIL a$ <> ""
COLOR Clr IF Scr = 12 THEN LOCATE 30, 35 ELSE LOCATE 25, 3 PRINT Filename$; IF Scr = 12 THEN LOCATE 30, 55 ELSE LOCATE 25, 16 PRINT PWidth; "X"; PDepth; PRINT " Colors:"; NColors;
FOR i = 0 TO 15 IF Scr = 12 THEN COLOR i: LOCATE i + 14, 77: PRINT i; IF Scr = 13 THEN COLOR i: LOCATE i + 8, 37: PRINT i; NEXT
DO: LOOP UNTIL INKEY$ = "" DO: a$ = INKEY$: SLEEP 1: LOOP UNTIL a$ <> ""
ERASE Image ERASE Colors LOOP UNTIL a$ = CHR$(27)
SYSTEM 'END PROGRAM
Handler: 'simple error handler for bad file names 'BEEP 'optional error sound NoExist = -1 RESUME NEXT
SUB AutoClr (Clr)
IF MaxColors = 0 THEN Clr = 11: EXIT SUB FOR i = 3 TO (3 * MaxColors) - 1 STEP 3 'set a viewable color totval = Image(i) + Image(i + 1) + Image(i + 2) IF totval > 90 AND totval <> Image(0) + Image(1) + Image(2) THEN Clr = i \ 3: EXIT FOR NEXT
END SUB
SUB Bloader 'BLOADS Screen 12 or 13 BSAVEd files
CLS : SCREEN Scr: PDepth = 0 file$ = MID$(file$, 1, LEN(file$) - 1): y = 0 IF Scr = 12 THEN spot = 160 ELSE adder = 4: spot = 100 DEF SEG = VARSEG(Image(0)) FOR n = 1 TO NumF LFile$ = file$ + LTRIM$(STR$(n + adder)) + "." + Ext$ 'numbered 1,2,3 or 5, 6 in 13 BLOAD LFile$, VARPTR(Image(0)) PUT (0, y), Image(MaxColors * 3), PSET ' Put the drawing on the screen. IF Scr = 12 THEN PWidth = Image(3 * MaxColors) ELSE PWidth = Image(3 * MaxColors) \ 8 PDepth = PDepth + Image((3 * MaxColors) + 1) 'add each depth used IF MaxColors > 0 THEN OUT &H3C8, 0 ' set attribute port to 0 FOR c = 0 TO (MaxColors * 3) - 1 ' colors 0 to 15 or 255 OUT &H3C9, Image(c) ' set palette from array NEXT c END IF y = y + spot 'advance 160 or 100 each loop NEXT n DEF SEG ' Restore default BASIC segment.
END SUB
SUB BloadOne CLS : SCREEN Scr DEF SEG = VARSEG(Image(0)) BLOAD Filename$, VARPTR(Image(0)) PUT (0, 0), Image(MaxColors * 3), PSET ' Put the drawing on the screen. IF Scr = 12 THEN PWidth = Image(3 * MaxColors) ELSE PWidth = Image(3 * MaxColors) \ 8 PDepth = Image((3 * MaxColors) + 1) IF MaxColors > 0 THEN OUT &H3C8, 0 ' set attribute port to 0 FOR c = 0 TO (MaxColors * 3) - 1 ' colors 0 to 15 or 255 OUT &H3C9, Image(c) ' set palette from array NEXT c END IF DEF SEG ' Restore default BASIC segment. END SUB
SUB Border (Colr) COLOR Colr FOR row = 1 TO 30 LOCATE row, 1: PRINT CHR$(186); 'CHR$(179); LOCATE row, 80: PRINT CHR$(186); 'CHR$(179); NEXT row FOR col = 1 TO 80 LOCATE 1, col: PRINT CHR$(205); 'CHR$(196); LOCATE 30, col: PRINT CHR$(205); 'CHR$(196); NEXT col LOCATE 1, 1: PRINT CHR$(201); 'CHR$(218); LOCATE 1, 80: PRINT CHR$(187); 'CHR$(191); LOCATE 30, 1: PRINT CHR$(200); 'CHR$(192); LOCATE 30, 80: PRINT CHR$(188); 'CHR$(217); END SUB
SUB CheckNumFiles 'Finds how many existing sequencial numbered files to load together. 2 or 3 BSV files. 'My BSAVER and BMPCOLOR Routines use 1, 2, 3 for Screen 12. 5 & 6 for 13 in BSAVER 'only if the BSAVE size is too large for one file to be made. NumF = 0: NoExist = 0
OPEN Filename$ FOR INPUT AS #1 'check if file name entered exists CLOSE #1 IF NoExist THEN NoExist = 0: EXIT SUB
IF LastNum >= 1 AND LastNum <= 3 THEN 'test for files ending 1, 2 and 3 in Screen 12 FOR NF = 1 TO 3 OPEN ChkFile$ + LTRIM$(STR$(NF)) + "." + Ext$ FOR INPUT AS #1 CLOSE #1 IF NoExist = 0 THEN NumF = NumF + 1 ELSE NoExist = 0 NEXT ELSEIF LastNum = 5 OR LastNum = 6 THEN 'test for files ending 5 and 6 in screen mode 13 FOR NF = 5 TO 6 OPEN ChkFile$ + LTRIM$(STR$(NF)) + "." + Ext$ FOR INPUT AS #1 CLOSE #1 IF NoExist = 0 THEN NumF = NumF + 1 ELSE NoExist = 0 NEXT END IF CLS
IF NumF = 0 THEN NumF = 1
END SUB
SUB CheckScreen 'find Screen mode used 12 or 13 and bitmap dimensions DIM Bsv AS STRING * 1 DIM Header AS STRING * 6
Scr = 0: MaxColors = 0 OPEN Filename$ FOR BINARY AS #1
GET #1, , Bsv '1 check for small 2 character GET #1, , Header '2 - 7 rest of file header
IF Bsv <> CHR$(253) THEN COLOR 12: LOCATE 15, 33: PRINT "Not a BSAVE file!": SLEEP 3: EXIT SUB END IF
GET #1, , widN '8 no color info bmp sizes GET #1, , depN '9 " " "
DO IF widN > 63 OR depN > 63 THEN EXIT DO
FOR i = 10 TO 55 'check for Screen 12 embedded colors GET #1, , RGB tot12& = tot12& + RGB 'PRINT i; RGB; : SOUND 300, 1 'test IF RGB > 63 OR RGB < 0 THEN EXIT DO IF i = 55 AND tot12& = 0 THEN EXIT DO NEXT
GET #1, , wid12 '56 GET #1, , dep12 '57 IF wid12 > 63 OR dep12 > 63 THEN EXIT DO
FOR i = 58 TO 775 'check for Screen 13 embedded colors GET #1, , RGB tot13& = tot13& + RGB 'PRINT i; RGB; : SOUND 300, 1 'test IF RGB > 63 OR RGB < 0 THEN EXIT DO IF i = 775 AND tot13& = 0 THEN EXIT DO NEXT GET #1, , wid13 '776 GET #1, , dep13 '777 LOOP UNTIL 1 = 1 CLOSE #1
COLOR 14: LOCATE 10, 25 SELECT CASE i CASE IS < 56: IF widN > 640 THEN Scr = 13: MaxColors = 0 PRINT "Default Screen 13:"; widN \ 8; "X"; depN ELSE LOCATE 10, 15: PRINT "Default Screen 12 ("; widN; "X"; depN; ") or 13 ("; widN \ 8; "X"; depN; ")" 'ask user for scr value DO: SOUND 600, 4 COLOR 13: LOCATE 12, 23: INPUT "Enter a Screen mode 12 or 13 : ", Scrn$ 'ask if no data found NO ERROR Scr = VAL(Scrn$) LOOP UNTIL Scr = 12 OR Scr = 13 END IF IF Scr = 12 THEN MaxColors = 0: PWidth = widN: PDepth = depN IF Scr = 13 THEN MaxColors = 0: PWidth = widN \ 8: PDepth = depN CASE 56 TO 775 PRINT "Custom Screen 12:"; wid12; "X"; dep12 Scr = 12: MaxColors = 16: PWidth = wid12: PDepth = dep12 CASE 776: PRINT "Custom Screen 13:"; wid13 \ 8; "X"; dep13 Scr = 13: MaxColors = 256: PWidth = wid13 \ 8: PDepth = dep13 END SELECT
END SUB
SUB Closing CLS : Border 13 COLOR 11: LOCATE 15, 30: PRINT "Ted Weissgerber 2008" LOCATE 17, 30: PRINT "burger2227@gmail.com" SLEEP 3 END SUB
SUB GetNumColors (Colors(), NColors) 'finds number of colors used in image with Point NColors = 0 IF Scr = 12 AND PDepth > 480 THEN PDepth = 480 IF Scr = 13 AND PDepth > 200 THEN PDepth = 200 FOR x = 0 TO PWidth - 1 'find how many colors are used with Point FOR y = 0 TO PDepth - 1 Colors(POINT(x, y)) = 1 NEXT y NEXT x FOR i = 0 TO 255 IF Colors(i) = 1 THEN NColors = NColors + 1 'add total colors used in Image NEXT END SUB
'Ted
This message has been edited by burger2227 on Aug 2, 2008 12:54 PM This message has been edited by burger2227 on Aug 1, 2008 8:50 PM
Fake Qbasic IDE with ASCII graphic character overlays
March 23 2009, 3:37 PM
DEFINT A-Z
DECLARE SUB QBIDE ()
DECLARE SUB TextSave ()
DECLARE SUB SetText (Tclr, Trow, Tcol, Text$)
DECLARE SUB Align (Tclr, Trow, Txt$)
DECLARE SUB BGround ()
DIM SHARED S(24 TO 122, 0 TO 15) AS STRING * 1
SCREEN 12 'NOTE: Sub programs set up for 8 X 16 Text characters!
BGround 'set RGB values for background color(see SUB)
'MAIN PROGRAM code here avoiding the IDE borders, hopefully.
QBIDE
DO: SLEEP: LOOP UNTIL INKEY$ <> ""
'END of PROGRAM CODE
SYSTEM
SUB Align (Tclr, Trow, Txt$)
Tcol = 41 - (LEN(Txt$) \ 2)
COLOR Tclr: LOCATE Trow, Tcol: PRINT Txt$;
END SUB
SUB BGround
'change to desired background hue
OUT &H3C8, 0 'set 0 color attribute to change
OUT &H3C9, 0 'set red (each 0 to 63 only)
OUT &H3C9, 0 'set green
OUT &H3C9, 30 'set blue
END SUB
SUB QBIDE
'Simulated Qbasic IDE can be used in any program - Ted Weissgerber
'Requires 3 other SUB procedures: TextSave, SetText, and Align plus String Array S as SHARED
OUT &H3C8, 7: OUT &H3C9, 50: OUT &H3C9, 50: OUT &H3C9, 50 'custom white color 7 borders
OUT &H3C9, 0: OUT &H3C9, 0: OUT &H3C9, 0 'custom black color 8 setting
TextSave 'Set ASCII character array. S holds row byte values (uses attrib 8 = black)
COLOR 7
FOR Row = 3 TO 30 'border
LOCATE Row, 1: PRINT CHR$(179);
LOCATE Row, 80: PRINT CHR$(179);
NEXT
LOCATE 1, 1: PRINT STRING$(80, 219); 'Menu
LOCATE 2, 1: PRINT STRING$(75, 196); CHR$(180); CHR$(219); CHR$(195); CHR$(196); 'top line border
LOCATE 30, 1: PRINT STRING$(80, 196); 'bottom line border
LOCATE 2, 1: PRINT CHR$(218); 'border line corners
LOCATE 2, 80: PRINT CHR$(191);
LOCATE 30, 1: PRINT CHR$(192);
LOCATE 30, 80: PRINT CHR$(217);
LOCATE 3, 80: PRINT CHR$(219); 'vertical scroll top arrow box
FOR Row = 4 TO 23
LOCATE Row, 80: PRINT CHR$(178);
NEXT
LOCATE 24, 80: PRINT CHR$(219) 'vertical scroll bottom arrow box
LOCATE 25, 2: PRINT CHR$(219); STRING$(76, 178); CHR$(219); 'horizontal scroll bar
LOCATE 26, 2: PRINT STRING$(78, 196);
Align 7, 26, " Immediate "
COLOR 8
LOCATE 4, 80: PRINT CHR$(178); 'side scrollbar marker
LOCATE 25, 3: PRINT CHR$(178); 'bottom scrollbar marker
menu$ = SPACE$(3) + "File" + SPACE$(2) + "Edit" + SPACE$(2) + "View" + SPACE$(2) + "Search" + SPACE$(2) + "Run" + SPACE$(2) + "Debug" + SPACE$(2) + "Calls" + SPACE$(2) + "Options" + SPACE$(19) + "Help"
SetText 8, 1, 1, menu$
SetText 0, 2, 77, CHR$(24) 'Immediate setting arrow
SetText 8, 3, 80, CHR$(24) 'vertical scroll top arrow
SetText 8, 24, 80, CHR$(25) 'vertical scroll lower arrow
SetText 8, 25, 2, CHR$(27) 'horizontal scroll left arrow
SetText 8, 25, 79, CHR$(26) 'horizontal scroll right arrow
END SUB
SUB SetText (Tclr, Trow, Tcol, Text$) 'sets text foreground using graphics - no background
'NOTE: Set up for SCREEN 12's 8 X 16 character box dimensions ONLY!
Srow = 16 * (Trow - 1) 'convert from text to graphics coordinates
Scol = 8 * (Tcol - 1)
FOR i = 1 TO LEN(Text$) 'loop for length of text
temp$ = MID$(Text$, i, 1) 'get one character from Text$ string
FOR y = 0 TO 15 'graphic rows (16)
ybyte$ = S(ASC(temp$), y) 'string value from S array
yval = ASC(ybyte$) 'numerical value of S character value
FOR x = 0 TO 7 'columns (8) To enlarge use circles for PSET
IF (yval AND 2 ^ x) > 0 THEN PSET (Scol + x, Srow + y), Tclr
NEXT
NEXT
Scol = Scol + 8 'advance one character width to right
NEXT
END SUB
SUB TextSave 'bit packing routine. Courtesy of Ildurest!
'Sets up S Array with ASCII character row byte values to PSET pixels in SetText SUB
COLOR 8 'hide the character printing (8 set to black)
FOR i = 24 TO 122 'Draw map of each character needed(from 1 TO 255 possible)
IF i = 7 THEN i = 8 'eliminate beep character if used
LOCATE 1, 1: PRINT CHR$(i)
FOR y = 0 TO 15
A = 0
FOR x = 7 TO 0 STEP -1
A = A * 2 - (POINT(x, y) > 0) 'bit-packing with 2 ^ X%
NEXT
S(i, y) = CHR$(A)
NEXT
IF i < 32 OR i = 254 THEN LOCATE 1, 1: PRINT SPACE$(1) 'erase previous control characters
NEXT
END SUB
The TextSave and SetText SUB procedures can be used to allow placement of text without the annoying black background caused by PRINT. SetText converts the normal text row and column settings for you. Be sure to DIM the S string Array for the characters you need!
Ted
This message has been edited by burger2227 on Apr 22, 2009 10:48 PM This message has been edited by burger2227 on Apr 22, 2009 1:16 PM This message has been edited by burger2227 on Apr 22, 2009 1:12 PM This message has been edited by burger2227 on Apr 22, 2009 1:11 PM This message has been edited by burger2227 on Mar 23, 2009 4:21 PM This message has been edited by burger2227 on Mar 23, 2009 4:06 PM This message has been edited by burger2227 on Mar 23, 2009 3:41 PM
'Useful to place text without the black background you get when printing
'text. Any background can be used by not using the ELSE code in the PSET
'loop.
SCREEN 13 ' Text 40 X 25, Character box = 8 X 8
DIM SHARED S(0 TO 255, 0 TO 7) AS STRING * 1 'array holds 8 row byte values for each ASCII code.
FOR I = 0 TO 255 'Draw map of each character
IF I = 7 THEN I = 8 'eliminate beep character
LOCATE 1, 1: PRINT CHR$(I)
FOR y = 0 TO 7
a = 0
FOR x = 7 TO 0 STEP -1
a = a * 2 - (POINT(x, y) > 0) 'Just a bit of bit-packing
NEXT
S(I, y) = CHR$(a)
NEXT
LOCATE 1, 1: PRINT SPACE$(1)
NEXT
COLOR 11: LOCATE 2, 4: PRINT "Screen 13's 8 X 8 Text Characters"
COLOR 9: LOCATE 23, 2: PRINT "Enter typing keys to find those codes.";
LOCATE 24, 2: PRINT " Also Ctrl + letter and Alt + NumPad.";
char = 1
DO
row = 0
COLOR 10: LOCATE 10, 25: PRINT "Code ="; char; SPACE$(2)
COLOR 11: LOCATE 17, 10: PRINT "Array Row Byte Values"
LOCATE 19, 20: PRINT SPACE$(20)
COLOR 14: LOCATE 19, 1
FOR y = 50 TO 57 ' normal character overlay size
rowval = ASC(S(char, row))
col = 0
FOR x = 50 TO 57
IF (rowval AND 2 ^ col) THEN
PSET (x, y), 15
ELSE :
PSET (x, y), 4
END IF
col = col + 1
NEXT
row = row + 1
NEXT
row = 0
FOR yy = 50 TO 113 STEP 9 ' 9 times normal character size
rowval = ASC(S(char, row)) 'pixel row value
PRINT rowval;
col = 0
FOR xx = 100 TO 163 STEP 9
IF (rowval AND 2 ^ col) > 0 THEN
CIRCLE (xx, yy), 4, 11
PAINT STEP(0, 0), 11
ELSE :
CIRCLE (xx, yy), 4, 1
PAINT STEP(0, 0), 1
END IF
col = col + 1
NEXT
row = row + 1
NEXT
code$ = ""
DO: cd$ = INKEY$
IF cd$ > CHR$(47) AND cd$ < CHR$(58) THEN
code$ = code$ + cd$: char = VAL(code$)
IF LEN(code$) = 3 THEN ' quit if 3 digits entered
IF char < 1 OR char > 255 THEN char = 0
EXIT DO
END IF
ELSE : IF cd$ <> "" AND cd$ <> CHR$(13) THEN char = ASC(cd$): EXIT DO
END IF
IF cd$ = CHR$(13) THEN char = VAL(code$) ' less than 3 digits
LOCATE 21, 5: COLOR 10: PRINT "Enter ASCII code 1 to 255: "; char; SPACE$(2)
LOOP UNTIL cd$ = CHR$(13) 'enter quits entry
LOOP UNTIL char = 0 'enter alone or codes < 1 or > 255 quit program
SYSTEM
'For normal strings, use MID$ to get each character while spacing 8 pixels to the right
This message has been edited by burger2227 on May 27, 2009 11:45 PM This message has been edited by burger2227 on May 27, 2009 12:08 PM This message has been edited by burger2227 on May 27, 2009 11:30 AM This message has been edited by burger2227 on May 27, 2009 11:28 AM This message has been edited by burger2227 on May 27, 2009 11:25 AM
Piping current DOS DIR Path and filenames to string data.
July 20 2009, 10:51 PM
DEFINT A-Z
DECLARE FUNCTION Path$ ()
DECLARE SUB Align (Tclr, Trow, Txt$)
DECLARE SUB Border (clr)
SCREEN 12 '80 X 30 text. Adapt for other screen modes.
SHELL "DIR *.BAS /B > DOS-DATA.INF" '/B = pipe filenames only
OPEN "DOS-DATA.INF" FOR INPUT AS #1
IF LOF(1) THEN
CurPath$ = Path$
Fcount = 0 'number of files found
Border 13: Align 14, 1, CurPath$
COLOR 11: LOCATE 2, 2
DO WHILE NOT EOF(1)
Fcount = Fcount + 1
LINE INPUT #1, FileN$
PRINT FileN$; SPACE$(13 - LEN(FileN$)); 'max DOS filename length is 12
IF Fcount MOD 6 = 0 THEN PRINT "": LOCATE , 2 'new line
IF Fcount MOD 156 = 0 THEN 'next screen
COLOR 14: LOCATE 29, 27: INPUT ; "Enter filename or hit Enter: ", F$
IF LEN(F$) THEN EXIT DO
CLS : Border 13: Align 14, 1, CurPath$: COLOR 11: LOCATE 2, 2
END IF
LOOP
ELSE : COLOR 12: LOCATE 15, 33: PRINT "NO Files Found!": CLOSE #1: SYSTEM
END IF
CLOSE #1
COLOR 10: LOCATE 28, 30: PRINT "Total Files shown ="; Fcount
IF LEN(F$) = 0 THEN COLOR 14: LOCATE 29, 27: INPUT ; "Enter filename. Enter quits!: ", F$
SYSTEM
SUB Align (Tclr, Trow, Txt$) 'centers text prints
Tcol = 41 - (LEN(Txt$) \ 2)
COLOR Tclr: LOCATE Trow, Tcol: PRINT Txt$;
END SUB
SUB Border (clr%)
COLOR clr%
FOR Row = 1 TO 30
LOCATE Row, 1: PRINT CHR$(179);
LOCATE Row, 80: PRINT CHR$(179);
NEXT Row
FOR Col = 1 TO 80
LOCATE 1, Col: PRINT CHR$(196);
LOCATE 30, Col: PRINT CHR$(196);
NEXT Col
LOCATE 1, 1: PRINT CHR$(218);
LOCATE 1, 80: PRINT CHR$(191);
LOCATE 30, 1: PRINT CHR$(192);
LOCATE 30, 80: PRINT CHR$(217);
END SUB
FUNCTION Path$
'assign result to another string variable for later use in other folders!
SHELL "DIR *.BAS > DOS-DATA.INF" 'get all file & dir info
OPEN "DOS-DATA.INF" FOR INPUT AS #1 'we know file exists
DO WHILE NOT EOF(1) 'in case file is empty
LINE INPUT #1, line$
location = INSTR(1, line$, ":\") 'find the drive path notation
IF location THEN EXIT DO
LOOP
CLOSE #1
IF location THEN
line$ = MID$(line$, location - 1, LEN(line$) - location + 2)
Path$ = RTRIM$(line$) + "\" 'a QB useable directory path
ELSE : Path = "" 'returns zero length string if not found
END IF
END FUNCTION
Not only can you display the string data, but Qbasic can use the path and filename strings in OPEN and SHELL statements! Put all of the filenames in an array if you want.
Ted
This message has been edited by burger2227 on Jul 21, 2009 4:38 AM This message has been edited by burger2227 on Jul 20, 2009 11:08 PM
| = pipe -- first program's output becomes input into next program
> = redirect output to file
>> = redirect output to file, but append instead of overwriting
< = redirect input from file
________________________________________________
Edited by Solitaire. Negative comments removed.
This message has been edited by Solitaire1 on Jul 31, 2009 7:45 AM
Scanning a sprite and compressing to a CSV file or DATA field.
July 31 2009, 10:10 PM
The following SUB scans an image area with POINT and compesses repeated pixel attributes into count and color file data. Actually creates or appends to a file! See below for how to translate the data back to the screen later:
'If Dtype$ = "C" then it creates a CSV data file exactly like WRITE would do.
'If Dtype$ = "D" it will create a DATA field that can be placed directly into a BAS file.
'Be sure to enter the correct image coodinates and Dtype$ = "C" or "D"!
SUB CSVData (Filename$, Dtype$, MinX, MinY, MaxX, MaxY)
x = MinX '(default = 0)
y = MinY '(default = 0)
OPEN filename$ FOR APPEND AS #1 'DATA fields need append for BAS files.
IF Dtype$ = "D" THEN
PRINT #1, : PRINT #1, : PRINT #1, "' " + TIME$ + ": " + DATE$
PRINT #1, "NewData: 'use a DATA fieldname to RESTORE fieldname"
END IF
'place the 4 minimum and maximum image coordinates to first line of data if needed later.
IF Dtype$ = "D" THEN PRINT #1, "DATA ";
PRINT #1, "LTRIM$(STR$(MinX)) + "," + LTRIM$(STR$(MinY)) + "," + LTRIM$(STR$(MaxX)) + "," + LTRIM$(STR$(MaxY))
D = 0
DO: attr = POINT(x, y) ' scan image pixels
IF Patt = attr THEN
Count = Count + 1
ELSE
IF Count THEN 'delay first attribute data write one loop
IF D MOD 30 = 0 THEN
IF D THEN PRINT #1, "" 'moves to next print row
IF Dtype$ = "D" THEN PRINT #1, "DATA ";
PRINT #1, LTRIM$(STR$(Count)) + "," + LTRIM$(STR$(Patt));
ELSE PRINT #1, "," + LTRIM$(STR$(Count)) + "," + LTRIM$(STR$(Patt));
END IF
D = D + 2
END IF
Count = 1
END IF
Patt = attr 'previous attribute
IF x < MaxX THEN x = x + 1 ELSE x = MinX: y = y + 1
LOOP UNTIL y > MaxY
IF D MOD 30 = 0 THEN 'start a new data line every 30
PRINT #1, ""
IF Dtype$ = "D" THEN PRINT #1, "DATA ";
PRINT #1, LTRIM$(STR$(Count)) + "," + LTRIM$(STR$(Patt))
ELSE PRINT #1, "," + LTRIM$(STR$(Count)) + "," + LTRIM$(STR$(Patt))
END IF
IF Dtype$ = "D" THEN PRINT #1, ""
CLOSE #1
END SUB
The above code can also be adapted for using a smaller sized array.
Calculation of array size is at least half using xpixels * ypixels \ 2.
'------------------------------------------------------------------
'HOW TO READ the DATA: adapted from a routine by Bob Seguin
SUB ReadData (Dtype$) ' assumes file is opened as filenumber #1
IF Dtype$ = "D" THEN READ MinX, MinY, MaxX, MaxY 'if DATA field used
IF Dtype$ = "C" THEN INPUT #1, MinX, MinY, MaxX, MaxY 'if CSV file is used
'otherwise just use your own adjusted coordinates. MUST be same pixel sizes as original!
x = MinX
y = MinY
DO
IF Dtype$ = "D" THEN READ Count, Colr 'for a DATA field READ
IF Dtype = "C" THEN INPUT #1, Count, Colr'for a CSV file INPUT read
FOR reps = 1 TO Count
PSET (x, y), Colr
IF x < MaxX THEN x = x + 1 ELSE x = MinX: y = y + 1
NEXT reps
IF Dtype$ = "C" AND EOF(1) THEN EXIT DO
LOOP UNTIL y > MaxY
END SUB
'can also be adapted to read data from an array, 2 integers at a time such as Array(D) and Array(D + 1).
Ted
This message has been edited by burger2227 on Sep 8, 2009 2:50 PM This message has been edited by burger2227 on Sep 8, 2009 2:45 PM This message has been edited by burger2227 on Sep 8, 2009 2:41 PM This message has been edited by burger2227 on Aug 1, 2009 2:41 PM This message has been edited by burger2227 on Aug 1, 2009 11:56 AM This message has been edited by burger2227 on Aug 1, 2009 12:31 AM This message has been edited by burger2227 on Aug 1, 2009 12:18 AM
Simple Multi-key graphics routine using an Array and INP(96).
November 29 2009, 3:03 PM
' ADD all of the scancodes you need! Demo uses W,S,A,D keys.
' INP(96) can return multiple keypresses for diagonal moves.
' Optional Mask setup for images that are not shaped like a box.
DEFINT A-Z
DIM BG(300), Image(300), Mask(300), SC(127) ' SC holds the INP returns
SCREEN 13 ' graphic coordinates are 0 to 319 wide and 199 deep.
COLOR 4: LOCATE 10, 5: PRINT "Multikey Keyboard input routine"
COLOR 10: LOCATE 12, 4: PRINT "Use the W,S,A,D keys to move box."
LOCATE 13, 4: PRINT "Note that you can press two or more"
LOCATE 14, 4: PRINT "keys at once for diagonal movement!"
COLOR 14: LOCATE 16, 4: PRINT " Also demonstrates how GET and PUT "
LOCATE 17, 4: PRINT "are used to preserve the background."
COLOR 11: LOCATE 19, 11: PRINT "Press [Esc] to quit"
X = 150: Y = 50: PX = X: PY = Y
DEF SEG = 0 ' set to PEEK and POKE TIMER
POKE (1132), 0 ' zero Timer tick
GET (X, Y)-(X + 15, Y + 15), BG ' GET original BG at start position
LINE (X, Y)-(X + 15, Y + 15), 9, BF ' box draw can be changed
GET (X, Y)-(X + 15, Y + 15), Image ' GET image to Array
'Optional Mask routine for non-box shaped images centered in box area.
'FOR i = X TO X + 15
' FOR j = Y TO Y + 15
'IF POINT(i, j) = 0 THEN PSET(i, j), 15 ELSE PSET(i, j), 0
'NEXT: NEXT
'GET (X, Y)-X + 15, Y + 15), Mask ' GET mask
'PUT (X, Y), Mask, AND ' all white areas show background image
'PUT (X, Y), Image ' default XOR action sets image only on black areas
DO 'main loop
DO '1 Tick (1/18th second) scancode loop
I$ = INKEY$ ' So the keyboard buffer won't get full
I = INP(&H60) ' Get keyboard scan code from port 96
IF I < 128 THEN SC(I) = 1 ELSE SC(I - 128) = 0 'place true/false values into array
LOOP UNTIL PEEK(1132) >= 1 ' until one tick has passed
POKE (1132), 0 ' zero timer again
PX = X: PY = Y ' previous coordinates
IF SC(30) = 1 THEN X = X - 5: IF X < 0 THEN X = 0
IF SC(32) = 1 THEN X = X + 5: IF X > 304 THEN X = 304
IF SC(17) = 1 THEN Y = Y - 5: IF Y < 0 THEN Y = 0
IF SC(31) = 1 THEN Y = Y + 5: IF Y > 184 THEN Y = 184
IF X <> PX OR Y <> PY THEN ' look for a changed coordinate value
WAIT 936, 8: PUT (PX, PY), BG, PSET ' replace previous BG first
GET (X, Y)-(X + 15, Y + 15), BG ' GET BG at new position before box is set
PUT (X, Y), Image, PSET ' comment out when using optional mask!
'Optional PUTs with mask!
'PUT (X, Y), Mask, AND ' PUT AND image mask (optional)
'PUT (X, Y), Image ' PUT XOR box image at new position(optional)
END IF
LOOP UNTIL SC(1) = 1 ' loop until [Esc] (scan code 1) is pressed
DEF SEG ' reset to QB default
SYSTEM
'See TheBob's mask demo in his QBG2 graphics tutorial download here.
' Ted
This message has been edited by burger2227 on Dec 5, 2009 2:47 PM This message has been edited by burger2227 on Dec 5, 2009 2:38 PM This message has been edited by burger2227 on Dec 5, 2009 2:36 PM This message has been edited by burger2227 on Dec 4, 2009 1:32 PM This message has been edited by burger2227 on Dec 1, 2009 12:53 PM