FYI: ImageList hack for 32bpp Alpha Bitmaps

[LaVolpe]

Common controls, with a manifested project, can actually display alpha bitmaps.

The attached sample includes a project that can be compiled and tested. However, if your IDE is manifested for common controls v6, then you can test it within the IDE.

There are some limitations:

1. This is a hack. The result is an API imagelist created and attached to a VB common controls ImageList with a simple CopyMemory call. Should the location for the CopyMemory statement ever change, the hack won't work obviously and is likely to crash. But location isn't likely to change if it hasn't changed in 20 years.

2. The imagelist Width,Height properties must be square. If not, some odd scaling occurs. The test project shows that.

3. The bitmaps assigned to the imagelist must be prescaled to the same dimensions of the imagelist. If not, that same crappy scaling occurs.

4. Any bitmap added to the imagelist must NOT be PARGB format (premultiplied pixels).

Oh, this works for both v5 & v6 of the ImageList control

Things we discover when we get bored and ask ourselves, "What if?"

edited: If you are actually considering using this hack, there is one cleanup scenario that needs to be addressed. If the API imagelist is attached but you have not added any images to it yet, VB won't destroy it. Only destroys it if images are added. In that scenario, destroy it manually. Here's an updated routine for the test project + new API. The best logic is to create the 32bpp imagelist just before you add the first image; don't create it just to have it around without a need to immediately add images.

Private Declare Function ImageList_Destroy Lib "comctl32.dll" (ByVal himl As Long) As Long

Private Sub Attach32bitImageList(ImageListObject As Control, _
                                ByVal Width As Long, ByVal Height As Long, _
                                Optional ByVal Flags As Long = 0)
                                
    ' Optional hack to force ImageList to use 32bpp. If you opt for this, then
    ' 1. Passed ImageList must not have images already assigned
    ' 2. The passed Width,Height should be the same else really bad scaling occurs
    ' 3. Any images you add later must NOT be in PARGB format
    ' 4. Any images should be pre-scaled to ImageList Width,Height else bad scaling
    
    ' 32bpp ImageList accepts high quality icons and bitmaps with ARGB alpha channels
                                
    If ImageListObject Is Nothing Then Exit Sub
    If TypeName(ImageListObject) <> "ImageList" Then Exit Sub
    
    Dim hImageList As Long
    Const OFFSET_HIMGLST = 24&
    
    With ImageListObject
        If .ListImages.Count = 0 Then
            If .hImageList <> 0 Then ImageList_Destroy .hImageList
            If Width > 0 And Height > 0 Then
                .ImageWidth = Width: .ImageHeight = Height
                hImageList = ImageList_Create(Width, Height, Flags Or &H20, 0, 0)
            End If
            CopyMemory ByVal ((ObjPtr(.object) Xor &H80000000) + OFFSET_HIMGLST) Xor &H80000000, hImageList, 4
        End If
    End With
    
End Sub

[fafalone]

Interesting, so if I'm interpreting this right, the ImageList control is just wrapping a normal API-type imagelist that was just created at a lower color flag than ILC_COLOR32, so you simply overwrite that pointer to a new one supporting that depth?

Cool stuff.

[LaVolpe]

Correct. But it doesn't behave like you would like, especially for scaling. Hence the limitations I mentioned. It does appear to be destroyed properly, as repeated runs within a manifested IDE shows the pointer being re-used on occasion.

But to be clear, overwriting a null pointer. The reason the code comments state that no images can exist in the ImageList beforehand is so that we don't overwrite an active pointer. The value at the 24th btye offset will be zero if no images exist beforehand.

[baka]

too bad we can only add square pictures (like 400x400, 1280x1280?)
I dont understand what "no images can exist in the ImageList beforehand" means. if I add images, and save it, next time I start the project, the images will be inside the imagelist, or it need to be empty and added before compiled?

can we add a "png" 32bit picture to the list, and later use it for GDI/GDI+/WIC?

what I would really like is if we did have a "filelist" container. we can add pictures, textfiles, mp3, well whatever file and use the filelist to add all files, and later use it like a stream,
similar to the resource editor.

[LaVolpe]

A resource file can be used to store images. Non-square images just render badly with this hack. It isn't that difficult to place a non-square image into a square image -- just center non-square into larger square. If you don't want to use a resource file, you can always cache your existing imagelist pictures to an array, clear the imagtelist, create the 32bpp ImageList, then add them back. Just an idea.

