[vb6] Icon Handle to File/Array

I've seen a few posts since I offered this code this time last year. So instead of it hiding in some user's thread, I think it is more suited here.

Here is a good routine to save icon handles to file.
1. It handles 1, 4 , 8, 16, 24 & 32 bit icons. But 16 bit are converted to 24 bit for saving.
2. Note that 32bit alpha icons will not be saved correctly unless running XP or better; nor will the hIcon display correctly anyway.
3. If successful, the passed array to the function will contain the icon in correct image/file format. Just save the array to a file.

Too long to post, so download from attachment. Add the code to a form, module, usercontrol, or class as desired.

Let me comment on #2 above. The reason you might get poor quality is rather simple. You may be running Windows 2000 and you extracted an icon or retrieved a handle to an icon that is 32bpp. Only on XP and higher will those icons display properly. Since the attached code is getting the icon image from handle, what you see is what you get. If the icon is not displayed properly by the system, the result is also poor quality. Just FYI.

Bonus code: Assign icon from the array directly to a VB picture/icon property without first saving to file. Again, note that VB won't load 32 bpp icons.

Code:

---

' sample call
Private Sub Command1_Click()
    Dim hIconData() As Byte
    ' replace Me.Icon.Handle with the icon handle you want to use
    If SaveHICONtoArray(Me.Icon.Handle, hIconData()) = True Then
        Set Image1.Picture = ArrayToStdPicture(hIconData)
    End If
End Sub

---

The routine and declarations needed for above sample call

Code:

---

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

Public Function ArrayToStdPicture(theArray() As Byte) As IPicture
   
    ' function creates a stdPicture from the passed array
    ' Note: The array was already validated as not empty before this was called
   
    Dim o_hMem  As Long
    Dim o_lpMem  As Long
    Dim aGUID(0 To 3) As Long
    Dim IIStream As IUnknown
   
    aGUID(0) = &H7BF80980    ' GUID for stdPicture
    aGUID(1) = &H101ABF32
    aGUID(2) = &HAA00BB8B
    aGUID(3) = &HAB0C3000
   
    o_hMem = GlobalAlloc(&H2&, UBound(theArray) + 1)
    If Not o_hMem = 0& Then
        o_lpMem = GlobalLock(o_hMem)
        If Not o_lpMem = 0& Then
            CopyMemory ByVal o_lpMem, theArray(0), UBound(theArray) + 1
            Call GlobalUnlock(o_hMem)
            If CreateStreamOnHGlobal(o_hMem, 1&, IIStream) = 0& Then
                  Call OleLoadPicture(ByVal ObjPtr(IIStream), 0&, 0&, aGUID(0), ArrayToStdPicture)
            End If
        End If
    End If

End Function

---

.

And not to abandon or dismiss the version I and most others used for years...

This option requires far less code and works well on paletted icons (256 colors or less). Other than that, not so good. Even with paletted icons, it is possible you won't get the exact same colors as the original icon.

Here's the sample call

Code:

---

Dim tPic As StdPicture
' hIcon = wherever you are getting your icon handle from
Set tPic = HandleToStdPicture(hIcon, vbPicTypeIcon)
SavePicture tPic, "C:\MyIcon.ico"

---

Here's the routine and its declarations

Code:

---

Private Type PictDesc
    Size As Long
    Type As Long
    hHandle As Long
    hPal As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long

Public Function HandleToStdPicture(ByVal hImage As Long, ByVal imgType As Long) As IPicture

    ' function creates a stdPicture object from an image handle (bitmap or icon)
   
    Dim lpPictDesc As PictDesc, aGUID(0 To 3) As Long
    With lpPictDesc
        .Size = Len(lpPictDesc)
        .Type = imgType
        .hHandle = hImage
        .hPal = 0
    End With
    ' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    aGUID(0) = &H7BF80980
    aGUID(1) = &H101ABF32
    aGUID(2) = &HAA00BB8B
    aGUID(3) = &HAB0C3000
    ' create stdPicture
    Call OleCreatePictureIndirect(lpPictDesc, aGUID(0), True, HandleToStdPicture)
   
End Function

---

