Results 1 to 7 of 7

Thread: [VB6] Code Snippet: Converting an hIcon to an hBitmap

Threaded View

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,532

    [VB6] Code Snippet: Converting an hIcon to an hBitmap

    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.
    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 Function
    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:
    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 Function
    (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:
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width