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
.
Insomnia is just a byproduct of, "It can't be done"
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)
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.
Insomnia is just a byproduct of, "It can't be done"
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
Last edited by jmsrickland; Sep 7th, 2015 at 02:05 PM.
Anything I post is an example only and is not intended to be the only solution, the total solution nor the final solution to your request nor do I claim that it is. If you find it useful then it is entirely up to you to make whatever changes necessary you feel are adequate for your purposes.
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.
Insomnia is just a byproduct of, "It can't be done"
Anything I post is an example only and is not intended to be the only solution, the total solution nor the final solution to your request nor do I claim that it is. If you find it useful then it is entirely up to you to make whatever changes necessary you feel are adequate for your purposes.
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.
Insomnia is just a byproduct of, "It can't be done"
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
Last edited by fafalone; Sep 7th, 2015 at 07:30 PM.
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?
Insomnia is just a byproduct of, "It can't be done"
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.