Date: 02-16-2022
Return to Index
created by gbSnippets
'PBCC5 program
'Compilable Example: (Jose Includes)
#Include "win32api.inc"
Type Palette16
colour(15) As Long
End Type
Function PBMain
Local FF, hWin ,IconCount, IconWidth, IconHeight, NumColours, x, y As Long
Local ColsSoFar, Flag, Col, z As Long
Local Icon, Bmp, NewBmp, NewBmp2 AS String
Local BmpHeader AS BitmapInfoHeader
Local Palette AS Palette16
IconCount = 1
IconWidth = 32
IconHeight = 32
NumColours = 16
'draw a bitmap to be converted to an icon
Graphic Window "Icon", 10,10,IconWidth, IconHeight TO hWin
Graphic Attach hWin,0
Graphic Clear %BLACK
Graphic Ellipse (2,2) - (30,30),%RED,%RED
Graphic Ellipse (6,6) - (26,26),%YELLOW,%YELLOW
Graphic Ellipse (10,10) - (22,22),%GREEN,%GREEN
Graphic Box (2,16)-(30,31),0,%RED,%RED
Graphic Box (6,16)-(26,31),0,%YELLOW,%YELLOW
Graphic Box (10,16)-(22,31),0,%GREEN,%GREEN
'set the palette colours
For x = 0 TO 15
Palette.colour(x)=&hffffef 'an unused colour to start with
Next
'extract the colours from the bitmap to create the palette. Assume only 16 are there
ColsSoFar = 0
For y = IconHeight - 1 TO 0 Step -1
For x = 0 TO IconWidth -1
Graphic Get Pixel (x, y) TO col
Flag = 0
For z = 0 TO 15
If Palette.colour(z) = Rgb(col) Then
'colour was used before so point to same index in palette
NewBmp = NewBmp + Chr$(z)
flag = 1
Exit For
End If
Next
If flag = 0 Then
'colour has not been used so add it to the palette
Palette.Colour(ColsSoFar) = Rgb(col)
NewBmp = NewBmp + Chr$(ColsSoFar)
ColsSoFar = ColsSoFar + 1
If ColsSoFar > 15 Then
ColsSoFar = 15
End If
End If
Next
Next
'the bitmap header
BmpHeader.biSize = SizeOf(BitmapInfoHeader)
BmpHeader.biWidth = IconWidth
BmpHeader.biHeight = IconHeight * 2
BmpHeader.biPlanes = 1
BmpHeader.biBitCount = 4 '4 bits = a 16 colour icon
BmpHeader.biCompression = 0
BmpHeader.biSizeImage = IconWidth * IconHeight * (1 + BmpHeader.biBitCount)/8 '1 allows for the monochrome mask
BmpHeader.biXPelsPerMeter = 0
BmpHeader.biYPelsPerMeter = 0
BmpHeader.biClrUsed = 0
BmpHeader.biClrImportant = 0
'create the icon header
Icon = Mki$(0) + Mki$(1) + Mki$(IconCount)
'add the directory entry for the icon,
Icon = Icon + MkByt$(IconWidth) + MkByt$(IconHeight) + MkByt$(NumColours) + MkByt$(0) + Mki$(0) + Mki$(0)
Icon = Icon + MkDwd$(SizeOf(BmpHeader) + SizeOf(Palette) + BmpHeader.biSizeImage)
Icon = Icon + MkDwd$(Len(Icon)+4)
'add the bitmap, first the header
Icon = Icon + BmpHeader
'then the pallette info
Icon = Icon + Palette
'compress the 1 byte per pixel in NewBmp to the 2 pixels/byte (16 colour) in NewBmp2
For x = 1 TO Len(NewBmp)/2
NewBmp2 = NewBmp2 + Chr$(Asc(Mid$(NewBmp,x*2,1)) + Asc(Mid$(NewBmp,x*2-1,1))*16)
Next
'add the main bitmap
Icon = Icon + NewBmp2
Dim Mask(1 TO IconWidth * IconHeight /8) AS BYTE
'create the monochrome mask bitmap
For x = 0 TO Len(NewBmp) -1
'I assume that palette colour 0 (the first colour found) is to be the transparent colour.
'change the 0 on the following line to the required colour 1-15 if another colour is to be transparent
If Asc(Mid$(NewBmp,x+1,1)) = 0 Then
'bit is transparent
Bit Set Mask(1),(x AND &hfffffff8) + 7 - (x AND &h7)
Else
Bit Reset Mask(1),(x AND &hfffffff8) + 7 - (x AND &h7)
End If
Next
'add the mask bitmap
Icon = Icon + Peek$(VarPTR(Mask(1)), IconWidth * IconHeight /8 )
'write to file
ff = FreeFile
Open "c:\testicon4.ico" For BINARY AS ff
Put$ ff,Icon
Seteof ff
Close ff
? "Done"
End Function
'gbs_00538
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm