I have ImageList1 loaded with icons during design time. When I run my app I extract the pictures from the ImageList control and save them the disk.
Code:
For n = 1 To 10
Picture1.Picture = ImageList1.ListImages(n).Picture
SavePicture Picture1.Picture, App.Path & "\PIC(" & n & ").bmp"
Next
Each time through the loop Picture1 shows the correct image and the bitmap file is created
However, when I try to open each PIC(n).bmp I get an error message:
Paint cannot read this file. This is not a valid bitmap file, or its format
is not currently supported.
Anyone know what's going on here?
Last edited by jmsrickland; Mar 2nd, 2016 at 01:47 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.
If I save Picture1.Image as a bitmap (.bmp) the quality is terrible and if I pre-load the ImageList control with these bitmaps then I can't use them in my program as they do not appear on a menu subitem when I try to add them using code.
If I save Picture1.Picture as an icon (.ico) then when I try to open them with Windows Picture and Fax Viewer they have no valid picture - I get "No preview available" message
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.
What about ImageList hBitmap -> GdipHBITMAPtoBITMAP -> save via
Code:
Public Function gdipImgToFileBMP(hImg As Long, sOut As String) As Long
Dim encoderCLSID As CLSIDG
Call GetEncoderClsid("image/bmp", encoderCLSID)
GdipSaveImageToFile hImg, StrConv(sOut, vbUnicode), encoderCLSID, ByVal 0&
End Function
Icons are easier... ImageList_GetIcon gives you an hIcon, savable via:
Code:
Public Function SaveIconToFile(ByVal hIcon As Long, ByVal Filename As String) As Boolean
If hIcon = 0 Then Exit Function
If Filename = vbNullString Then Exit Function
Dim Bits() As Long, icoBits() As Byte, pow2(0 To 8) As Long
Dim scanWidth As Long, maskScan As Long, clrScan As Long
Dim bNewColor As Boolean
Dim X As Long, Y As Long, palIndex As Long, palShift As Long, palPtr As Long
Dim ICI As modRename.ICONINFO, BHI As BITMAPINFO
Dim hDC As Long
If GetIconInfo(hIcon, ICI) = 0& Then Exit Function
hDC = GetDC(0&)
If ICI.hbmColor = 0& Then
' black and white image, already in needed format
BHI.bmiHeader.biSize = 40
If GetDIBits(hDC, ICI.hbmMask, 0&, 0&, ByVal 0&, BHI, 0&) Then
BHI.bmiColors(2) = vbWhite
With BHI.bmiHeader
maskScan = ByteAlignOnWord(1, .biWidth)
.biBitCount = 1
.biClrImportant = 2
.biClrUsed = 2
.biCompression = 0&
.biSizeImage = maskScan * .biHeight
ReDim icoBits(0 To .biSizeImage + 69&)
If GetDIBits(hDC, ICI.hbmMask, 0&, .biHeight, icoBits(70), BHI, 0&) Then
DeleteObject ICI.hbmMask: ICI.hbmMask = 0&
.biClrImportant = 2&
.biClrUsed = 2&
icoBits(8) = .biClrUsed
icoBits(2) = 1 ' type: icon
icoBits(4) = 1 ' count
If .biWidth < 256 Then icoBits(6) = .biWidth
If .biHeight < 512 Then icoBits(7) = .biHeight \ 2
icoBits(10) = 1 ' planes
icoBits(12) = .biBitCount
CopyMemory icoBits(14), CLng(UBound(icoBits) - 21&), 4& ' bytes in resource
icoBits(18) = 22 ' offset into directory where BHI starts
CopyMemory icoBits(icoBits(18)), BHI, 48&
SaveIconToFile = True
End If
End With
End If
Else
BHI.bmiHeader.biSize = 40
If GetDIBits(hDC, ICI.hbmColor, 0&, 0&, ByVal 0&, BHI, 0&) Then
With BHI.bmiHeader
scanWidth = .biWidth * 4&
maskScan = ByteAlignOnWord(1, .biWidth)
.biBitCount = 32&
.biSize = 40
.biCompression = 0&
.biSizeImage = scanWidth * .biHeight
ReDim Bits(0 To .biWidth * .biHeight - 1&)
End With
If GetDIBits(hDC, ICI.hbmColor, 0&, BHI.bmiHeader.biHeight, Bits(0), BHI, 0&) Then
DeleteObject ICI.hbmColor: ICI.hbmColor = 0&
With BHI.bmiHeader
For X = 0& To .biWidth * .biHeight - 1&
If Bits(X) <> (Bits(X) And &HFFFFFF) Then
.biClrImportant = 0&
Exit For
End If
If .biBitCount = 32 Then
palIndex = FindColor(BHI.bmiColors(), Bits(X), .biClrImportant, bNewColor)
If bNewColor Then
If .biClrImportant = 256& Then ' either 24 bit or 32 bit icon
.biBitCount = 24
.biClrImportant = 0&
ElseIf bNewColor Then
.biClrImportant = .biClrImportant + 1
If palIndex < .biClrImportant Then
CopyMemory BHI.bmiColors(palIndex + 1&), BHI.bmiColors(palIndex), (.biClrImportant - palIndex) * 4&
End If
BHI.bmiColors(palIndex) = Bits(X)
End If
End If
End If
Next
End With
If BHI.bmiHeader.biClrImportant Then
With BHI.bmiHeader
Select Case .biClrImportant
'Case Is < 3: .biBitCount = 1 ' no't work good :/
Case Is < 17: .biBitCount = 4
Case Else: .biBitCount = 8
End Select
pow2(0) = 1&
For X = 1& To .biBitCount
pow2(X) = pow2(X - 1&) * 2&
Next
clrScan = ByteAlignOnWord(.biBitCount, .biWidth)
.biClrUsed = pow2(.biBitCount)
.biSizeImage = clrScan * .biHeight
ReDim icoBits(0 To .biSizeImage + maskScan * .biHeight + .biClrUsed * 4& + 61&)
X = 0&
For Y = X To .biHeight - 1&
palShift = 8& - .biBitCount
palPtr = 62& + .biClrUsed * 4& + Y * clrScan
For X = X To X + .biWidth - 1&
palIndex = FindColor(BHI.bmiColors(), Bits(X), .biClrImportant, bNewColor) - 1&
icoBits(palPtr) = icoBits(palPtr) Or (palIndex * pow2(palShift))
If palShift = 0& Then
palPtr = palPtr + 1&
palShift = 8& - .biBitCount
Else
palShift = palShift - .biBitCount
End If
Next
Next
If .biClrUsed < 256 Then icoBits(8) = .biClrUsed
End With
Else ' can be 24 or 32 bit color
With BHI.bmiHeader
clrScan = ByteAlignOnWord(.biBitCount, .biWidth)
.biSizeImage = clrScan * .biHeight
ReDim icoBits(0 To .biSizeImage + maskScan * .biHeight + 61&)
If .biBitCount = 32 Then
CopyMemory icoBits(62), Bits(0), .biSizeImage
Else
X = 0&
For Y = X To .biHeight - 1&
palPtr = Y * clrScan + 62&
For X = X To .biWidth - 1&
CopyMemory icoBits(palPtr), Bits(X), 3&
palPtr = palPtr + 3&
Next
Next
End If
End With
End If
Erase Bits()
icoBits(2) = 1 ' type: icon
icoBits(4) = 1 ' count
If BHI.bmiHeader.biWidth < 256 Then icoBits(6) = BHI.bmiHeader.biWidth
If BHI.bmiHeader.biHeight < 256 Then icoBits(7) = BHI.bmiHeader.biHeight
BHI.bmiHeader.biHeight = BHI.bmiHeader.biHeight + BHI.bmiHeader.biHeight
icoBits(10) = 1 ' planes
icoBits(12) = BHI.bmiHeader.biBitCount
CopyMemory icoBits(14), CLng(UBound(icoBits) - 21&), 4& ' bytes in resource
icoBits(18) = 22 ' offset into directory where BHI starts
CopyMemory icoBits(icoBits(18)), BHI, BHI.bmiHeader.biClrUsed * 4& + 40&
If ICI.hbmMask Then
BHI.bmiColors(2) = vbWhite
With BHI.bmiHeader
.biBitCount = 1
.biClrImportant = 2
.biClrUsed = 2
.biHeight = .biHeight \ 2
.biSizeImage = 0&
palPtr = UBound(icoBits) - maskScan * .biHeight + 1&
End With
GetDIBits hDC, ICI.hbmMask, 0&, BHI.bmiHeader.biHeight, icoBits(palPtr), BHI, 0&
DeleteObject ICI.hbmMask: ICI.hbmMask = 0&
End If
SaveIconToFile = True
End If
End If
End If
If ICI.hbmColor Then DeleteObject ICI.hbmColor
If ICI.hbmMask Then DeleteObject ICI.hbmMask
ReleaseDC 0&, hDC
If SaveIconToFile Then
Open Filename For Binary As #1
Put #1, 1, icoBits()
Close #1
End If
End Function
Last edited by fafalone; Feb 27th, 2016 at 06:48 PM.
Why keep them in an ImageList, in the first place, if the intention is to extract them from there and save them to disk? Maybe just keep them on disk in the first place and load them from there as and when. Or put them in a resource file if you'd rather 'hide' them...
If you don't know where you're going, any road will take you there...
Sounds like JM is saving icons with a bitmap extension. Since XP Paint & PicFax viewer don't do icons, if I recall correctly, the likely reason for them reporting invalid/unknown format.
When in doubt, check the .Type property of the picture object. It will return the image format which is the format VB will attempt to save to disk as. VB does a poor job saving icons and having a good icon-handle (HICON) to bitmap routine is key.
P.S. The .Image property of a VB object (picturebox, form, etc) always saves as bitmap, i.e., Picture1.Image.Type returns vbPicTypeBitmap
Last edited by LaVolpe; Feb 28th, 2016 at 03:17 PM.
Insomnia is just a byproduct of, "It can't be done"
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
Yes it does. I do a lot of icon viewing using this application.
Last edited by jmsrickland; Feb 29th, 2016 at 02:11 AM.
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.
I don't put images in an ImageList control just to turn around and extract them to disk. This was just a test I was doing because I loaded an ImageList with system icons during run time and then tried to use them as menu sub item images which didn't work so I then thought to save these to disk from the ImageList and make bitmaps out of them since I found out later I can't use icons for menu items with the APIs I was using; only bitmaps worked. Well it turned out that when I made bitmaps out of these icons they turned out terrible so then I tried to extract the icon out of the ImageList but they didn't turn out to be valid icons so I just gave up on this so actually this thread can be marked as closed but unresolved.
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.
Well I'm not sure what your "quality" problems were, but it sounds like you don't really need to save bitmaps anyway.
Maybe this is close to what you are after? It is a little crude since it was quickly cobbled together from existing modules but it might have the pieces and parts you need.
Note that as written it requires a Form-scope instance of the MenuBitmaps class to hang around because it caches the menu hBITMAP values until it is destroyed, normally when the Form unloads. If this instance goes away early you lose the menu bitmaps.
The ImageList control uses: bitmap (.gif), cursor (.cur), icon (.ico), JPEG (.jpg), or GIF (.gif) files.
You need advanced code to extract the correct image format from FRX file (where graphics are stored in binary format).
Brad Martinez (MVPS) has developed a good example of this.
Unfortunately his website seem to be no longer available, but you can get there using Internet Archive WayBack Machine.
jms if you want to use system imagelist images, use the clsMenuImage class, and then .AddIconFromHandle with the SHFILEINFO.hIcon from SHGetFileInfo.
Yes, that is now what I am doing. I saw you other post and downloaded those two examples.
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.
Well I'm not sure what your "quality" problems were, but it sounds like you don't really need to save bitmaps anyway.
Maybe this is close to what you are after? It is a little crude since it was quickly cobbled together from existing modules but it might have the pieces and parts you need.
Note that as written it requires a Form-scope instance of the MenuBitmaps class to hang around because it caches the menu hBITMAP values until it is destroyed, normally when the Form unloads. If this instance goes away early you lose the menu bitmaps.
It doesn't use any ImageList controls at all.
I downloaded your example. On my PC it shows the images as tiny images, like about 13 x 13 but your picture shows them more like 16 x 16 and also the images are sitting next to the captions where they actually touch the first letter of the caption and the images and text are centered in the menu, not left justified like it should be. I haven't yet looked into the code so I don't know what/where/why I have this problem.
EDIT
This is strange. I looked at the code and I see it uses small icons:
Code:
Private Const SHGFI_SMALLICON As Long = &H1& '16x16 pixels.
Public Enum ICON_SIZES
iszLarge = SHGFI_LARGEICON
iszSmall = SHGFI_SMALLICON
iszShell = SHGFI_SHELLICONSIZE
End Enum
but I have used SHGFI_SMALLICON in another project and the icons came out 16 x 16 but in this example they are 13 x 13
EDIT AGAIN:
I found this in the code
Code:
Public Function HIconToMenuHBitmap(ByVal Form As Form, ByVal hIcon As Long) As Long
Dim RECT As RECT
Dim hCompatDc As Long
With RECT
.Right = GetSystemMetrics(SM_CXMENUCHECK)
.Bottom = GetSystemMetrics(SM_CYMENUCHECK)
'
'
'
End Function
Where .Right and .Bottom have 13 as their values. Should be 16
EDIT AGAIN:
Unfortunately, although I would have liked to have been able to use this example even if I got the size and positioning corrected there remains another issue which I don't like. As you drag the mouse over each item and it is highlighted the images get inverted which doesn't look good.
Last edited by jmsrickland; Feb 29th, 2016 at 01:08 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.
You need advanced code to extract the correct image format from FRX file (where graphics are stored in binary format).
Brad Martinez (MVPS) has developed a good example of this.
Unfortunately his website seem to be no longer available, but you can get there using Internet Archive WayBack Machine.
and download this sample project: GfxFromFrx 12/08/99 How to extract graphics from VB binary property files
I'm not wanting to extract images from the .FRX file. I'm getting icons that are associated with certain files using some code I get here from another thread several weeks backs.
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.
Unfortunately, although I would have liked to have been able to use this example even if I got the size and positioning corrected there remains another issue which I don't like. As you drag the mouse over each item and it is highlighted the images get inverted which doesn't look good.
The inversion only seems to occur in a session that isn't using Desktop Composition.
Note As of Windows 8, the information in this section is no longer valid. DWM can no longer be programmatically disabled, nor is it disabled when an application attempts to draw to the primary display surface. The following information applies to only Windows 7 and earlier systems.
Application-defined bitmaps associated with a menu item must be the same size as the default check mark bitmap, the dimensions of which may vary depending on screen resolution. To retrieve the correct dimensions, use the GetSystemMetrics function. You can create multiple bitmap resources for different screen resolutions; create one bitmap resource and scale it, if necessary; or create a bitmap at run time and draw an image in it. The bitmaps may be either monochrome or color. However, because menu items are inverted when highlighted, the appearance of certain inverted color bitmaps may be undesirable.
So in light of those requirements you're sort of screwed as far as I can tell on an unsupported OS or one that doesn't support Desktop Composition. I was able to reproduce this issue on both Windows XP and Windows Home Server 2011 which is based on Windows Server 2008 R2 (which shares the Windows 7 codebase but normally uses a "classic" theme without Desktop Composition).
But Windows 10 had no problem and making the program DPI Aware resulted in proper scaling of these images as well:
Note that the Desktop Window Manager (Desktop Composition) results in a non-inverted "cutout" for the bitmaps even when they're highlighted... which on Win 10 are back to a primitive flat look like the Win 10 UI in general.
I'm not saying workarounds don't exist but from what I read at MSDN these are just the facts of life.
Thanks, everyone for all your help and suggestions. I learned a lot from this
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.
Re: [RESOLVED] Can't save images from ImageList control
For what it's worth:
I made a change to use 32bpp Alpha images, and while there I found and fixed some minor bugs including a handle leak. I also added support for a CC6 manifest though the demo doesn't have anything but a menu. Just as well since you'd normally want that as well as other things like DPI Aware, Vista Aware, Win7 Aware, and perhaps additional "awareness" compatibility mark nodes as well.
I haven't included a manifest in the attachment though.
Now on Windows 10 there isn't any background "cutout" though on XP or WHS the same issues exist as before. I assume that clsMenuImage thing is subclassing the Form to do owner drawn menus? Sounds that way from what I read on the guy's blog.
I assume you are all set now but perhaps this would help anyone that might be led astray by my earlier sample code. It does not subclass and owner-draw so the issues remain on XP or other platforms where there is no active DWM.
Re: [RESOLVED] Can't save images from ImageList control
Same issue but worse for XP
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.
Re: [RESOLVED] Can't save images from ImageList control
Funny there isn't something more explicit about when menu bitmaps require owner drawn mode, but I sure can't find anything.
I think I'd use normal subclassing techniques rather than binary code injection though. Seems like the sort of thing that will result in antivirus false positives to me.
I downloaded your example. On my PC it shows the images as tiny images, like about 13 x 13 but your picture shows them more like 16 x 16 and also the images are sitting next to the captions where they actually touch the first letter of the caption and the images and text are centered in the menu, not left justified like it should be. I haven't yet looked into the code so I don't know what/where/why I have this problem.
This really all comes down to how menus worked back in the olden times. XP is limited to monochrome menu bitmaps unless you owner-draw, due to the inversion when highlighted. It also used two positions for the check/uncheck and secondary bitmaps:
In the post-XP era "checked" has a different meaning, i.e. "selected." If you don't use a secondary bitmap you get a checkmark, but when you do the secondary bitmap is displayed as a "pressed button" as in:
Because Windows now combines these there is no need for the "extra room" for the checked/unchecked bitmap.
Re: [RESOLVED] Can't save images from ImageList control
BTW:
After looking at a few MS KB articles on alpha icons and such I think I have the icon-to-bitmap-with-alpha working correctly now even on Windows XP using only GDI:
// The following mask specification specifies a supported 32 BPP
// alpha format for Windows XP.
bi.bV5RedMask = 0x00FF0000;
bi.bV5GreenMask = 0x0000FF00;
bi.bV5BlueMask = 0x000000FF;
bi.bV5AlphaMask = 0xFF000000;
Of course that does nothing about the other XP issues such as inversion on highlight, tiny menu bitmap size, etc. but hey at least it's half the battle:
Code:
Public Function HIconToMenuHBitmap(ByVal Form As Form, ByVal hIcon As Long) As Long
Dim Width As Long
Dim Height As Long
Dim BITMAPINFO As BITMAPINFO
Dim hCompatDC As Long
Dim lpBits As Long
Dim hBitmapOrig As Long
Dim hBrushOrig As Long
Width = GetSystemMetrics(SM_CXMENUCHECK)
Height = GetSystemMetrics(SM_CYMENUCHECK)
With BITMAPINFO.bmiHeader
.bV5Size = LenB(BITMAPINFO.bmiHeader)
.bV5Width = Width
.bV5Height = Height
.bV5Planes = 1
.bV5BitCount = 32
.bV5Compression = BI_BITFIELDS
.bV5RedMask = &HFF0000
.bV5GreenMask = &HFF00&
.bV5BlueMask = &HFF&
.bV5AlphaMask = &HFF000000
End With
hCompatDC = CreateCompatibleDC(Form.hDC)
HIconToMenuHBitmap = CreateDIBSection(hCompatDC, BITMAPINFO, DIB_RGB_COLORS, lpBits)
hBitmapOrig = SelectObject(hCompatDC, HIconToMenuHBitmap)
hBrushOrig = SelectObject(hCompatDC, hBrushMenuColor)
PatBlt hCompatDC, 0, 0, Width, Height, PATCOPY
DrawIconEx hCompatDC, 0, 0, hIcon, Width, Height, 0, 0, DI_NORMAL
SelectObject hCompatDC, hBrushOrig
SelectObject hCompatDC, hBitmapOrig
DeleteDC hCompatDC
CreatedHBmps.Add HIconToMenuHBitmap
End Function
This version includes the manifest for CC6, DPI-aware, Vista-aware, and Win7-aware.
Re: [RESOLVED] Can't save images from ImageList control
One thing I'm unsure of is who deallocates the memory CreateDIBSection() creates, at pointer lpBits above. So I may have a memory leak here.
Maybe a graphics guy with a lot more GDI experience knows that answer to that. But as far as I can tell destroying the DIBSection later (DeleteObject) takes care of it.
Re: [RESOLVED] Can't save images from ImageList control
Your last example turns out to be the same as your first example. I made it 16 x 16 (instead of the 13, x 13) by just hard coding Width and Height
Code:
Public Function HIconToMenuHBitmap(ByVal Form As Form, ByVal hIcon As Long) As Long
Dim Width As Long
Dim Height As Long
Dim BITMAPINFO As BITMAPINFO
Dim hCompatDC As Long
Dim lpBits As Long
Dim hBitmapOrig As Long
Dim hBrushOrig As Long
Width = GetSystemMetrics(SM_CXMENUCHECK)
Height = GetSystemMetrics(SM_CYMENUCHECK)
Width = 16
Height = 16
'
'
and I corrected the image too close to caption issue by just adding a space in front of the captions using the menu editor
Now, after all the work I have gone through putting a working model together to get it to behave the way I need (see my post #21) it appears it was all for nothing as I can't use any of these examples because I need this for a PopupMenu and when I make the main menu invisible the images no longer appear in the submenu which is my popup menu
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.
I'm not sure it is "the same as" the first one - even in appearance, on dead old XP. In any case the rendering from hIcon to alpha hBitmap is now being done "correctly" as far as I can tell.
The other things like the size, "position" and inverting are just the way things work. Until Vista you should be using monochrome bitmaps, bitmaps of that tiny size (i.e. the system menu bitmap size), and not step on the checkmark bitmap... otherwise you should owner-draw your menus.
You'll probably want to test your deviant menus on other OSs or you may be in for a shock later when you finally leave the year 2001 behind.
As for popup menus, I have a workaround for that too. I think it has been around for quite a long time but until now I never needed it so I had to do some Googling. Sort of a hack but it seems to work:
What about ImageList hBitmap -> GdipHBITMAPtoBITMAP -> save via
Code:
Public Function gdipImgToFileBMP(hImg As Long, sOut As String) As Long
Dim encoderCLSID As CLSIDG
Call GetEncoderClsid("image/bmp", encoderCLSID)
GdipSaveImageToFile hImg, StrConv(sOut, vbUnicode), encoderCLSID, ByVal 0&
End Function
Icons are easier... ImageList_GetIcon gives you an hIcon, savable via:
Code:
Public Function SaveIconToFile(ByVal hIcon As Long, ByVal Filename As String) As Boolean
If hIcon = 0 Then Exit Function
If Filename = vbNullString Then Exit Function
Dim Bits() As Long, icoBits() As Byte, pow2(0 To 8) As Long
Dim scanWidth As Long, maskScan As Long, clrScan As Long
Dim bNewColor As Boolean
Dim X As Long, Y As Long, palIndex As Long, palShift As Long, palPtr As Long
Dim ICI As modRename.ICONINFO, BHI As BITMAPINFO
Dim hDC As Long
If GetIconInfo(hIcon, ICI) = 0& Then Exit Function
hDC = GetDC(0&)
If ICI.hbmColor = 0& Then
' black and white image, already in needed format
BHI.bmiHeader.biSize = 40
If GetDIBits(hDC, ICI.hbmMask, 0&, 0&, ByVal 0&, BHI, 0&) Then
BHI.bmiColors(2) = vbWhite
With BHI.bmiHeader
maskScan = ByteAlignOnWord(1, .biWidth)
.biBitCount = 1
.biClrImportant = 2
.biClrUsed = 2
.biCompression = 0&
.biSizeImage = maskScan * .biHeight
ReDim icoBits(0 To .biSizeImage + 69&)
If GetDIBits(hDC, ICI.hbmMask, 0&, .biHeight, icoBits(70), BHI, 0&) Then
DeleteObject ICI.hbmMask: ICI.hbmMask = 0&
.biClrImportant = 2&
.biClrUsed = 2&
icoBits(8) = .biClrUsed
icoBits(2) = 1 ' type: icon
icoBits(4) = 1 ' count
If .biWidth < 256 Then icoBits(6) = .biWidth
If .biHeight < 512 Then icoBits(7) = .biHeight \ 2
icoBits(10) = 1 ' planes
icoBits(12) = .biBitCount
CopyMemory icoBits(14), CLng(UBound(icoBits) - 21&), 4& ' bytes in resource
icoBits(18) = 22 ' offset into directory where BHI starts
CopyMemory icoBits(icoBits(18)), BHI, 48&
SaveIconToFile = True
End If
End With
End If
Else
BHI.bmiHeader.biSize = 40
If GetDIBits(hDC, ICI.hbmColor, 0&, 0&, ByVal 0&, BHI, 0&) Then
With BHI.bmiHeader
scanWidth = .biWidth * 4&
maskScan = ByteAlignOnWord(1, .biWidth)
.biBitCount = 32&
.biSize = 40
.biCompression = 0&
.biSizeImage = scanWidth * .biHeight
ReDim Bits(0 To .biWidth * .biHeight - 1&)
End With
If GetDIBits(hDC, ICI.hbmColor, 0&, BHI.bmiHeader.biHeight, Bits(0), BHI, 0&) Then
DeleteObject ICI.hbmColor: ICI.hbmColor = 0&
With BHI.bmiHeader
For X = 0& To .biWidth * .biHeight - 1&
If Bits(X) <> (Bits(X) And &HFFFFFF) Then
.biClrImportant = 0&
Exit For
End If
If .biBitCount = 32 Then
palIndex = FindColor(BHI.bmiColors(), Bits(X), .biClrImportant, bNewColor)
If bNewColor Then
If .biClrImportant = 256& Then ' either 24 bit or 32 bit icon
.biBitCount = 24
.biClrImportant = 0&
ElseIf bNewColor Then
.biClrImportant = .biClrImportant + 1
If palIndex < .biClrImportant Then
CopyMemory BHI.bmiColors(palIndex + 1&), BHI.bmiColors(palIndex), (.biClrImportant - palIndex) * 4&
End If
BHI.bmiColors(palIndex) = Bits(X)
End If
End If
End If
Next
End With
If BHI.bmiHeader.biClrImportant Then
With BHI.bmiHeader
Select Case .biClrImportant
'Case Is < 3: .biBitCount = 1 ' no't work good :/
Case Is < 17: .biBitCount = 4
Case Else: .biBitCount = 8
End Select
pow2(0) = 1&
For X = 1& To .biBitCount
pow2(X) = pow2(X - 1&) * 2&
Next
clrScan = ByteAlignOnWord(.biBitCount, .biWidth)
.biClrUsed = pow2(.biBitCount)
.biSizeImage = clrScan * .biHeight
ReDim icoBits(0 To .biSizeImage + maskScan * .biHeight + .biClrUsed * 4& + 61&)
X = 0&
For Y = X To .biHeight - 1&
palShift = 8& - .biBitCount
palPtr = 62& + .biClrUsed * 4& + Y * clrScan
For X = X To X + .biWidth - 1&
palIndex = FindColor(BHI.bmiColors(), Bits(X), .biClrImportant, bNewColor) - 1&
icoBits(palPtr) = icoBits(palPtr) Or (palIndex * pow2(palShift))
If palShift = 0& Then
palPtr = palPtr + 1&
palShift = 8& - .biBitCount
Else
palShift = palShift - .biBitCount
End If
Next
Next
If .biClrUsed < 256 Then icoBits(8) = .biClrUsed
End With
Else ' can be 24 or 32 bit color
With BHI.bmiHeader
clrScan = ByteAlignOnWord(.biBitCount, .biWidth)
.biSizeImage = clrScan * .biHeight
ReDim icoBits(0 To .biSizeImage + maskScan * .biHeight + 61&)
If .biBitCount = 32 Then
CopyMemory icoBits(62), Bits(0), .biSizeImage
Else
X = 0&
For Y = X To .biHeight - 1&
palPtr = Y * clrScan + 62&
For X = X To .biWidth - 1&
CopyMemory icoBits(palPtr), Bits(X), 3&
palPtr = palPtr + 3&
Next
Next
End If
End With
End If
Erase Bits()
icoBits(2) = 1 ' type: icon
icoBits(4) = 1 ' count
If BHI.bmiHeader.biWidth < 256 Then icoBits(6) = BHI.bmiHeader.biWidth
If BHI.bmiHeader.biHeight < 256 Then icoBits(7) = BHI.bmiHeader.biHeight
BHI.bmiHeader.biHeight = BHI.bmiHeader.biHeight + BHI.bmiHeader.biHeight
icoBits(10) = 1 ' planes
icoBits(12) = BHI.bmiHeader.biBitCount
CopyMemory icoBits(14), CLng(UBound(icoBits) - 21&), 4& ' bytes in resource
icoBits(18) = 22 ' offset into directory where BHI starts
CopyMemory icoBits(icoBits(18)), BHI, BHI.bmiHeader.biClrUsed * 4& + 40&
If ICI.hbmMask Then
BHI.bmiColors(2) = vbWhite
With BHI.bmiHeader
.biBitCount = 1
.biClrImportant = 2
.biClrUsed = 2
.biHeight = .biHeight \ 2
.biSizeImage = 0&
palPtr = UBound(icoBits) - maskScan * .biHeight + 1&
End With
GetDIBits hDC, ICI.hbmMask, 0&, BHI.bmiHeader.biHeight, icoBits(palPtr), BHI, 0&
DeleteObject ICI.hbmMask: ICI.hbmMask = 0&
End If
SaveIconToFile = True
End If
End If
End If
If ICI.hbmColor Then DeleteObject ICI.hbmColor
If ICI.hbmMask Then DeleteObject ICI.hbmMask
ReleaseDC 0&, hDC
If SaveIconToFile Then
Open Filename For Binary As #1
Put #1, 1, icoBits()
Close #1
End If
End Function
All the APIs and types are standard and can be looked up from MSDN, Google, etc.
Although I should have included these two functions:
Code:
Private Function ByteAlignOnWord(ByVal BitDepth As Byte, ByVal Width As Long) As Long
' function to align any bit depth on dWord boundaries
ByteAlignOnWord = (((Width * BitDepth) + &H1F&) And Not &H1F&) \ &H8&
End Function
Private Function FindColor(ByRef PaletteItems() As Long, ByVal Color As Long, ByVal count As Long, ByRef isNew As Boolean) As Long
' MODIFIED BINARY SEARCH ALGORITHM -- Divide and conquer.
' Binary search algorithms are about the fastest on the planet, but
' its biggest disadvantage is that the array must already be sorted.
' Ex: binary search can find a value among 1 million values between 1 and 20 iterations
' [in] PaletteItems(). Long Array to search within. Array must be 1-bound
' [in] Color. A value to search for. Order is always ascending
' [in] Count. Number of items in PaletteItems() to compare against
' [out] isNew. If Color not found, isNew is True else False
' [out] Return value: The Index where Color was found or where the new Color should be inserted
Dim ub As Long, LB As Long
Dim newIndex As Long
If count = 0& Then
FindColor = 1&
isNew = True
Exit Function
End If
ub = count
LB = 1&
Do Until LB > ub
newIndex = LB + ((ub - LB) \ 2&)
If PaletteItems(newIndex) = Color Then
Exit Do
ElseIf PaletteItems(newIndex) > Color Then ' new color is lower in sort order
ub = newIndex - 1&
Else ' new color is higher in sort order
LB = newIndex + 1&
End If
Loop
If LB > ub Then ' color was not found
If Color > PaletteItems(newIndex) Then newIndex = newIndex + 1&
isNew = True
Else
isNew = False
End If
FindColor = newIndex
End Function