From the image below you can see what the icon looks like on the left and what VB does to it after saving it and then using LoadPicture to display it. These icons were created with the LoadImage API. From top down, 32 bpp, 24 bpp, 4 bpp (paletted)
Attachment 81941
Side note. The routine above will take 32bpp images, obviously, but VB just won't save or display them correctly. You can use DrawIconEx on the stdPicture.Handle before you save it and it will draw perfectly. The screw up is during the save procedure, for whatever reason.

User defined type not defined error

Code:

---

Private Sub Command1_Click()
    Dim hIconData() As Byte
    ' replace Me.Icon.Handle with the icon handle you want to use
    If SaveHICONtoArray(Me.Icon.Handle, hIconData()) = True Then
        Set Image1.Picture = ArrayToStdPicture(hIconData)
    End If
End Sub


Public Function ArrayToStdPicture(theArray() As Byte) As IPicture
  '
  '
End Function

---

From post #1 with added bonus code

EDIT: Never mind. It was my fault. I didn't have OLE Automation in the reference

Double check for typos. IPicture is a VB class. If you are getting that error, then see if you have declared an object/variable IPicture anywhere in your code. If in doubt about my comment, open a new project and in form_load, simply declare X As IPicture and run the project. No errors. The issue is with your project somewhere.

It works now - see my previous post Edit

All of your examples posted in this thread work

Thanks

Quote:

---

Originally Posted by jmsrickland

All of your examples posted in this thread work

Thanks

---

Please keep in mind that assigning most hIcons to a vb stdPicture will likely produce poor results, if it doesn't error. This is simply because on modern operating systems, hIcon is likely a pretty, alpha blended icon. VB doesn't deal with those well, if at all.

There's another very simple way to draw an .ico file/hIcon into a picturebox preserving the transparency from it being a fancy vista icon. Several other methods didn't preserve the transparency, but this one did, and will actually load the large sizes like 128x128 or 256x256 instead of scaling up 32x32:

Code:

---

Dim sIcon As String, hIcon As Long
Dim hIMLTest As Long
hIMLTest = ImageList_Create(128, 128, ILC_COLOR32, 1, 1)
sIcon = App.Path & "\apphr2.ico"

hIcon = LoadImage(App.hInstance, sIcon, IMAGE_ICON, 128, 128, LR_LOADFROMFILE)

ImageList_AddIcon hIMLTest, hIcon
ImageList_Draw hIMLTest, 0, Picture4.hDC, 0, 0, ILD_NORMAL

Call DestroyIcon(hIcon)
ImageList_Destroy hIMLTest

---

Not entirely sure if it works on XP, but Vista and later work.

Edit: It will also work for hBitmaps but you have to be careful because it will fail if your hBitmap is smaller than the imagelist dimensions.

Code:

---

Public Sub hBitmapToPictureBox(picturebox As Object, hBitmap As Long, Optional x As Long = 0&, Optional y As Long = 0&)
Dim himlBmp As Long
Dim tBMP As BITMAP
Dim cx As Long, cy As Long

Call GetObject(hBitmap, LenB(tBMP), tBMP)
cx = tBMP.bmWidth
cy = tBMP.bmHeight
If cx = 0 Then Exit Sub

himlBmp = ImageList_Create(cx, cy, ILC_COLOR32, 1, 1)

ImageList_Add himlBmp, hBitmap, 0&
ImageList_Draw himlBmp, 0, picturebox.hDC, x, y, ILD_NORMAL

ImageList_Destroy himlBmp
End Sub

---

If the goal is to just draw the icon, DrawIconEx works like a champ and you don't need to create an imagelist. The gist of this thread was saving an hIcon (can have come from anywhere) to file/array without losing quality.

P.S. Not 100% sure, but doesn't usage of ILC_COLOR32 require manifesting?

Yeah I had just wanted to show that method since a lot of the time the icons you're using are from an imagelist, and can draw it like that instead of having to first get an hIcon from the imagelist. For hBitmaps I don't think there's an easier way anyway; CreateCompatibleDC/SelectObject/BitBlt resulted in no transparency.

ILC_COLOR32 isn't listed in the 5.0 or 6.0 sections of the enum on commctrl.h, so it should be there without a manifest.