So this isn't a full on project (although it will be part of an upcoming one), just some code- doing this conversion in VB turned out to be very difficult for someone unfamiliar with graphics APIs. Found tons of other people having the same question with mostly incomplete answers, and I couldn't find anywhere showing it done in VB.. spent hours figuring it out from other codes, which turned the issue into something far more complicated than the ultimate solution I found turned out to be.
The use case this was developed as a response to was to be able to use take hIcon's extracted from files and be able to use them as a value for MENUITEMINFO.hbmpItem.
The initial hIcon can be from any source that has that type returned; e.g. ExtractIcon[Ex], LoadImage, etc.
EDIT - KNOWN ISSUES
**The above code only works for 24-bit icons with an alpha channel.**
For 24-bit icons without an alpha channel, and icons with 256 or fewer colors:
(note that this requires gdiplus to be initialized, so use the entire module below which includes it)
This of course requires knowing which one to use, I'm working on one without GDIPlus, in the mean time there's this one from Leandro Ascierto's clsMenuImage:
The use case this was developed as a response to was to be able to use take hIcon's extracted from files and be able to use them as a value for MENUITEMINFO.hbmpItem.
Code:
'Declares
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(3) As Byte
End Type
Private Const DIB_RGB_COLORS = 0&
Private Const DI_NORMAL = 3&
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Any, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal XLeft As Long, ByVal YTop As Long, ByVal hIcon As Long, ByVal CXWidth As Long, ByVal CYWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
'Functions
Public Function HBitmapFromHIcon(hIcon As Long, cx As Long, cy As Long) As Long
Dim hdc As Long
Dim hBackDC As Long
Dim hBitmap As Long
Dim hBackSV As Long
hdc = GetDC(0)
hBackDC = CreateCompatibleDC(hdc)
hBitmap = Create32BitHBITMAP(hBackDC, cx, cy)
hBackSV = SelectObject(hBackDC, hBitmap)
DrawIconEx hBackDC, 0, 0, hIcon, cx, cy, 0, 0, DI_NORMAL
Call SelectObject(hBackDC, hBackSV)
Call ReleaseDC(0, hdc)
Call DeleteDC(hBackDC)
HBitmapFromHIcon = hBitmap
End Function
Public Function Create32BitHBITMAP(hdc As Long, cx As Long, cy As Long) As Long
Dim bmi As BITMAPINFO
Dim hdcUsed As Long
bmi.bmiHeader.biSize = Len(bmi.bmiHeader)
bmi.bmiHeader.biPlanes = 1
bmi.bmiHeader.biCompression = 0
bmi.bmiHeader.biWidth = cx
bmi.bmiHeader.biHeight = cy
bmi.bmiHeader.biBitCount = 32
Create32BitHBITMAP = CreateDIBSection(hdc, bmi, DIB_RGB_COLORS, ByVal 0&, 0, 0)
End FunctionEDIT - KNOWN ISSUES
**The above code only works for 24-bit icons with an alpha channel.**
For 24-bit icons without an alpha channel, and icons with 256 or fewer colors:
Code:
Public Function HBitmapFromHIconNoAlpha(hIcon As Long) As Long
Dim himg As Long
Dim hb As Long
GdipCreateBitmapFromHICON hIcon, himg
GdipCreateHBITMAPFromBitmap himg, hb, &HFF000000
GdipDisposeImage himg
HBitmapFromHIconNoAlpha = hb
End FunctionThis of course requires knowing which one to use, I'm working on one without GDIPlus, in the mean time there's this one from Leandro Ascierto's clsMenuImage:
Code:
Option Explicit
'If you are using this don't just copy the main function, note the startup and shutdown of gdiplus
Public gInitToken As Long
Private Const PixelFormat32bppRGB As Long = &H22009
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type ARGB
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Private Type BitmapData
Width As Long
Height As Long
Stride As Long
PixelFormat As Long
Scan0 As Long
Reserved As Long
End Type
Private Enum ImageLockMode
ImageLockModeRead = &H1
ImageLockModeWrite = &H2
ImageLockModeUserInputBuf = &H4
End Enum
Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (Token As Long, gdipInput As GdiplusStartupInput, GdiplusStartupOutput As Long) As Long
Private Declare Sub GdiplusShutdown Lib "GdiPlus.dll" (ByVal Token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hBmp As Long, ByVal hPal As Long, GpBitmap As Long) As Long
Private Declare Function GdipGetImagePixelFormat Lib "GDIplus" (ByVal Image As Long, ByRef PixelFormat As Long) As Long
Private Declare Function GdipGetImageDimension Lib "GDIplus" (ByVal Image As Long, ByRef Width As Single, ByRef Height As Single) As Long
Private Declare Function GdipBitmapLockBits Lib "GDIplus" (ByVal BITMAP As Long, ByRef RECT As RECT, ByVal Flags As ImageLockMode, ByVal PixelFormat As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "GDIplus" (ByVal BITMAP As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Sub InitGDIP()
Static Token As Long
If Token = 0 Then
Dim gdipInit As GdiplusStartupInput
gdipInit.GdiplusVersion = 1
GdiplusStartup Token, gdipInit, ByVal 0&
gInitToken = Token
End If
End Sub
Public Function pvIsAlphaIcon(ByVal IconHandle As Long) As Boolean
Dim tARGB() As ARGB
Dim tRECT As RECT
Dim tICONINFO As ICONINFO
Dim tBitmapData As BitmapData
Dim lPixelFormat As Long
Dim lngX As Long
Dim lngY As Long
Dim sngWidth As Single
Dim sngHeight As Single
Dim lngArgbBmp As Long
Dim lngColorBmp As Long
Dim bolRet As Boolean
Dim hr As Long
On Error GoTo e0
If gInitToken = 0 Then InitGDIP
hr = GetIconInfo(IconHandle, tICONINFO)
If hr <> 0 Then
If tICONINFO.hBMColor <> 0 Then
If GdipCreateBitmapFromHBITMAP(tICONINFO.hBMColor, 0&, lngColorBmp) = 0 Then
If GdipGetImagePixelFormat(lngColorBmp, lPixelFormat) = 0 Then
If lPixelFormat <> PixelFormat32bppRGB Then
bolRet = False
Else
If GdipGetImageDimension(lngColorBmp, sngWidth, sngHeight) = 0 Then
With tRECT
.Right = CLng(sngWidth)
.Bottom = CLng(sngHeight)
End With
ReDim tARGB(tRECT.Right - 1&, tRECT.Bottom - 1&)
With tBitmapData
.Scan0 = VarPtr(tARGB(0&, 0&))
.Stride = 4& * tRECT.Right
End With
If GdipBitmapLockBits(lngColorBmp, tRECT, ImageLockModeRead Or ImageLockModeUserInputBuf, lPixelFormat, tBitmapData) = 0 Then
For lngY = 0 To tBitmapData.Height - 1
For lngX = 0 To tBitmapData.Width - 1
If tARGB(lngX, lngY).Alpha > 0 Then
If tARGB(lngX, lngY).Alpha < 255 Then
bolRet = True
Exit For
End If
End If
Next lngX
If bolRet Then Exit For
Next lngY
Call GdipDisposeImage(lngArgbBmp)
Call GdipBitmapUnlockBits(lngColorBmp, tBitmapData)
End If
End If
End If
End If
Call GdipDisposeImage(lngColorBmp)
End If
Call DeleteObject(tICONINFO.hBMColor)
End If
Call DeleteObject(tICONINFO.hBMMask)
Else
bolRet = False
End If
pvIsAlphaIcon = bolRet
ReleaseGDIP
On Error GoTo 0
Exit Function
e0:
Debug.Print "modGDIP.pvIsAlphaIcon.Error->" & Err.Description & " (" & Err.Number & ")"
End Function
Public Function HBitmapFromHIconNoAlpha(hIcon As Long) As Long
Dim himg As Long
Dim hb As Long
GdipCreateBitmapFromHICON hIcon, himg
GdipCreateHBITMAPFromBitmap himg, hb, &HFF000000
GdipDisposeImage himg
HBitmapFromHIconNoAlpha = hb
End Function
Public Sub ReleaseGDIP()
GdiplusShutdown gInitToken
End Sub