forked from QB64-Phoenix-Edition/QB64pe
-
Notifications
You must be signed in to change notification settings - Fork 0
Creating Icon Bitmaps
Samuel Gomes edited this page Nov 8, 2022
·
1 revision
The following program can be used to view Icon or Cursor images and save them as Bitmaps. When you answer Y the bitmap is saved with a black background so that it can be PUT using XOR on to the AND image. The AND image will be black and white if the image is irregularly shaped(not a full box image). It is placed first using PUT (graphics statement) with the AND action or can be placed using _PUTIMAGE with the color white _ALPHA being set to 0. In that case, try just placing the XOR image with the color black 0 _ALPHA with _SETALPHA.
Code by Ted Weissgerber
'********************************* IconType.BI INCLUDE FILE ********************************
TYPE IconType 'Icon or cursor file header
Reserved AS INTEGER 'Reserved (always 0)
ID AS INTEGER 'Resource ID (Icon = 1, Cursor = 2)
Count AS INTEGER 'Number of icon bitmaps in Directory of icon entries array
END TYPE '6 bytes
TYPE ICONENTRY 'or unanimated Cursor entry (see ANI for animated cursors)
PWidth AS _BYTE 'Width of icon in pixels (USE THIS)
PDepth AS _BYTE 'Height of icon in pixels (USE THIS)
NumColors AS _BYTE 'Maximum number of colors: (2 or 16 colors. 256 or 24/32 bit = 0}
RES2 AS _BYTE 'Reserved. Not used (always 0)
HotSpotX AS INTEGER 'Icon: NumberPlanes(normally 0), Cursor: hotspot pixels from left
HotSpotY AS INTEGER 'Icon: BitsPerPixel(normally 0), Cursor: hotspot pixels from top
DataSize AS LONG 'Length of icon bitmap in bytes (USE THIS)
DataOffset AS LONG 'Offset byte position of icon bitmap data header in file(add 1)
END TYPE '16 bytes
TYPE ICONHEADER 'Bitmap type header found using entry DataOffset + 1
IconHSize AS LONG 'size of ICON header (always 40 bytes)
ICONWidth AS LONG 'bitmap width in pixels. (width and double height may be missing)
ICONDepth AS LONG 'Total map height in pixels (TWO TIMES the image height).
NumPlanes AS INTEGER 'number of color planes. Must be set to 1.
BPP AS INTEGER 'bits per pixel 1, 4, 8, 16, 24 or 32.(USE THIS for BPP)
Compress AS LONG 'compression method should always be 0.
RAWSize AS LONG 'size of the raw ICON image data(may only be XOR mask size).
Hres AS LONG 'horizontal resolution of the image(not normally used)
Vres AS LONG 'vertical resolution of the image(not normally used)
NumColors AS LONG 'number of colors in the color palette(not normally used)
SigColors AS LONG 'number of important colors used(not normally used)
END TYPE '40 byte
REM $INCLUDE: 'IconType.BI'
DEFINT A-Z
DIM Icon AS IconType
DIM SHARED Item, BPP
DIM SHARED wide&, deep&, bmp&, bmpStretch&
DIM Image(26000)
dst& = _NEWIMAGE(800, 600, 32)
SCREEN dst&
hdr$ = " & File ID = # ## Image(s) in file #######, bytes "
ico$ = " Size = ## X ## Colors = ## Planes = # BPP = ## "
cur$ = " Size = ## X ## Colors = ## HotSpot X = ## Y = ## "
dat$ = " DATA Size = #####, bytes DATA Offset = ######, "
bm1$ = " HeaderSize = ## MaskArea = ## X ## Planes = # BPP = ## "
bm2$ = " Compression = # RAW Data Size = ######, bytes "
LOCATE 20, 20: LINE INPUT "Enter an ICOn or CURsor file name: ", IconName$
L = LEN(IconName$)
IF L = 0 THEN SOUND 400, 4: SYSTEM
dot = INSTR(IconName$, ".")
IF dot = 0 THEN
Save$ = IconName$: IconName$ = IconName$ + ".ICO"
ELSE Save$ = LEFT$(IconName$, dot - 1)
END IF
OPEN IconName$ FOR BINARY AS #1
length& = LOF(1)
PRINT
IF length& THEN
GET #1, 1, Icon
SELECT CASE Icon.ID
CASE 1: IC$ = "Icon": ent$ = ico$
CASE 2: IC$ = "Cursor": ent$ = cur$
CASE ELSE: IC$ = "Bitmap?"
END SELECT
LOCATE 22, 20: PRINT USING hdr$; IC$; Icon.ID; Icon.Count; length&
IF Icon.Count THEN
count = Icon.Count
DIM SHARED Entry(count) AS ICONENTRY
DIM SHARED Header(count) AS ICONHEADER
FOR Item = 1 TO count '16 bytes each entry
GET #1, , Entry(Item)
NEXT
VIEW PRINT 24 TO 32
FOR Item = 1 TO count
GET #1, Entry(Item).DataOffset + 1, Header(Item) 'ADD 1 to offsets!
COLOR _RGB(255, 255, 0): LOCATE 24, 30
IF count > 1 THEN PRINT " IMAGE ENTRY #"; Item ELSE PRINT " IMAGE ENTRY"
COLOR _RGB(50, 200, 255)
PRINT USING ent$; Entry(Item).PWidth; Entry(Item).PDepth; Entry(Item).NumColors; Entry(Item).HotSpotX; Entry(Item).HotSpotY
PRINT USING dat$; Entry(Item).DataSize; Entry(Item).DataOffset
PRINT USING bm1$; Header(Item).IconHSize; Header(Item).ICONWidth; Header(Item).ICONDepth, Header(Item).NumPlanes; Header(Item).BPP
PRINT USING bm2$; Header(Item).Compress; Header(Item).RAWSize
PRINT
k$ = INPUT$(1) 'Palette(4 or 8BPP) and/or XOR mask starts immediately after an ICONHEADER
wide& = Entry(Item).PWidth: deep& = Entry(Item).PDepth: BPP = Header(Item).BPP
IF BPP > 8 THEN BitColor = 32 ELSE BitColor = 256 'assign for proper colors
bmpStretch& = _NEWIMAGE(4 * wide&, 4 * deep&, BitColor) 'set either 256 or 32
bmp& = _NEWIMAGE(wide&, deep&, BitColor) 'don't bother with _FREEIMAGE, reuse them!
SELECT CASE BPP
CASE 1: OneBit
CASE 4: FourBIT
CASE 8: EightBIT
CASE IS > 8: TrueCOLOR
END SELECT
IF BPP < 24 THEN _COPYPALETTE bmp&, bmpStretch&
_PUTIMAGE , bmp&, bmpStretch&
_DEST 0: _PUTIMAGE (100, 0), bmpStretch&
SOUND 600, 3
COLOR _RGB(255, 0, 255): LOCATE CSRLIN, 30: PRINT "Save as Bitmap? (Y/N)";
k$ = INPUT$(1)
k$ = UCASE$(k$)
PRINT k$ + SPACE$(1);
IF k$ = "Y" THEN
SaveFile$ = Save$ + LTRIM$(STR$(Item)) + ".BMP"
ThirtyTwoBit 0, 0, wide& - 1, deep& - 1, bmp&, SaveFile$
END IF
IF k$ = "Y" THEN PRINT "Saved!" ELSE PRINT "Not saved"
ANDMask
IF BPP < 24 THEN _COPYPALETTE bmp&, bmpStretch&
_PUTIMAGE , bmp&, bmpStretch&
_DEST 0: _PUTIMAGE (400, 0), bmpStretch&
IF k$ = "Y" THEN
ANDFile$ = Save$ + LTRIM$(STR$(Item)) + "BG.BMP"
ThirtyTwoBit 0, 0, wide& - 1, deep& - 1, bmp&, ANDFile$
END IF
k$ = INPUT$(1)
CLS
NEXT
VIEW PRINT
ELSE SOUND 400, 4: CLOSE #1: PRINT "No images entries found!": END
END IF
ELSE: CLOSE #1: SOUND 400, 4: KILL IconName$: END
END IF
CLOSE #1
END
SUB OneBit 'adapted from TheBob's Winbit 'B & W monochrome images ONLY (NO PALETTE data)
BitsOver = wide& MOD 32
IF BitsOver THEN ZeroPAD$ = SPACE$((32 - BitsOver) \ 8)
_DEST bmp&
y = deep& - 1: p$ = " "
DO
x = 0
DO
GET #1, , p$
ByteVAL = ASC(p$)
FOR Bit% = 7 TO 0 STEP -1 'read bits left to right
IF ByteVAL AND 2 ^ Bit% THEN PSET (x, y), 15 ELSE PSET (x, y), 0
x = x + 1
NEXT Bit%
LOOP WHILE x < wide&
GET #1, , ZeroPAD$ ' 'prevents odd width image skewing
y = y - 1 '
LOOP UNTIL y = -1
END SUB
SUB EightBIT 'adapted from TheBob's Winbit '256 palette data Colors (8 BPP)
IF wide& MOD 4 THEN ZeroPAD$ = SPACE$(4 - (wide& MOD 4))
_DEST bmp&
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 = deep& - 1: p$ = " "
DO: x = 0
DO
GET #1, , p$
PSET (x, y), ASC(p$)
x = x + 1
LOOP WHILE x < wide&
GET #1, , ZeroPAD$ ' 'prevents odd width image skewing
y = y - 1
LOOP UNTIL y = -1
END SUB
SUB FourBIT 'adapted from TheBob's Winbit '16 palette data colors (4 BPP = 8 or 16 color)
_DEST bmp&
IF wide& MOD 8 THEN ZeroPAD$ = SPACE$((8 - wide& MOD 8) \ 2) 'prevents odd width image skewing
a$ = " ": u$ = " "
FOR Colr = 0 TO 15
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, , u$ '--- unused byte
NEXT Colr
y = deep& - 1: p$ = " "
DO
x = 0
DO
GET #1, , p$
HiNIBBLE = ASC(p$) \ &H10
LoNIBBLE = ASC(p$) AND &HF
PSET (x, y), HiNIBBLE
x = x + 1
PSET (x, y), LoNIBBLE
x = x + 1
LOOP WHILE x < wide&
GET #1, , ZeroPAD$ ' 'prevents odd width image skewing
y = y - 1
LOOP UNTIL y = -1
END SUB
SUB ANDMask ' 'AND MASK is B & W. Black area holds XOR colors, white displays background
BitsOver = wide& MOD 32
IF BitsOver THEN ZeroPAD$ = SPACE$((32 - BitsOver) \ 8) 'look for sizes not multiples of 32 bits
_DEST bmp&
IF BPP < 24 THEN PALETTE ' 'remove for a PUT using previous XOR mask palette data
y = deep& - 1: a$ = " ": p$ = " "
DO
x = 0
DO
GET #1, , a$
ByteVAL = ASC(a$) 'MSBit is left when calculating 16 X 16 cursor map 2 byte integer
FOR Bit% = 7 TO 0 STEP -1 'values despite M$ documentation that says otherwise!
IF ByteVAL AND 2 ^ Bit% THEN 'LONG values cannot be used in a cursor file!
IF BPP > 8 THEN PSET (x, y), _RGB32(255, 255, 255) ELSE PSET (x, y), 15
ELSE: IF BPP > 8 THEN PSET (x, y), _RGB32(0, 0, 0) ELSE PSET (x, y), 0
END IF
x = x + 1 '16 X 16 = 32 bytes, 32 X 32 = 128 bytes AND MASK SIZES
NEXT Bit% '48 X 48 = 288 bytes, 64 X 64 = 512 bytes, 128 X 128 = 2048 bytes
LOOP WHILE x < wide&
GET #1, , ZeroPAD$ '16 X 16 and 48 X 48 = 2 byte end padder per row in the AND MASK
y = y - 1 'adds 32 and 96 bytes respectively to the raw data size!
LOOP UNTIL y = -1
END SUB
SUB TrueCOLOR ' ' 16 Million colors. NO PALETTE! Colored by pixels (24 or 32 BPP)
_DEST bmp&
IF ((BMP.PWidth * 3) MOD 4) <> 0 THEN '3 byte pixels
ZeroPAD$ = SPACE$((4 - ((BMP.PWidth * 3) MOD 4)))
END IF
R$ = " ": G$ = " ": B$ = " "
y = deep& - 1
DO
x = 0
DO
GET #1, , B$ '3 bytes set RGB color intensities
GET #1, , G$
GET #1, , R$
red& = ASC(R$)
green& = ASC(G$)
blue& = ASC(B$)
PSET (x, y), _RGB(red&, green&, blue&) 'returns closest attribute in 4 or 8 bit
x = x + 1
LOOP WHILE x < wide&
GET #1, , ZeroPAD$ ' 'prevents odd width image skewing
y = y - 1
LOOP UNTIL y = -1
END SUB
REM $INCLUDE: '32BitSUB.BM'
'*********************************** 32BitSUB.BM INCLUDE FILE *******************************
SUB ThirtyTwoBit (x1%, y1%, x2%, y2%, image&, Filename$)
DIM Colors8%(255)
IF x1% > x2% THEN SWAP x1%, x2%
IF y1% > y2% THEN SWAP y1%, y2%
_SOURCE image&
pixelbytes& = _PIXELSIZE(image&)
IF pixelbytes& = 0 THEN BEEP: EXIT SUB 'no text screens
FileType$ = "BM"
QB64$ = "QB64" 'free advertiising in reserved bytes
IF pixelbytes& = 1 THEN OffsetBITS& = 1078 ELSE OffsetBITS& = 54 'no palette in 24/32 bit
InfoHEADER& = 40
PictureWidth& = (x2% - x1%) + 1 ' don't exceed maximum screen resolutions!
PictureDepth& = (y2% - y1%) + 1
NumPLANES% = 1
IF pixelbytes& = 1 THEN BPP% = 8 ELSE BPP% = 24
Compression& = 0
WidthPELS& = 3780
DepthPELS& = 3780
IF pixelbytes& = 1 THEN NumColors& = 256 '24/32 bit say none
IF (PictureWidth& AND 3) THEN ZeroPAD$ = SPACE$(4 - (PictureWidth& AND 3))
ImageSize& = (PictureWidth& + LEN(ZeroPAD$)) * PictureDepth&
FileSize& = ImageSIZE& + OffsetBITS&
f = FREEFILE
OPEN Filename$ FOR BINARY AS #f
PUT #f, , FileType$
PUT #f, , FileSize&
PUT #f, , QB64$
PUT #f, , OffsetBITS&
PUT #f, , InfoHEADER&
PUT #f, , PictureWidth&
PUT #f, , PictureDepth&
PUT #f, , NumPLANES%
PUT #f, , BPP%
PUT #f, , Compression&
PUT #f, , ImageSize&
PUT #f, , WidthPELS&
PUT #f, , DepthPELS&
PUT #f, , NumColors&
PUT #f, , SigColors& '51 offset
IF pixelbytes& = 1 THEN '4 or 8 BPP Palettes set for 256 colors
u$ = CHR$(0)
FOR c& = 0 TO 255 'PUT as BGR order colors
cv& = _PALLETTECOLOR(c&, image&)
Colr$ = CHR$(_BLUE32(cv&))
PUT #f, , Colr$
Colr$ = CHR$(_GREEN32(cv&))
PUT #f, , Colr$
Colr$ = CHR$(_RED32(cv&))
PUT #f, , Colr$
PUT #f, , u$ 'Unused byte
NEXT
END IF
FOR y% = y2% TO y1% STEP -1 'place bottom up
FOR x% = x1% TO x2%
c& = POINT(x%, y%)
IF pixelbytes& = 1 THEN
a$ = CHR$(c&)
Colors8%(ASC(a$)) = 1
ELSE : a$ = LEFT$(MKL$(c&), 3)
END IF
PUT #f, , a$
NEXT
PUT #f, , ZeroPAD$
NEXT
FOR n = 0 TO 255
IF Colors8%(n) = 1 THEN SigColors& = SigColors& + 1
NEXT n
PUT #f, 51, SigColors&
CLOSE #f
END SUB
Adapted from code by Bob Seguin
NOTE: Black areas of an image may become "see through" unless another color attribute is used and set to black!
This can be done by changing another color attribute's RGB settings to 0 or almost 0 and creating a mask after using it in solid black areas of a 4 or 8 BPP palette image. This can also be done using _PUTIMAGE with 32 bit _CLEARCOLOR settings.
See the following page: Creating Sprite Masks
The following program uses a conversion function with the TYPE definitions inside of the function to eliminate an $INCLUDE library file.
SCREEN _NEWIMAGE(640, 480, 256)
_TITLE "Icon Converter"
icon$ = "daphne.ico" '<<<<<<<<< change icon file name
bitmap$ = "tempfile.bmp"
indx% = 5 '1 minimum <<<<<<< higher values than count get highest entry image in icon file
IF Icon2BMP(icon$, bitmap$, indx%) THEN
img& = _LOADIMAGE(bitmap$)
PRINT img&
IF img& < -1 THEN ' check that handle value is good before loading
_ICON img& ' place image in header
_PUTIMAGE (300, 250), img& 'place image on screen
_FREEIMAGE img& ' always free unused handles to save memory
'KILL bitmap$ ' comment out and/or rename to save the bitmaps
END IF
ELSE PRINT "Could not create bitmap!"
END IF
END
' ----------------------------------------------------
FUNCTION Icon2BMP% (filein AS STRING, fileout AS STRING, index AS INTEGER)
TYPE ICONTYPE ' Icon or cursor file header
Reserved AS INTEGER ' Reserved (always 0)
ID AS INTEGER ' Resource ID (Icon = 1, Cursor = 2)
Count AS INTEGER ' Number of icon bitmaps in Directory of icon entries array
END TYPE '6 bytes
TYPE ENTRYTYPE ' or unanimated Cursor entry (ANI are animated cursors)
Wide AS _UNSIGNED _BYTE ' Width of icon in pixels (USE THIS) Use _UNSIGNED over 127
High AS _UNSIGNED _BYTE ' Height of icon in pixels (USE THIS) Use _UNSIGNED over 127
NumColors AS _BYTE ' Maximum number of colors. (2, 8 or 16 colors. 256 or 24/32 bit = 0)
RES2 AS _BYTE ' Reserved. Not used (always 0)
HotSpotX AS INTEGER ' Icon: NumberPlanes(normally 0), Cursor: hotspot pixels from left
HotSpotY AS INTEGER ' Icon: BitsPerPixel(normally 0), Cursor: hotspot pixels from top
DataSize AS LONG ' Length of image data in bytes minus Icon and Entry headers (USE THIS)
Offset AS LONG ' Start Offset byte position of icon bitmap header(add 1 if TYPE GET)
END TYPE '16 bytes
TYPE PREHEADER ' Bitmap information not in icon BM header
BM AS INTEGER ' Integer value changed to "BM" by PUT
Size AS LONG ' Size of the data file(LOF)
Reser AS LONG' 2 reserved integers are zero automatically
BOffset AS LONG ' Start offset of pixel data(next byte)
END TYPE '14 bytes
TYPE BMPHEADER ' Bitmap type header found using entry DataOffset + 1
IconHSize AS LONG ' size of ICON header (always 40 bytes)
PWidth AS LONG ' bitmap width in pixels (signed integer).
PDepth AS LONG ' Total map height in pixels (signed integer is 2 times image height)
NumPlanes AS INTEGER ' number of color planes. Must be set to 1.
BPP AS INTEGER ' bits per pixel 1, 4, 8, 16, 24 or 32.(USE THIS)
Compress AS LONG ' compression method should always be 0.
RAWSize AS LONG ' size of the raw ICON image data(may only be XOR mask size).
Hres AS LONG ' horizontal resolution of the image(not normally used)
Vres AS LONG ' vertical resolution of the image(not normally used)
NumColors AS LONG ' number of colors in the color palette(not normally used)
SigColors AS LONG ' number of important colors used(not normally used)
END TYPE '40 bytes palette and image data immediately follow this header!
DIM ICON AS ICONTYPE, ENT AS ENTRYTYPE, PRE AS PREHEADER, BMP AS BMPHEADER
rf = FREEFILE
IF LCASE$(RIGHT$(filein, 4)) = ".ico" THEN 'check file extension is ICO only
OPEN filein FOR BINARY ACCESS READ AS rf
ELSE EXIT FUNCTION
END IF
GET rf, , ICON 'GET 6 byte icon header
IF ICON.ID <> 1 OR ICON.Count = 0 THEN CLOSE rf: EXIT FUNCTION
IF index > 0 AND index <= ICON.Count THEN entry = 16 * (index - 1) ELSE entry = 16 * (ICON.Count - 1)
PRINT ICON.Count, entry
SEEK rf, 1 + 6 + entry 'start of indexed Entry header selected
GET rf, , ENT 'GET 16 byte Entry Header set by index request or highest available
SEEK rf, 1 + ENT.Offset 'go to BMP header offset given in Entry header
GET rf, , BMP 'GET 40 byte icon bitmap header information
IF BMP.BPP <= 24 THEN pixelbytes = BMP.BPP / 8 ELSE pixelbytes = 3
IF BMP.BPP > 1 AND BMP.BPP <= 8 THEN palettebytes = 4 * (2 ^ BMP.BPP) ELSE palettebytes = 0
datasize& = (ENT.Wide * ENT.High * pixelbytes) + palettebytes 'no padder should be necessary
filesize& = datasize& + 14 + 40 ' data and palette + header
bmpoffset& = palettebytes + 54 ' data offset from start of bitmap
BMP.PWidth = ENT.Wide
BMP.PDepth = ENT.High
BMP.RAWSize = datasize& - palettebytes
PRE.BM = CVI("BM") 'integer value changes to "BM" in file
PRE.Size = filesize&
PRE.BOffset = bmpoffset& 'start of data after header and palette if used
wf = FREEFILE
OPEN fileout FOR BINARY AS wf
PUT wf, , PRE 'PUT 14 byte bitmap information
PUT wf, , BMP 'PUT 40 byte bitmap header information
SEEK rf, 1 + ENT.Offset + 40
dat$ = STRING$(datasize&, 0) 'create string variable the length of remaining image data
GET rf, , dat$ 'GET remaining palette and only the XOR image data after the indexed header
PUT wf, , dat$ 'PUT remaining data into new bitmap file
CLOSE rf, wf
Icon2BMP = ICON.Count 'function returns number of images available in icon file
END FUNCTION
Code by Ted Weissgerber
Note: The index selected or the highest numbered icon image less than the index value is the image displayed.
- Creating Icons from Bitmaps
- Bitmaps, Icons and Cursors
- _CLEARCOLOR
- _ALPHA, _ICON
- SaveIcon32 (create icons from any image)