Results 1 to 33 of 33

Thread: [RESOLVED] Resize stdPicture

  1. #1

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Resolved [RESOLVED] Resize stdPicture

    Hey, guys ...

    I'm using the DrawState API to draw a disabled image. So far so good. The problem is that the image is 32x32 and I need to draw with 48x48. The API is not doing this.

    I was wondering if there is a way to resize the stdPicture before sending it to the DrawState API?

    Thanks

  2. #2
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,324

    Talking Re: Resize stdPicture

    Put the image in a hBitmap, use StretchBlt and then create a StdPicture from the hBitmap. Or you can put it in an ImageControl that does the stretching for you!

  3. #3

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: Resize stdPicture

    But it's icons, not Bitmap

  4. #4
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,324

    Re: Resize stdPicture

    Ugh, I don't have any experience with icons. Are they not bitmaps as well?

  5. #5

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: Resize stdPicture

    no .... icons have transparency

  6. #6
    Addicted Member -Franky-'s Avatar
    Join Date
    Dec 2022
    Location
    Bremen Germany
    Posts
    223

    Re: Resize stdPicture

    Just an idea. Split the icon into the color and mask bitmap -> GetIconInfo. Enlarge both and reassemble them into one icon with CreateIconIndirect.
    Last edited by -Franky-; Mar 16th, 2023 at 11:23 AM.

  7. #7
    The Idiot
    Join Date
    Dec 2014
    Posts
    2,721

    Re: Resize stdPicture

    stdPicture can be used to create a gdi+ bitmap. and from there its left explanatory.
    but the best way would be to not use the stdPicture but the source and load it directly into gdi+ bitmap.
    but I believe a stdPicture is 24bit so not sure how u could retrieve the alpha at all.
    so gdi32 is enough.
    Last edited by baka; Mar 16th, 2023 at 11:52 AM.

  8. #8
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Resize stdPicture

    Do icons have a true alpha channel?

    Or is it just a specified background color, like a GIF? (i.e., mask alpha)
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  9. #9
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    Re: Resize stdPicture

    The cGDIPlusCache-class in the CodeBank can resize any IconFile (or IconByteArray) "on-load" into the desired size.

    GC.AddIcon "MyIconKey", IconFileNameOrByteArray, 48, 48

    After Loading, any (pre-sized) Alpha-Resorce is represented (and held) within the Cache as a GDIPlus-(Alpha)-image.
    (so, after loading it does not really matter, from where the resource originated, be it an *.ico or a *.png or a *.gif).

    One can then draw these (resized already "onload") Alpha-Images to hDCs directly (using one of the Drawxxx or AlphaRender-methods) -
    but also retrieve different GDI- (not GDIPlus-) Handles from them via StringKey ...

    as e.g.:
    - hIcon = GC.GetHIconFromImage("MyIconKey") ...and if needed later: GC.DestroyHIcon(hIcon)
    - hCursor = GC.GetHCursorFromImage("MyIconKey") ...and if needed later: GC.DestroyHCursor(hCursor)
    - hBmp = GC.GetHBmpFromImage("MyIconKey") ...and if needed later: GC.DestroyHBmp(hBmp)

    The GC.Destroy... methods above are not needed, when you wrap such a GDI-Handle up behind a StdPicture-returning Picture-Property - as shown in #32 in the CodeBank-Thread:
    https://www.vbforums.com/showthread....=1#post5589925

    HTH

    Olaf

  10. #10
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: Resize stdPicture

    Quote Originally Posted by Elroy View Post
    Do icons have a true alpha channel?

    Or is it just a specified background color, like a GIF? (i.e., mask alpha)
    Both variants exist.

    New (since Win8) is that 32-bit DIBs w/ alpha channel can be converted to an hIcon and this in turn to an StdPicture of vbPicTypeIcon sub-type.

    Unfortunately StdPicture.Render does not use DrawIconEx to paint vbPicTypeIcon's but custom paints color+mask icons because it was implemented before DrawIconEx was available but DrawIcon cannot *resize* the icon so COM team had to use StretchBlt and ROP hacks to implement mask transparency *and* resize to target size on StdPicture.Render.

    Later when DrawIconEx became available no one bothered to refactor StdPicture.Render and still later in Win8+ we have true 32-bit icons which cannot be rendered by StdPictures in VB6 unless custom rendered w/ DrawIconEx which some commercial Ax Controls actually do.

    cheers,
    </wqw>

  11. #11

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: Resize stdPicture

    I managed to solve the sizing with BitBlt, but the drawstate insists on drawing with 32x32.

  12. #12
    The Idiot
    Join Date
    Dec 2014
    Posts
    2,721

    Re: Resize stdPicture

    bitblt is a copy while StretchBlt will allow to size it as well.
    if u want to place it in the same stdpicture, u will need to first copy it to a memoryDC
    after that resize the stdpicture and use stretchblt it back with the size of your choice.
    not sure what drawstate api is never used it.

  13. #13

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: Resize stdPicture

    Code:
    Dim lPic As Picture
    Set lPic = Picture
    Call StretchBlt(GetDC(lPic.Handle), 0, 0, 48, 48, GetDC(m_This.Picture.Handle), 0, 0, 48, 48, vbSrcCopy)
    Call DrawState(.hDC, 0, 0, lPic, 0, (50 / 15), ((.ScaleWidth - 720) / 2) / 15, 48, 48, DST_ICON Or DSS_DISABLED)
    is not resizing

  14. #14
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,324

    Re: Resize stdPicture

    I thought GetDC needs a hWnd parameter, not a hBitmap...

  15. #15

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: Resize stdPicture

    Quote Originally Posted by VanGoghGaming View Post
    I thought GetDC needs a hWnd parameter, not a hBitmap...
    GetDC(lPic.Handle)

    lPic.handle = lPic.hwnd

  16. #16
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,324

    Re: Resize stdPicture

    That is a handle to a Bitmap, not a handle to a Window.

    https://learn.microsoft.com/en-us/wi...ure-get_handle

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

    Re: Resize stdPicture

    Seems to work as documented for me (icons don't get automagic stretching):

    CallBacks.bas:

    Code:
    Option Explicit
    
    Private Const WIN32_NULL As Long = 0
    
    Private Enum DI_FLAGS
        DI_NORMAL = &H3&
    End Enum
    
    Private Declare Function DrawIconEx Lib "user32" ( _
        ByVal hDC As Long, _
        ByVal xLeft As Long, _
        ByVal yTop As Long, _
        ByVal hIcon As Long, _
        Optional ByVal cxWidth As Long = 0, _
        Optional ByVal cyWidth As Long = 0, _
        Optional ByVal istepIfAniCur As Long = 0, _
        Optional ByVal hbrFlickerFreeDraw As Long = WIN32_NULL, _
        Optional ByVal diFlags As DI_FLAGS = DI_NORMAL) As Long
    
    Public Function StretchIconCB( _
        ByVal hDC As Long, _
        ByVal hIcon As Long, _
        ByVal wData As Long, _
        ByVal cx As Long, _
        ByVal cy As Long) As Long
    
        StretchIconCB = DrawIconEx(hDC, 0, 0, hIcon, cx, cy)
    End Function
    Form1.frm:

    Code:
    Option Explicit
    
    Private Const WIN32_NULL As Long = 0
    
    Private Enum DST_DSS
        DST_COMPLEX = 0&
        DST_ICON = &H3&
    
        DSS_DISABLED = &H20&
    End Enum
    
    Private Declare Function DrawState Lib "user32" Alias "DrawStateW" ( _
        ByVal hDC As Long, _
        ByVal hbrFore As Long, _
        ByVal qfnCallBack As Long, _
        ByVal lData As Long, _
        ByVal wData As Long, _
        ByVal X As Long, _
        ByVal y As Long, _
        ByVal cx As Long, _
        ByVal cy As Long, _
        ByVal uFlags As DST_DSS) As Long
    
    Private Sub Form_Load()
        AutoRedraw = True
        ScaleMode = vbPixels
        DrawWidth = 1
        Line (9, 9)-(57, 57), vbRed, B
        DrawState hDC, _
                  WIN32_NULL, _
                  AddressOf CallBacks.StretchIconCB, _
                  LoadPicture("Sample32.ico", vbLPCustom, , 32, 32).Handle, _
                  0, _
                  10, _
                  10, _
                  48, _
                  48, _
                  DST_COMPLEX Or DSS_DISABLED
    End Sub

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

    Re: Resize stdPicture

    Note that there DrawState() does a lot of heavy lifting, such as creating and deleting the intermediate memory DC for you just as DrawIconEx() does when rendering. So there are TWO temporary DCs involved this way but you do not need to manage any yourself.

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

    Re: Resize stdPicture

    Also note that stretching sizes upward always produces jaggy results. Better to scale down from a larger common size instead.

    To do better requires fiddling to size with resampling and anti-aliasing and even then it can be blocky. It isn't worth the trouble for UI elements: just size down from larger sizes instead and provide several sizes in ICO resources to help match detail levels to rendered sizes better.

  20. #20

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: Resize stdPicture

    Quote Originally Posted by dilettante View Post
    Seems to work as documented for me (icons don't get automagic stretching):

    CallBacks.bas:

    Code:
    Option Explicit
    
    Private Const WIN32_NULL As Long = 0
    
    Private Enum DI_FLAGS
        DI_NORMAL = &H3&
    End Enum
    
    Private Declare Function DrawIconEx Lib "user32" ( _
        ByVal hDC As Long, _
        ByVal xLeft As Long, _
        ByVal yTop As Long, _
        ByVal hIcon As Long, _
        Optional ByVal cxWidth As Long = 0, _
        Optional ByVal cyWidth As Long = 0, _
        Optional ByVal istepIfAniCur As Long = 0, _
        Optional ByVal hbrFlickerFreeDraw As Long = WIN32_NULL, _
        Optional ByVal diFlags As DI_FLAGS = DI_NORMAL) As Long
    
    Public Function StretchIconCB( _
        ByVal hDC As Long, _
        ByVal hIcon As Long, _
        ByVal wData As Long, _
        ByVal cx As Long, _
        ByVal cy As Long) As Long
    
        StretchIconCB = DrawIconEx(hDC, 0, 0, hIcon, cx, cy)
    End Function
    Form1.frm:

    Code:
    Option Explicit
    
    Private Const WIN32_NULL As Long = 0
    
    Private Enum DST_DSS
        DST_COMPLEX = 0&
        DST_ICON = &H3&
    
        DSS_DISABLED = &H20&
    End Enum
    
    Private Declare Function DrawState Lib "user32" Alias "DrawStateW" ( _
        ByVal hDC As Long, _
        ByVal hbrFore As Long, _
        ByVal qfnCallBack As Long, _
        ByVal lData As Long, _
        ByVal wData As Long, _
        ByVal X As Long, _
        ByVal y As Long, _
        ByVal cx As Long, _
        ByVal cy As Long, _
        ByVal uFlags As DST_DSS) As Long
    
    Private Sub Form_Load()
        AutoRedraw = True
        ScaleMode = vbPixels
        DrawWidth = 1
        Line (9, 9)-(57, 57), vbRed, B
        DrawState hDC, _
                  WIN32_NULL, _
                  AddressOf CallBacks.StretchIconCB, _
                  LoadPicture("Sample32.ico", vbLPCustom, , 32, 32).Handle, _
                  0, _
                  10, _
                  10, _
                  48, _
                  48, _
                  DST_COMPLEX Or DSS_DISABLED
    End Sub

    Dil...... your VB6 sample library should be approaching 20TB....

    Thank you very much ...... it worked ..... although I don't like using CallBack ...... but everything is fine.

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

    Re: [RESOLVED] Resize stdPicture

    Well you might do it all manually.

    Create a memory DC, create and select a monochrome bitmap into it, DrawIconEx into that. Then TransparentBlt from that to your destination. Clean up the temporary GDI objects.

  22. #22

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: [RESOLVED] Resize stdPicture

    I don't know how to do this....... I have to look at some examples to see how it works..... I don't have the skills to work with images.

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

    Re: [RESOLVED] Resize stdPicture

    I'd just use the callback. Using those two API calls that way saves a lot of lines of code and potential mistakes.

  24. #24
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    Re: [RESOLVED] Resize stdPicture

    Quote Originally Posted by Episcopal View Post
    I don't know how to do this...
    Did you try it with the cGDIPlusCache-Class?
    (it's just a few, easy to understand lines)...

    Just make sure, to add the Class-File (cGDIPlusCache.cls) from the example in the CodeBank-Link into your Project -
    after that the following Form-Code should work...

    Code:
    Option Explicit
     
    Private Declare Function DrawStateW Lib "user32" (ByVal hDC As Long, ByVal hbrFore As Long, ByVal qfnCallBack As Long, ByVal lData As Long, ByVal wData As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long) As Long
    
    Public GC As New cGDIPlusCache 'normally placed in a *.bas-Module (as a true, global Object)
    
    Private Sub Form_Load() 'add two differently sized Icons into the cache (from the same Ico-File)
      GC.AddIcon "Ico32", "c:\temp\favicon.ico", 32, 32
      GC.AddIcon "Ico48", "c:\temp\favicon.ico", 48, 48
      Caption = "Click me, repeatedly"
    End Sub
    
    Private Sub Form_Click()
      Static IcoDisabled As Boolean
      Cls
         RenderCachedIconTo hDC, 10, 10, "Ico32", IcoDisabled 'render the smaller one
         RenderCachedIconTo hDC, 50, 10, "Ico48", IcoDisabled 'and the larger one as well
      IcoDisabled = Not IcoDisabled 'switch the Disabled-flag after each Click
    End Sub
    
    Private Sub RenderCachedIconTo(hDC, x, y, GC_Key, Optional ByVal Disabled As Boolean)
      Dim hIcon As Long: Const DST_ICON = &H3&, DSS_DISABLED = &H20&
      
      hIcon = GC.GetHIconFromImage(GC_Key) 'retrieve the Icon from the Cache via String-Key
      
      DrawStateW hDC, 0, 0, hIcon, 0, x, y, 0, 0, DST_ICON Or IIf(Disabled, DSS_DISABLED, 0)
      
      GC.DestroyHIcon hIcon 'don't leak the icon-Handle after the render-call above
    End Sub
    Note, that this approach has not only a better "Stretching-Quality" (compared with DrawIconEx) -
    but it will work as well, in case you add *.png or *.gif Images into the Cache instead of *.ico (in Form_Load)...

    HTH

    Olaf

  25. #25

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: [RESOLVED] Resize stdPicture

    I found this code that puts it in grayscale ...

    Code:
    Private Function GrayScalePicture()
        Dim Color As Long, intMix As Integer
        Dim intX As Long, intY As Long
        Dim YRes As Long, XRes As Long
        Dim R As Long, G As Long, B As Long
    
        YRes = Picture1.ScaleHeight - 1
        XRes = Picture1.ScaleWidth - 1
        For intY = 0 To YRes
            For intX = 0 To XRes
                Color = Picture1.Point(intX, intY)
                B = Color \ 65536
                G = (Color - B * 65536) \ 256
                R = Color - B * 65536 - G * 256
                intMix = CInt(R * 0.3 + G * 0.59 + B * 0.11)
                Picture2.PSet (intX, intY), RGB(intMix, intMix, intMix)
            Next
        Next
    
     End Function


    I have no experience in this, but this does not work ...

    Code:
    Private Function GrayScaleImage(ByVal stdPic As StdPicture) As StdPicture
        Dim Color As Long, intMix As Integer
        Dim intX As Long, intY As Long
        Dim YRes As Long, XRes As Long
        Dim R As Long, G As Long, B As Long
        Dim tmpPic As StdPicture
        Dim memDC As Long, tmpDC As Long
        
        Set tmpPic = New StdPicture
        
        memDC = CreateCompatibleDC(0)
        tmpDC = CreateCompatibleDC(0)
        
        YRes = stdPic.Height - 1
        XRes = stdPic.Width - 1
    
        For intY = 0 To YRes
            For intX = 0 To XRes
                SelectObject memDC, stdPic.Handle
                Color = GetPixel(memDC, intX, intY)
                B = Color \ 65536
                G = (Color - B * 65536) \ 256
                R = Color - B * 65536 - G * 256
                intMix = CInt(R * 0.3 + G * 0.59 + B * 0.11)
                SelectObject tmpDC, tmpPic.Handle
                Call SetPixel(tmpDC, intX, intY, RGB(intMix, intMix, intMix))
            Next
        Next
        Set GrayScaleImage = tmpPic
        DeleteDC memDC
        DeleteDC tmpDC
        
     End Function


    What do I do to make it work?

  26. #26
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,324

    Wink Re: [RESOLVED] Resize stdPicture

    StdPic uses Himetric coordinates which you need to convert to pixels and then it will work:

    Code:
    XRes = Me.ScaleX(stdPic.Width, vbHimetric, vbPixels) - 1
    YRes = Me.ScaleY(stdPic.Height, vbHimetric, vbPixels) - 1

  27. #27
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,324

    Resolved Re: [RESOLVED] Resize stdPicture

    My bad, I haven't read your code carefully. You can't modify StdPicture handles like that. Here's the revised code that works to convert a color picture to grayscale:

    Code:
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (ByRef PicDesc As PICTDESC, ByRef IID As UUID, ByVal fOwn As Long, ByRef IPicture As IPicture) As Long
    
    Private Function MonoRGB(cRGB As Long) As Long
    Dim cRGBQ As RGBQUAD
        CopyMemory ByVal VarPtr(cRGBQ), cRGB, 4
    '    MonoRGB = 0.299 * cRGBQ.rgbRed + 0.587 * cRGBQ.rgbGreen + 0.114 * cRGBQ.rgbBlue ' Standard quality
        MonoRGB = 0.2126 * cRGBQ.rgbRed + 0.7152 * cRGBQ.rgbGreen + 0.0722 * cRGBQ.rgbBlue ' Better quality
    '    MonoRGB = (0.2126 * cRGBQ.rgbRed ^ 2.2 + 0.7152 * cRGBQ.rgbGreen ^ 2.2 + 0.0722 * cRGBQ.rgbBlue ^ 2.2) ^ (1 / 2.2) ' Best quality but slow due to exponentiation
        MonoRGB = RGB(MonoRGB, MonoRGB, MonoRGB)
    End Function
    
    Private Function GrayScaleImage(colorPic As IPicture) As IPicture
    Dim i As Long, j As Long, lWidth As Long, lHeight As Long, BitmapPixels() As Long, lStockBitmap As Long, memDC As Long, lDesktopDC As Long, bmiBitmapInfo As BITMAPINFO, IID_IPicture As UUID, PicDesc As PICTDESC
        lWidth = Me.ScaleX(colorPic.Width, vbHimetric, vbPixels): lHeight = Me.ScaleY(colorPic.Height, vbHimetric, vbPixels)
        ReDim BitmapPixels(0 To lWidth - 1, 0 To lHeight - 1): PicDesc.cbSizeofstruct = LenB(PicDesc): PicDesc.picType = vbPicTypeBitmap
        lDesktopDC = GetDC(0): memDC = CreateCompatibleDC(0)
        PicDesc.hgdiobj = CreateCompatibleBitmap(lDesktopDC, lWidth, lHeight)
        lStockBitmap = SelectObject(memDC, PicDesc.hgdiobj)
        colorPic.Render memDC, 0, 0, lWidth, lHeight, 0, colorPic.Height, colorPic.Width, -colorPic.Height, 0
        With bmiBitmapInfo.bmiHeader
            .biSize = LenB(bmiBitmapInfo.bmiHeader): .biPlanes = 1: .biBitCount = 32: .biCompression = BI_RGB
            .biWidth = lWidth: .biHeight = -lHeight
            .biSizeImage = (((.biWidth * .biBitCount) + 31) \ 32) * 4 * lHeight
        End With
        GetDIBits memDC, PicDesc.hgdiobj, 0, lHeight, BitmapPixels(0, 0), bmiBitmapInfo, DIB_RGB_COLORS
        For i = 0 To lWidth - 1
            For j = 0 To lHeight - 1
                BitmapPixels(i, j) = MonoRGB(BitmapPixels(i, j))
            Next j
        Next i
        SetDIBits memDC, PicDesc.hgdiobj, 0, lHeight, BitmapPixels(0, 0), bmiBitmapInfo, DIB_RGB_COLORS
        IIDFromString "{7BF80980-BF32-101A-8BBB-00AA00300CAB}", IID_IPicture
        OleCreatePictureIndirect PicDesc, IID_IPicture, 1, GrayScaleImage
        SelectObject memDC, lStockBitmap: DeleteDC memDC: ReleaseDC 0, lDesktopDC
     End Function
    I have provided the "OleCreatePictureIndirect" declaration for you. The rest are standard GDI functions, types and constants which you can declare yourself. Alternatively you can download Bruce MCKinney's typelib which already contains all these declarations so you can run the code straight away.

  28. #28

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: [RESOLVED] Resize stdPicture

    Quote Originally Posted by VanGoghGaming View Post
    I have provided the "OleCreatePictureIndirect" declaration for you. The rest are standard GDI functions, types and constants which you can declare yourself. Alternatively you can download Bruce MCKinney's typelib which already contains all these declarations so you can run the code straight away.
    It works, but where it's white it paints it black...



    Edit: This way works with icons
    Set Image1.Picture = GrayScaleImage(Picture1.Image)
    Last edited by Episcopal; Mar 23rd, 2023 at 09:58 AM.

  29. #29
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,324

    Cool Re: [RESOLVED] Resize stdPicture

    Quote Originally Posted by Episcopal View Post
    It works, but where it's white it paints it black...
    The Rolling Stones approve:



    I don't know about icons but with bitmaps it works flawlessly, I don't post untested code!

  30. #30

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: [RESOLVED] Resize stdPicture

    Code:
    Option Explicit
    
    Private Const BI_RGB = 0&
    Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
    
    Private Type PICTDESC
       cbSizeOfStruct As Long
       picType As Long
       hgdiObj As Long
       hPalOrXYExt As Long
    End Type
    Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
    End Type
    Private Type BITMAPINFOHEADER
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
    End Type
    Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
    End Type
    Private Type Guid
      Data1 As Long
      Data2 As Integer
      Data3 As Integer
      Data4(0 To 7) As Byte
    End Type
    
    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Byte
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (ByRef PicDesc As PICTDESC, ByRef IID As Guid, ByVal fOwn As Long, ByRef IPicture As IPicture) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    
    Private Function GrayScaleImage(colorPic As IPicture) As IPicture
    Dim i As Long, j As Long, lWidth As Long, lHeight As Long, BitmapPixels() As Long, lStockBitmap As Long, memDC As Long, lDesktopDC As Long, bmiBitmapInfo As BITMAPINFO, IID_IPicture As Guid, PicDesc As PICTDESC
        lWidth = Me.ScaleX(colorPic.Width, vbHimetric, vbPixels): lHeight = Me.ScaleY(colorPic.Height, vbHimetric, vbPixels)
        ReDim BitmapPixels(0 To lWidth - 1, 0 To lHeight - 1): PicDesc.cbSizeOfStruct = LenB(PicDesc): PicDesc.picType = vbPicTypeBitmap
        lDesktopDC = GetDC(0): memDC = CreateCompatibleDC(0)
        PicDesc.hgdiObj = CreateCompatibleBitmap(lDesktopDC, lWidth, lHeight)
        lStockBitmap = SelectObject(memDC, PicDesc.hgdiObj)
        colorPic.Render memDC, 0, 0, lWidth, lHeight, 0, colorPic.Height, colorPic.Width, -colorPic.Height, 0
        With bmiBitmapInfo.bmiHeader
            .biSize = LenB(bmiBitmapInfo.bmiHeader): .biPlanes = 1: .biBitCount = 32: .biCompression = BI_RGB
            .biWidth = lWidth: .biHeight = -lHeight
            .biSizeImage = (((.biWidth * .biBitCount) + 31) \ 32) * 4 * lHeight
        End With
        GetDIBits memDC, PicDesc.hgdiObj, 0, lHeight, BitmapPixels(0, 0), bmiBitmapInfo, DIB_RGB_COLORS
        For i = 0 To lWidth - 1
            For j = 0 To lHeight - 1
                BitmapPixels(i, j) = MonoRGB(BitmapPixels(i, j))
            Next j
        Next i
        With IID_IPicture
          .Data1 = &H7BF80981
          .Data2 = &HBF32
          .Data3 = &H101A
          .Data4(0) = &H8B
          .Data4(1) = &HBB
          .Data4(3) = &HAA
          .Data4(5) = &H30
          .Data4(6) = &HC
          .Data4(7) = &HAB
       End With
        SetDIBits memDC, PicDesc.hgdiObj, 0, lHeight, BitmapPixels(0, 0), bmiBitmapInfo, DIB_RGB_COLORS
        OleCreatePictureIndirect PicDesc, IID_IPicture, 1, GrayScaleImage
        SelectObject memDC, lStockBitmap: DeleteDC memDC: ReleaseDC 0, lDesktopDC
     End Function

    This works without tlb ....

  31. #31

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: [RESOLVED] Resize stdPicture

    Now the problem is the transparency of the icon.

  32. #32
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,324

    Red face Re: [RESOLVED] Resize stdPicture

    Obviously it works without the TLB but you're missing the point. You WANT the TLB unless you enjoy copy-pasting chunks of declarations.

    Also if your original image had an alpha channel, you can preserve it in the MonoRGB function. Also made it into a SUB for faster execution speed:

    Code:
    Private Sub MonoRGB(cRGB As Long)
    Dim cRGBQ As RGBQUAD
        CopyMemory ByVal VarPtr(cRGBQ), cRGB, 4
        With cRGBQ
            .rgbRed = 0.2126 * .rgbRed + 0.7152 * .rgbGreen + 0.0722 * .rgbBlue
            .rgbGreen = .rgbRed: .rgbBlue = .rgbRed
        End With
        CopyMemory cRGB, ByVal VarPtr(cRGBQ), 4
    End Sub
    Now the loop through the bitmap pixels looks like this:

    Code:
        For i = 0 To lWidth - 1
            For j = 0 To lHeight - 1
                Call MonoRGB(BitmapPixels(i, j))
            Next j
        Next i
    Does this fix your transparency issue?

  33. #33

    Thread Starter
    Fanatic Member Episcopal's Avatar
    Join Date
    Mar 2019
    Location
    Brazil
    Posts
    547

    Re: [RESOLVED] Resize stdPicture

    Quote Originally Posted by VanGoghGaming View Post
    Obviously it works without the TLB but you're missing the point. You WANT the TLB unless you enjoy copy-pasting chunks of declarations.
    Yes, I prefer to paste the statements, I don't like to reference anything, it's an old custom.



    Quote Originally Posted by VanGoghGaming View Post
    Does this fix your transparency issue?
    No it is returning black color where it is transparent....

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