Empty the imagelist first, otherwise the routine will reject the passed imagelist (see code, it checks for .ListImages.Count = 0.

PNGs. Sure, but they'll needed to be converted to ARGB bitmap first. GDI+ can transfer the bits to a DIB and you'd wrap the DIB in a stdPicture object using OleCreatePictureIndirect. Then add the stdPicture to the imagelist.

[LeandroA]

perfect, try this old routine that added png to an imagelist and now with this trick the white background is removed.

http://leandroascierto.com/blog/png-en-un-imagelist/

[LeandroA]

the images do not distort even if they are not square

[LeandroA]

When you find the time, try my sample project and tell me what I'm doing wrong

The comctl32.dll does not resize images, the problem is that COMCTL32.OCX and MSCOMCTL.OCX use some internal function to do this and this has its failures, almost the same as when we use StretchBlt without SetStretchBltMode the image is distorted, my advice would be that you Stretch the image before passing it to the imagelist, just as I do in the link I shared.

http://leandroascierto.com/blog/png-en-un-imagelist/

[LaVolpe]

can we add a "png" 32bit picture to the list, and later use it for GDI/GDI+/WIC?

Updated: Enhanced to allow passing array of bytes or a file name

Here is a GDI+ solution to load any GDI+ supported image format into an ARGB 32bpp bitmap and return a stdPicture object from that 32bpp bitmap. Do note that unfilled transparency will be rendered as black. Code that knows how to recognize transparency in bitmaps will render transparency correctly.

Lots of APIs when using GDI+

Private Declare Function GdipCreateBitmapFromScan0 Lib "GdiPlus.dll" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, BITMAP As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long
Private Declare Function GdipDrawImageRectRectI Lib "GdiPlus.dll" (ByVal hGraphics As Long, ByVal hImage As Long, ByVal DstX As Long, ByVal DstY As Long, ByVal DstWidth As Long, ByVal DstHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal Callback As Long, ByVal callbackData As Long) As Long
Private Declare Function GdipGetImageBounds Lib "GdiPlus.dll" (ByVal nImage As Long, srcRect As Any, srcUnit As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "GdiPlus.dll" (ByVal pImage As Long, ByRef graphics As Long) As Long
Private Declare Function GdipGraphicsClear Lib "GdiPlus.dll" (ByVal graphics As Long, ByVal pColor As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal File As Long, Image As Long) As Long
Private Declare Function GdipLoadImageFromStream Lib "GdiPlus.dll" (ByVal Stream As Long, Image As Long) As Long
Private Declare Function GdiplusShutdown Lib "GdiPlus.dll" (Token As Long) As Long
Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (Token As Long, inputbuf As Any, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipSetInterpolationMode Lib "GdiPlus.dll" (ByVal hGraphics As Long, ByVal Interpolation As Long) As Long
Private Declare Function GdipGetImageType Lib "GdiPlus.dll" (ByVal hImage As Long, ByRef nType As Long) As Long

Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hDC As Long, ByRef pBitmapInfo As Any, ByVal un As Long, ByRef lplpVoid As Long, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (lpPictDesc As Any, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long

Private Function GDIplusToStdPictureARGB(Source As Variant, _
                        ByVal Width As Long, ByVal Height As Long, _
                        Optional ByVal bStretch As Boolean = False) As IPicture
                        
    ' Source: either a file name or 1D byte array
    ' Width,Height: size of returned stdPicture (in pixels)
    ' bStretch:
    '   True = image is stretched to Width,Height
    '   False = image is scaled & centered within Width,Height
    
    Dim aStruct(0 To 10) As Long, oStream As stdole.IUnknown
    ' ^^ used for GUID,BITMAPINFO,PICDESC,GDI+Startup structures
    Dim fBounds(0 To 3) As Single, aData() As Byte
    Dim X As Long, Y As Long, Cx As Long, Cy As Long
    Dim sngRatio1 As Single, sngRatio2 As Single
    Dim tDC As Long, hDib As Long, pBits As Long, lValue As Long
    Dim hGraphics As Long, hHandle As Long
    Dim hToken As Long, hDstHandle As Long
    Const PixelFormat32bppARGB = &H26200A
    Const UNIT_PIXELS = 2&

    aStruct(0) = 1
    GdiplusStartup hToken, aStruct(0)
    If hToken = 0 Then
        Stop ' gdi+ failed to load
        Exit Function
    End If
    
    ' load from file or create stream & load from that
    If VarType(Source) = vbString Then
        GdipLoadImageFromFile StrPtr(Source), hHandle
    ElseIf VarType(Source) = (vbArray Or vbByte) Then
        On Error Resume Next
        aData() = Source
        Cx = Abs(UBound(aData) - LBound(aData) + 1)
        On Error GoTo 0 ' passed unitialized array?
        If Cx > 0 Then
            hDstHandle = GlobalAlloc(&H2&, Cx)
            If hDstHandle <> 0 Then
                lValue = GlobalLock(hDstHandle)
                If lValue <> 0 Then
                    CopyMemory ByVal lValue, aData(LBound(aData)), Cx
                    GlobalUnlock hDstHandle
                    CreateStreamOnHGlobal hDstHandle, 1&, oStream
                End If
                If oStream Is Nothing Then
                    GlobalFree hDstHandle
                Else
                    GdipLoadImageFromStream ObjPtr(oStream), hHandle
                End If
                hDstHandle = 0
            End If
        End If
        Erase aData()
    End If
    
    If hHandle <> 0 Then    ' else GDI+ failed to load the image
        GdipGetImageType hHandle, lValue
        If lValue = 1 Then ' else not a bitmap-type item (metafile for example)
            GdipGetImageBounds hHandle, fBounds(0), lValue
            ' calculate scale & centering if not stretching
            If bStretch = False Then
                sngRatio1 = Width / fBounds(2)
                sngRatio2 = Height / fBounds(3)
                If sngRatio1 > sngRatio2 Then sngRatio1 = sngRatio2
                Cx = fBounds(2) * sngRatio1: Cy = fBounds(3) * sngRatio1
                X = (Width - Cx) \ 2: Y = (Height - Cy) \ 2
            Else
                Cx = Width: Cy = Height: X = 0: Y = 0
            End If
            tDC = GetDC(0)      ' create 32bpp DIB at requested size
            aStruct(0) = 40: aStruct(1) = Width
            aStruct(2) = Height: aStruct(3) = &H200001
            hDib = CreateDIBSection(tDC, aStruct(0), 0, pBits, 0, 0)
            ReleaseDC 0, tDC
            If hDib <> 0 Then
                ' overlay GDI+ handle onto DIB, bottom-up
                lValue = Width * 4 ' DIB scanwidth
                pBits = ((pBits Xor &H80000000) + lValue * (Height - 1)) Xor &H80000000
                GdipCreateBitmapFromScan0 Width, Height, -lValue, PixelFormat32bppARGB, ByVal pBits, hDstHandle
                If hDstHandle <> 0 Then ' draw PNG from GDI+ to GDI+
                    ' when rendering this way, we are actually drawing into the DIB
                    GdipGetImageGraphicsContext hDstHandle, hGraphics
                    GdipGraphicsClear hGraphics, 0
                    GdipSetInterpolationMode hGraphics, 7 ' high quality
                    GdipDrawImageRectRectI hGraphics, hHandle, X, Y, Cx, Cy, fBounds(0), fBounds(1), fBounds(2), fBounds(3), UNIT_PIXELS, 0, 0, 0
                    GdipDeleteGraphics hGraphics    ' clean up
                    GdipDisposeImage hDstHandle
                
                    ' create VB picture from handle
                    aStruct(0) = 16: aStruct(1) = vbPicTypeBitmap
                    aStruct(2) = hDib: aStruct(3) = 0
                    ' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
                    aStruct(4) = &H7BF80980: aStruct(5) = &H101ABF32
                    aStruct(6) = &HAA00BB8B: aStruct(7) = &HAB0C3000
                    ' create stdPicture
                    OleCreatePictureIndirect aStruct(0), aStruct(4), True, GDIplusToStdPictureARGB
                Else
                    DeleteObject hDib
                End If
            End If
        End If
        GdipDisposeImage hHandle  ' cleanup & release file/stream
    End If
    GdiplusShutdown hToken
    
End Function

Sample usages:

Set Image1.Picture = GDIplusToStdPictureARGB([file path/name], 32, 32)
ImageList1.ListImages.Add , , GDIplusToStdPictureARGB([file path/name], 32, 32)
ImageList1.ListImages.Add , , GDIplusToStdPictureARGB(LoadResData(101, "CUSTOM"), 32, 32)

edited: If you want to fill the picture's transparency with a specific color
change from: GdipGraphicsClear hGraphics, 0
to: GdipGraphicsClear hGraphics, Color Or &HFF000000 ' ensure color is BGR not RGB
may want to add a FillColor parameter to the function?

Sometimes PARGB (premultiplied pixels) can be used in other APIs. If so, you can tweak the function to ensure that format is returned by replacing the pixel format in the call to GdipCreateBitmapFromScan0 as: Format32bppPARGB (&HE200B)