Results 1 to 31 of 31

Thread: Can't save images from ImageList control

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    Unhappy Can't save images from ImageList control

    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.

  2. #2
    gibra
    Guest

    Re: Can't save images from ImageList control

    The ImageList control uses:
    bitmap (.gif), cursor (.cur), icon (.ico), JPEG (.jpg), or GIF (.gif) files.

    SavePicture Statement
    https://msdn.microsoft.com/en-us/lib...(v=vs.60).aspx



    Last edited by gibra; Feb 27th, 2016 at 04:18 PM.

  3. #3

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    Re: Can't save images from ImageList control

    Either way it doesn't come out right

    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.

  4. #4
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    5,651

    Re: Can't save images from ImageList control

    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.

  5. #5
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,253

    Re: Can't save images from ImageList control

    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...

    My VB6 love-children: Vee-Hive and Vee-Launcher

  6. #6
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    19,541

    Re: Can't save images from ImageList control

    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"

    Classics Enthusiast? Here's my 1969 Mustang Mach I Fastback. Her sister '67 Coupe has been adopted

    Newbie? Novice? Bored? Spend a few minutes browsing the FAQ section of the forum.
    Read the HitchHiker's Guide to Getting Help on the Forums.
    Here is the list of TAGs you can use to format your posts
    Here are VB6 Help Files online


    {Alpha Image Control} {Memory Leak FAQ} {Unicode Open/Save Dialog} {Resource Image Viewer/Extractor}
    {VB and DPI Tutorial} {Manifest Creator} {UserControl Button Template} {stdPicture Render Usage}

  7. #7
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    5,651

    Re: Can't save images from ImageList control

    For hIcon to hBitmap with transparency I use:
    Code:
    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

  8. #8

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    Re: Can't save images from ImageList control

    Quote Originally Posted by LaVolpe View Post
    XP Paint & PicFax viewer don't do icons
    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.

  9. #9

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    Re: Can't save images from ImageList control

    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.

  10. #10
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: Can't save images from ImageList control

    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.

    Name:  sshot.png
Views: 1012
Size:  7.1 KB

    It doesn't use any ImageList controls at all.
    Attached Files Attached Files

  11. #11
    gibra
    Guest

    Re: Can't save images from ImageList control

    As I wrote in my first post,
    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.

    Go here:
    http://web.archive.org/web/201508101...tmtz.mvps.org/

    and download this sample project:
    GfxFromFrx 12/08/99 How to extract graphics from VB binary property files
    Last edited by gibra; Feb 29th, 2016 at 06:20 AM.

  12. #12
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: Can't save images from ImageList control

    I thought he was after Shell icons for various specific and/or generic files, not .FRX extraction. Maybe I've misread the thread though.

  13. #13
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    5,651

    Re: Can't save images from ImageList control

    jms if you want to use system imagelist images, use the clsMenuImage class, and then .AddIconFromHandle with the SHFILEINFO.hIcon from SHGetFileInfo.

  14. #14

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    Re: Can't save images from ImageList control

    Quote Originally Posted by fafalone View Post
    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.

  15. #15

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    Re: Can't save images from ImageList control

    Quote Originally Posted by dilettante View Post
    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.

    Name:  sshot.png
Views: 1012
Size:  7.1 KB

    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.

  16. #16
    gibra
    Guest

    Re: Can't save images from ImageList control

    Quote Originally Posted by dilettante View Post
    I thought he was after Shell icons for various specific and/or generic files, not .FRX extraction. Maybe I've misread the thread though.
    Sorry, I misunderstood.
    I realized that jmsrickland would extract images from an ImageList, where he did not own the images.

  17. #17

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    Re: Can't save images from ImageList control

    Quote Originally Posted by gibra View Post
    As I wrote in my first post,


    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.

    Go here:
    http://web.archive.org/web/201508101...tmtz.mvps.org/

    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.

  18. #18
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    19,541

    Re: Can't save images from ImageList control

    @JM. This thread may help clear some things up regarding bitmaps on menus, think it would be useful anyway

    http://www.vbforums.com/showthread.p...de-Menus/page2
    Insomnia is just a byproduct of, "It can't be done"

    Classics Enthusiast? Here's my 1969 Mustang Mach I Fastback. Her sister '67 Coupe has been adopted

    Newbie? Novice? Bored? Spend a few minutes browsing the FAQ section of the forum.
    Read the HitchHiker's Guide to Getting Help on the Forums.
    Here is the list of TAGs you can use to format your posts
    Here are VB6 Help Files online


    {Alpha Image Control} {Memory Leak FAQ} {Unicode Open/Save Dialog} {Resource Image Viewer/Extractor}
    {VB and DPI Tutorial} {Manifest Creator} {UserControl Button Template} {stdPicture Render Usage}

  19. #19
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: Can't save images from ImageList control

    Quote Originally Posted by jmsrickland View Post
    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.

    Enable and Control DWM 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.
    About Menus

    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:

    Name:  Win10.PNG
Views: 944
Size:  5.0 KB

    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.

  20. #20
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: Can't save images from ImageList control

    You might need to look into owner drawn menus.

  21. #21

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    Re: Can't save images from ImageList control

    OK, I got what I need.

    I used SystemIcons.bas from dilettante's post #10 Menu Shell Icons.zip above

    and

    clsMenuImage.cls from post #4 by fafalone HERE

    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.

  22. #22
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    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.

    Name:  Win10.PNG
Views: 950
Size:  6.1 KB


    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.
    Attached Files Attached Files

  23. #23

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    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.

  24. #24
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    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.

  25. #25
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: Can't save images from ImageList control

    Quote Originally Posted by jmsrickland View Post
    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:

    Name:  sshotXP.png
Views: 923
Size:  8.1 KB

    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:

    Name:  sshotVista.png
Views: 905
Size:  7.5 KB

    Because Windows now combines these there is no need for the "extra room" for the checked/unchecked bitmap.

  26. #26
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    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:

    How To Create an Alpha Blended Cursor or Icon in Windows XP

    // 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:

    Name:  sshotXP2.png
Views: 895
Size:  8.5 KB


    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.
    Attached Files Attached Files

  27. #27
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    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.

  28. #28

    Thread Starter
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,074

    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.

  29. #29
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: Can't save images from ImageList control

    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:

    Name:  sshot.png
Views: 949
Size:  11.1 KB
    Attached Files Attached Files

  30. #30
    Member
    Join Date
    Aug 2006
    Posts
    57

    Re: Can't save images from ImageList control

    Quote Originally Posted by fafalone View Post
    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
    how to use u code??

  31. #31
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    5,651

    Re: Can't save images from ImageList control

    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

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