Convert hBMP to hIcon (Dixon)

Category: Convert Bitmap to Icon

Date: 03-28-2012

Return to Index


 
'PBCC5 program
'Compilable Example:
#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.icoFor BINARY AS ff
   Put$ ff,Icon
   Seteof ff
   Close ff
 
   ? "Done"
End Function
 
'gbs_00538
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm