Convert hBMP to hIcon (B&W)

Category: Convert Bitmap to Icon

Date: 03-28-2012

Return to Index


 
'Primary Code:
'Credit:  Peter
 
 
'Compilable Example:
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#Include "Win32API.inc"
#Resource "gbsnippets.pbr"
 
Global hDlg As DWord, hBMP As DWord, bmp$, w As Long, h As Long
Global bmpAND() As Byte, bmpXOR() As Byte, hIcon As DWord
%ID_Graphic = 400 : %ID_Button = 300
 
Function PBMain() As Long
   Dialog New Pixels, 0, "GDI Load Image Test",300,300,250,260, %WS_OverlappedWindow To hDlg
   Control Add Button, hDlg, %ID_Button,"Convert", 60,10,90,25
   '   CONTROL ADD GRAPHIC, hDlg, %ID_Graphic,"", 10,40,100,100
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   If CB.Msg = %WM_Command AND CB.Ctl = %ID_Button AND CB.Ctlmsg = %BN_Clicked Then
      ConvertBMPtoIcon
      'use the icon to show it works
      SendMessage hDlg, %WM_SETICON, %ICON_SMALL, hIcon
 
      ' Show the source icon, just so we know it's ok.
      Control Add Graphic, hDlg, %ID_Graphic, "", 10, 40, w, h
      Graphic Attach hDlg, %ID_Graphic
      Graphic Set Bits bmp$
      Graphic Detach
   End If
End Function
 
Sub ConvertBMPtoICON
   Local i As Long
 
   'retrieve bitmap string, get w/h
   bmp$ = Bitstring                      'happy face from the DATA statements
   w = CVL(bmp$,1) : h = CVL(bmp$,5)     'get w/h from bitstring
 
   'convert bmp$ to AND and XOR bytes arrays
   CreateIconByteArrays
 
   'create an icon using w,h and the Byte arrays.
   ' Bitmaps are monochrome, so use 1 for planes / bpp
   hIcon = CreateIcon( ByVal %Null, w,h,1,1,ByVal VarPTR(bmpXOR(0)), ByVal VarPTR(bmpAND(0)) )
End Sub
 
Sub CreateIconByteArrays
   Local i As Long, j As Long, colTransparent As Long
   Local lByte As Long, lBit As Long
   Local bRed, bGreen, bBlue, bGrey As Byte
   Local bSetXOR, bSetAND As Byte
 
   Local lWhite As Long, lBlack As Long, lScreen As Long, lReverse As Long
 
   '   colTransparent = 0
   '   colTransparent = RGB(&HFF, &HFF, &H00)
   '   colTransparent = %WHITE
   colTransparent = Rgb(&HEC, &HE9, &HD8)
 
   ' How many BYTEs do we need to store (w*h) bits ? (Less 1 for zero-based array)
   Dim bmpAND(((w*h) \ 8) - 1) , bmpXOR(((w*h) \ 8) - 1)
 
   ' Each four characters in the string equal one Long RGB(A) value
   For i = 9 To Len(bmp$) Step 4
 
      bRed   = CVByt(bmp$, i + 2)
      bGreen = CVByt(bmp$, i + 1)
      bBlue  = CVByt(bmp$, i + 0)
 
      ' Could play around with proportions for better greyscale, but for now, leave at 1 for all
      bGrey  = ((bRed * 1) + (bGreen * 1) + (bBlue * 1)) \ 3
 
      '      IF cvl(bmp$, i) = colTransparent then
      If Rgb(bRed, bGreen, bBlue) = colTransparent Then
         ' Transparent pixel = SCREEN (?)
         bSetAND = 0
         bSetXOR = 1
         Incr lScreen
      Else
         ' If not transparent...
 
         If bGrey > 127 Then
            ' MSDN says WHITE is AND=0, XOR=1, but tests seem to show vice versa
            ' White pixel
            bSetAND = 1
            bSetXOR = 0
            Incr lWhite
         Else
            ' Black pixel
            bSetAND = 0
            bSetXOR = 0
            Incr lBlack
         End If
      End If
 
      If IsTrue(bSetAND) Then
         Bit Set bmpAND(0), (lByte * 8) + (8 - lBit) - 1
      End If
      If IsTrue(bSetXOR) Then
         Bit Set bmpXOR(0), (lByte * 8) + (8 - lBit) - 1
      End If
 
      Incr lBit
      If lBit = 8 Then
         Incr lByte
         lBit = 0
      End If
 
   Next i
 
   MsgBox "Set " & Format$(lScreen) & " as SCREEN, " & Format$(lBlack) & " as BLACK, and " & Format$(lWhite) & " as WHITE"
End Sub
 
Function BitString() As String
   'bit string for:   HAPPY FACE    16x16
   Local bmp$, i As Long
   Data 000010, 000010
   Data ECE9D8, ECE9D8, ECE9D8, ECE9D8, ECE9D8, 000000, 000000, 000000, 000000, 000000, 000000, ECE9D8, ECE9D8, ECE9D8, ECE9D8, ECE9D8
   Data ECE9D8, ECE9D8, ECE9D8, 000000, 000000, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, 000000, 000000, ECE9D8, ECE9D8, ECE9D8
   Data ECE9D8, ECE9D8, 000000, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, 000000, ECE9D8, ECE9D8
   Data ECE9D8, 000000, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, 000000, ECE9D8
   Data ECE9D8, 000000, FFFF00, FFFF00, FFFF00, 000000, 000000, FFFF00, FFFF00, 000000, 000000, FFFF00, FFFF00, FFFF00, 000000, ECE9D8
   Data 000000, FFFF00, FFFF00, FFFF00, FFFF00, 000000, 000000, FFFF00, FFFF00, 000000, 000000, FFFF00, FFFF00, FFFF00, FFFF00, 000000
   Data 000000, FFFF00, FFFF00, FFFF00, FFFF00, 000000, 000000, FFFF00, FFFF00, 000000, 000000, FFFF00, FFFF00, FFFF00, FFFF00, 000000
   Data 000000, FFFF00, FFFF00, FFFF00, FFFF00, 000000, 000000, FFFF00, FFFF00, 000000, 000000, FFFF00, FFFF00, FFFF00, FFFF00, 000000
   Data 000000, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, 000000
   Data 000000, FFFF00, FFFF00, FFFF00, 000000, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, 000000, FFFF00, FFFF00, FFFF00, 000000
   Data 000000, FFFF00, FFFF00, FFFF00, 000000, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, 000000, FFFF00, FFFF00, FFFF00, 000000
   Data ECE9D8, 000000, FFFF00, FFFF00, ECE9D8, 000000, FFFF00, FFFF00, FFFF00, FFFF00, 000000, ECE9D8, FFFF00, FFFF00, 000000, ECE9D8
   Data ECE9D8, 000000, FFFF00, FFFF00, FFFF00, ECE9D8, 000000, 000000, 000000, 000000, ECE9D8, FFFF00, FFFF00, FFFF00, 000000, ECE9D8
   Data ECE9D8, ECE9D8, 000000, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, 000000, ECE9D8, ECE9D8
   Data ECE9D8, ECE9D8, ECE9D8, 000000, 000000, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, FFFF00, 000000, 000000, ECE9D8, ECE9D8, ECE9D8
   Data ECE9D8, ECE9D8, ECE9D8, ECE9D8, ECE9D8, 000000, 000000, 000000, 000000, 000000, 000000, ECE9D8, ECE9D8, ECE9D8, ECE9D8, ECE9D8
   For i = 1 To Datacount
      bmp$ = bmp$ + Mkl$(Val("&H"+Read$(i)))
   Next i
   Function = bmp$
End Function
 
'gbs_00486
'Date: 03-10-2012


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