Load image into STATIC control Win32

Code:

---

hwnd = CreateWindowEx(0, "STATIC", "", SS_BITMAP + WS_CHILD + WS_VISIBLE, 50, 55, 200, 200, hWnd, 0, Application.Hinstance, ByVal 0&)
Call SendMessage(hwnd, STM_SETIMAGE, IMAGE_BITMAP, GetHBMP(UserForm1.Image1))

---

I am trying to add an image to a win32 static control using the code above.

The Static control is created successfully onto its parent form, but no image is displayed.

GetHBMP is a user function that successfully returns a valid bitmap handle from another image activeX on the form (<==tested and confirmed).

Do I need to set the static image in the static control window procedure for it to take effect or do I need to set the OwnerDrawn style and set the image in its Parent window procedure?

Note:
The Static control IS NOT OwnerDrawn.

You mean besides the point that this is VBA/Office apparently?

Show us your SendMessage declaration and help us to help you out.

Perhaps your issue can be all solved as easily as using ByVal GetHBMP(UserForm1.Image1) for the lParam As Any parameter but who knows. . .

cheers,
</wqw>
p.s. A sample code that can be copy/pasted in a form in VB6 IDE is way more likely to attract responses.

Quote:

---

Originally Posted by wqweto

Show us your SendMessage declaration and help us to help you out.

Perhaps your issue can be all solved as easily as using ByVal GetHBMP(UserForm1.Image1) for the lParam As Any parameter but who knows. . .

cheers,
</wqw>
p.s. A sample code that can be copy/pasted in a form in VB6 IDE is way more likely to attract responses.

---

Thanks for responding.

Download Demo

Here is a simplified version of the code I have which illustrates the issue:

This is the code I have:

Code:

---

Option Explicit

'GDI+ Structures
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Type EncoderParameter
  GUID As GUID
  NumberOfValues As Long
  Type As Long
    Value As Long
End Type

Private Type EncoderParameters
  Count As Long
  Parameter As EncoderParameter
End Type

'GDI+ Declares
Private Declare  Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare  Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare  Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
Private Declare  Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare  Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare  Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal Filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long

'
Private Declare  Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare  Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare  Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare  Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hWnd As Long) As Long
Private Declare  Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long


Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const SS_BITMAP = &HE
Private Const IMAGE_BITMAP = 0
Private Const STM_SETIMAGE = &H172

Private hStatic As Long


Private Sub CommandButton1_Click()

    Dim hForm As Long, hStatic As Long, hBitmap As Long
   
    IUnknown_GetWindow Me, VarPtr(hForm)
    Debug.Print "Form Handle: "; hForm
   
    hStatic = CreateWindowEx(0, "STATIC", "TEST", SS_BITMAP Or WS_CHILD Or WS_VISIBLE, 0, 0, _
    120, 80, hForm, 0, GetModuleHandle(vbNullString), 0)
    Debug.Print "Static Control Handle: "; hStatic
   
    hBitmap = GetHBMP(Me.Image1)
    Debug.Print "BITMAP Handle: "; hBitmap

    Call SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal hBitmap)

End Sub



Private Function GetHBMP(ByVal img As Object) As Long

    Dim tSI As GdiplusStartupInput, lRes As Long
    Dim tJpgEncoder As GUID, tParams As EncoderParameters
    Dim lGDIP As Long, hBitmap As Long

    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI)
   
    If lRes = 0 Then
        lRes = GdipCreateBitmapFromHBITMAP(img.Picture.Handle, 0, hBitmap)
        If lRes = 0 Then
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
            tParams.Count = 1
            With tParams.Parameter
                CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
                .NumberOfValues = 1
                .Type = 4
                .Value = VarPtr(255)
            End With
            GetHBMP = hBitmap
            '******************************************************************************************************************
            'Saving Image to disk for testing only to verify that hBitmap is a valid handle.
            lRes = GdipSaveImageToFile(hBitmap, StrPtr("C:\Users\Info-Hp\Desktop\ABC\A.bmp"), tJpgEncoder, tParams)
            '*******************************************************************************************************************
            GdipDisposeImage hBitmap
        End If
        GdiplusShutdown lGDIP
    End If
End Function



Private Sub UserForm_Terminate()
        DestroyWindow hStatic
End Sub

---

If I simply remove the SS_BITMAP style, I can see the Static control appear on the form (obviously with no image in it) otherwise , the static control is created but doesn't show up at all.

No idea how GDI+ got into the mix.

This works fine in VB6:

Code:

---

Private hWndStatic As Long
Private StaticPicture As StdPicture 'Keep it around, it owns the BITMAP.

Private Sub Form_Load()
    hWndStatic = CreateWindowEx(0, _
                                StrPtr("STATIC"), _
                                0, _
                                WS_CHILD Or WS_VISIBLE Or WS_EX_NOPARENTNOTIFY Or WS_EX_NOACTIVATE _
                            Or SS_BITMAP Or SS_REALSIZEIMAGE, _
                                0, _
                                0, _
                                0, _
                                0, _
                                hWnd, _
                                0, _
                                App.hInstance, _
                                0)
    If hWndStatic = 0 Then
        Debug.Print Err.LastDllError
    Else
        Set StaticPicture = LoadPicture("static.gif")
        SendMessage hWndStatic, STM_SETIMAGE, IMAGE_BITMAP, StaticPicture.Handle
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DestroyWindow hWndStatic
End Sub

---

Attachment 178910

You cannot use GDI+ handles in place of GDI handles. Windows controls (and Common controls) work *only* with native GDI handles. GDI+ to them is no different than skia or RichClient5 or OpenGL — completely unknown external user-space component.

Here's a silly VB6 demo that uses some small-file-size animated icons (actually cursors) that I found by searching for some. No idea what tools are out there for creating them today.

Attachment 178913

Of course to see the animation you'll need to run it.

The first one there is a regular old icon.

ok. The reason I resorted to the GDI+ is because I couldn't make the code work by retrieving a valid bitmap handle from (Me.Image1.Picture.Handle).

After further investigation, I discovered the reason for this and that is because of the WS_VISIBLE style... I had to omit that style when creating the control and then only after sending the STM_SETIMAGE message make the static control visible via ShowWindow API.

In other words, if the static control is visible before setting the image, the control doesn't show up. This is weird and I don't understand why this is happening.

Ok. Now, I got rid of the GDI+ stuff and made the static control visible subsequent to STM_SETIMAGE and the image is successfully set , BUT the quality of the resulting image is bad (see below the resulting pic at the top left of the form)


Attachment 178917

if I don't set the SS_REALSIZECONTROL style, the picture quality is good but static control resizes itself which I don't want. I need the static control to be the same size as the original image control (ie: same size as image1)


Here is the entire code :

Code:

---

Option Explicit

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
   


Private Sub CommandButton1_Click()

    Const WS_CHILD = &H40000000
    Const WS_VISIBLE = &H10000000
    Const SS_BITMAP = &HE
    Const SS_REALSIZECONTROL = &H40
    Const SS_REALSIZEIMAGE = &H800
    Const SS_CENTERIMAGE = &H200
    Const IMAGE_BITMAP = 0
    Const STM_SETIMAGE = &H172
   
   
    Dim hForm As Long, hStatic As Long
   
    IUnknown_GetWindow Me, VarPtr(hForm)
    Debug.Print "Form Handle: "; hForm
   
    Dim lPicWidth As Long, lPicHeight As Long
   
    lPicWidth = PTtoPX(Me.Image1.Width, False)
    lPicHeight = PTtoPX(Me.Image1.Height, True)
   
   
    hStatic = CreateWindowEx(0, "STATIC", "", SS_REALSIZECONTROL Or SS_BITMAP Or WS_CHILD Or 0, 0, 0, _
    lPicWidth, lPicHeight, hForm, 0, GetModuleHandle(vbNullString), 0)
   
    Debug.Print "Static Control Handle: "; hStatic
   
    Call SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal Me.Image1.Picture.Handle)
   
    ShowWindow hStatic, 1

End Sub


Private Function ScreenDPI(ByVal bVert As Boolean) As Long
   
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Static lDPI(1), hdc

    If lDPI(0) = 0 Then
        hdc = GetDC(0)
        lDPI(0) = GetDeviceCaps(hdc, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hdc, LOGPIXELSY)
        ReleaseDC 0, hdc
    End If
    ScreenDPI = lDPI(Abs(bVert))

End Function


Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
  Const POINTSPERINCH As Long = 72

    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function


Private Sub UserForm_Terminate()
        DestroyWindow hStatic
End Sub

---

Is there a style that I should set so the resulting pic retains its qualty ?

Thanks both for your help.

Here I used a VB6 Image control to show a scaled-down image. Its Picture property contains the full-size original.

If you want smoother scaling you have more work to do. In VB6 this is easy enough:

Attachment 178918

Code:

---

Private hWndStatic As Long

Private Sub Form_Load()
    Dim hBmpPrev As Long

    hWndStatic = CreateWindowEx(0, _
                                StrPtr("STATIC"), _
                                0, _
                                WS_CHILD Or WS_VISIBLE Or SS_BITMAP, _
                                0, _
                                0, _
                                0, _
                                0, _
                                hWnd, _
                                0, _
                                App.hInstance, _
                                0)
    If hWndStatic = 0 Then
        Debug.Print Err.LastDllError
    Else
        'Picture1 is Visible = False.  We will use it for its hDC and its PaintPicture()
        'method which wraps SetStretchBltMode(hDC, HALFTONE) and StretchBlt().
        '
        'You could also create a Compatible memory DC and use that.
        With Picture1
            .Width = Image1.Width
            .Height = Image1.Height
            .AutoRedraw = True
            .PaintPicture Image1.Picture, 0, 0, Image1.Width, Image1.Height
            .AutoRedraw = False
            Set .Picture = .Image
            hBmpPrev = SendMessage(hWndStatic, STM_SETIMAGE, IMAGE_BITMAP, .Picture.Handle)
        End With
        If hBmpPrev Then DeleteObject hBmpPrev
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DestroyWindow hWndStatic
End Sub

---

However in VBA macros you'll probably need to resort to API calls unless the hosting application exposes something useful to scripters in this regard.

Thanks.

I agree. vba has less features than vb6 (there are no HWNDs or HDCs exposed in vba forms and controls , there is no PictureBox control and its rich graphical Properties ... etc. So it is more difficult to get the job done and like you said, one must work from scratch and often resort to the windows api.

I do seem to have managed to load the image into the static control in the end, but I have two questions that perplexe me:

1- Why is it that if I set the WS_VISISBLE style bit upon creating the static control, or if I show the static control (ShowWindow API) before sending to it the STM_SETIMAGE message, the control doesn't showup not even after sending a Repaint or refreshing the form ?!!!

2- Why do I first need to create a StdPicture Object from the memory bitmap and then pass the Handle of this StdPicture object to the SendMessage API, rather than just directly pass the actual memory bitmap handle in the SendMessage API?

(ie:_)

Why this ? ( works )

Code:

---

    'create new StdPicture object from the memory bitmap.
    Set oPic = CreateStdPicture(hMemBMP)
   
    'load newly created picture onto the static control.
    If Not oPic Is Nothing Then
        Call SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal oPic.handle)
    End If

---

Rather than just this ? (Doesn't work )

Code:

---

Call SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal hMemBMP)

---

My understanding has been that the Handle of a StdPicture object is the same as the BITMAP handle but that's probably wrong.



https://www.vbforums.com/images/ieimages/2020/10/1.gif




Here is the entire code:

Code:

---

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type


Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC 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 BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

Private hStatic As Long


Private Sub CommandButton1_Click()

    Const WS_CHILD = &H40000000
    Const SS_BITMAP = &HE
    Const SS_REALSIZECONTROL = &H40
    Const IMAGE_BITMAP = 0
    Const STM_SETIMAGE = &H172
    Const SRCCOPY = &HCC0020

    Dim oPic As StdPicture, hForm As Long
    Dim lPicWidth As Long, lPicHeight As Long, lLeft As Long, lTop As Long
    Dim hMemDC As Long, hMemBMP As Long, hdc As Long


  'get UserForm hwnd.
    IUnknown_GetWindow Me, VarPtr(hForm)

  'convert source image points to screen pixels.
    lLeft = PTtoPX(Me.Image1.Left, False)
    lTop = PTtoPX(Me.Image1.Top, True)
    lPicWidth = PTtoPX(Me.Image1.Width, False)
    lPicHeight = PTtoPX(Me.Image1.Height, True)

    'create static control to hold a copy of the source image control.
    hStatic = CreateWindowEx(0&, "STATIC", "", SS_REALSIZECONTROL Or SS_BITMAP Or WS_CHILD, 0&, 0&, _
    lPicWidth, lPicHeight, hForm, 0&, GetModuleHandle(vbNullString), 0&)

  'Create memory dc and draw image on it.
    hdc = GetDC(hForm)
    hMemDC = CreateCompatibleDC(hdc)
    hMemBMP = CreateCompatibleBitmap(hdc, lPicWidth, lPicHeight)
    DeleteObject SelectObject(hMemDC, hMemBMP)
    Call BitBlt(hMemDC, 0&, 0&, lPicWidth, lPicHeight, hdc, lLeft, lTop, SRCCOPY)

    'create new StdPicture object from the memory bitmap.
    Set oPic = CreateStdPicture(hMemBMP)

    'cleanup.
    Call DeleteDC(hMemDC)
    Call DeleteObject(hMemBMP)
    ReleaseDC hForm, hdc

  'load newly created picture onto the static control.
    If Not oPic Is Nothing Then
        Call SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal oPic.handle)
    End If

  'make the static control visible. (left till the end)
    Call ShowWindow(hStatic, 1&)

End Sub

Private Function CreateStdPicture(ByVal hBitmap As Long) As StdPicture

    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    Const PICTYPE_BITMAP = 1
    Const S_OK = &H0

    Static oStdPic As StdPicture
    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc, hPtr As Long


    hPtr = CopyImage(hBitmap, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPtr
        .hPal = 0&
    End With

    If OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, oStdPic) = S_OK Then
        Set CreateStdPicture = oStdPic
    End If

End Function


Private Function ScreenDPI(ByVal bVert As Boolean) As Long

    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Static lDPI(1), hdc

    If lDPI(0) = 0 Then
        hdc = GetDC(0)
        lDPI(0) = GetDeviceCaps(hdc, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hdc, LOGPIXELSY)
        ReleaseDC 0, hdc
    End If
    ScreenDPI = lDPI(Abs(bVert))

End Function


Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
  Const POINTSPERINCH As Long = 72

    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function


Private Sub UserForm_Terminate()
        DestroyWindow hStatic
End Sub

---

Quote:

---

1- Why is it that if I set the WS_VISISBLE style bit upon creating the static control, or if I show the static control (ShowWindow API) before sending to it the STM_SETIMAGE message, the control doesn't showup not even after sending a Repaint or refreshing the form ?!!!

---

You probably need to call UpdateWindow API on the static hWnd? Refreshing the form likely does nothing because a form is not going to know to refresh an API-generated window you created. The form does not know that window exists.

Quote:

---

2- Why do I first need to create a StdPicture Object from the memory bitmap and then pass the Handle of this StdPicture object to the SendMessage API, rather than just directly pass the actual memory bitmap handle in the SendMessage API?

---

It would likely work if your Command's Click event was correct. Keeping it in a stdPicture object has the advantage of having VBA destroy the bitmap when the stdPicture is released. This way you don't need to cache the bitmap handle and manually destroy it later.

Regarding that click event:

Code:

---

DeleteObject SelectObject(hMemDC, hMemBMP)

---

That is wrong, you don't delete the default bitmap from hMemDC. You cache it and put it back later

Code:

---

    Call DeleteDC(hMemDC)
    Call DeleteObject(hMemBMP)

---

You are deleting hMemBmp therefore "Call SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal hMemBMP)" fails. In addition, you have those 2 lines reversed. You should first put back the original bitmap, then delete the DC. If your intentions were to actually delete hMemBMP, then you would do that too.

Hi Lavolpe,

Quote:

---

Regarding that click event:

---

You mean like this ?

Code:

---

  'Create memory dc and draw image on it.
    hdc = GetDC(hForm)
    hMemDC = CreateCompatibleDC(hdc)
    hMemBMP = CreateCompatibleBitmap(hdc, lPicWidth, lPicHeight)

    'store original memory bitmap.   
    hOriginalBitmap = SelectObject(hMemDC, hMemBMP)

    Call BitBlt(hMemDC, 0, 0, lPicWidth, lPicHeight, hdc, lLeft, lTop, SRCCOPY)

    'create new StdPicture object from the memory bitmap.
    Set oPic = CreateStdPicture(hMemBMP)

  'load newly created picture onto the static control.
    If Not oPic Is Nothing Then
        Call SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal oPic.handle)
    End If

  'restore original memory bitmap and cleanup.
    hMemBMP = SelectObject(hMemDC, hOriginalBitmap)
    Call DeleteObject(hMemBMP)
    Call DeleteDC(hMemDC)
    ReleaseDC hForm, hdc

---

Quote:

---

You are deleting hMemBmp therefore "Call SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal hMemBMP)" fails. In addition, you have those 2 lines reversed. You should first put back the original bitmap, then delete the DC. If your intentions were to actually delete hMemBMP, then you would do that too.

---

I deleted the memory bitmap before SendMessage because I already had the bitmap secured in the
StdPicture Object but even if I don't delete hMemBMP, calling SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal hMemBMP) doesn't work ... The whole thing only works via a StdPicture object which still begs the question why.

Quote:

---

You probably need to call UpdateWindow API on the static hWnd? Refreshing the form likely does nothing because a form is not going to know to refresh an API-generated window you created. The form does not know that window exists.

---

Makes sense, but calling UpdateWindow on the static control hwnd doesn't seem to have any effect nor does InvalidateRect or RedawWindow... I had already tested them all.

The only way the static control gets displayed is if I don't set the WS_VISIBLE style bit and only if I call the ShowWindow API on it's hwnd after SendMessage, not before !!!! weird

Why would you do any of this anyway?

You already have an Image control in the MSForms library. Are you hoping to get some other functionality out of a Static control?

Quote:

---

The whole thing only works via a StdPicture object which still begs the question why.

---

Because in your CreateStdPicture routine you are copying the bitmap and that copy is wrapped in a stdpicture:

Code:

---

hPtr = CopyImage(hBitmap, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)

---

Quote:

---

... I deleted the memory bitmap before SendMessage because I already had the bitmap secured in the StdPicture Object

---

As noted in comments above, the two handles are different values: memory bitmap <> stdPicture.Handle. You should be able to verify that.

Quote:

---

Originally Posted by dilettante

Why would you do any of this anyway?

You already have an Image control in the MSForms library. Are you hoping to get some other functionality out of a Static control?

---

Yes, funnily enough, I am trying to do something close to what you posted here:
https://www.vbforums.com/showthread....te-Image-Areas
but vba friendly, without the use of a usercontrol.

Quote:

---

Originally Posted by LaVolpe

As noted in comments above, the two handles are different values: memory bitmap <> stdPicture.Handle. You should be able to verify that.

---

Thanks.

Ok- This is the current situation:

I added the static control to the form and set the static control image... so far so good...

Now next step is to make the static control semi-transparent.

Since we cannot set the transparency of a control that has the WS_CHILD style, I resorted to an ugly hack by making the static control with the WS_POPUP style, setting the form as its owner (GWL_HWNDPARENT) and adding some code to synchronize the static control with its owner window (ie: the form). ... The result is not too bad actually.

Now the problem:
Since the static control is now an owned window (not a child) , the user can drag the control outside its owner bounderies which is not good (See gif1)

In order to remedie this, I dynamically change the static control clip region during the dragging operation (CombineRgn(hStaticRgn, hStaticRgn, hFormClientRgn, RGN_AND) and call the SelectClipRgn API. The problem is SelectClipRgn returns NULLREGION despite being able to successfully draw a red FrameRgn around the clip region (see gif1)

I also used (SetWindowRgn(hStatic, hStaticRgn, True)) but doesn't work (see gif2)

I think, I must be messing up the static dc with the screen dc but haven't been able figure out.

Here is part of the relevant code (inside a Do-While loop)

Code:

---

        With tFormChildRect
            hFormClientRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
        End With
       
        GetWindowRect hStatic, tStaticRect
        With tStaticRect
            hStaticRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
        End With

        Call CombineRgn(hStaticRgn, hStaticRgn, hFormClientRgn, RGN_AND)

        'for testing valid region.
        hBrush = CreateSolidBrush(vbRed)
        hScreenDC = GetDC(0)
        FrameRgn hScreenDC, hStaticRgn, hBrush, 3, 3
        ReleaseDC 0, hScreenDC

        GetCursorPos tPos
        SetWindowPos hStatic, 0, tPos.x - PTtoPX(x, False), tPos.y - PTtoPX(y, True), lImgWidth, lImgHeight, SWP_NOACTIVATE
           
           
        hStaticDC = GetDC(hStatic)
        Debug.Print SelectClipRgn(hStaticDC, hStaticRgn) '<=== NULLREGION
        ReleaseDC hStatic, hStaticDC
'      Debug.Print SetWindowRgn(hStatic, hStaticRgn, True)

        DeleteObject hBrush
        DeleteObject hFormClientRgn
        DeleteObject hStaticRgn

---

Gif1 (Before calling SelectClipRgn or SetWindowRgn) (Notice framed clip region in RED)

https://www.vbforums.com/images/ieimages/2020/10/2.gif



Gif2 (After calling SetWindowRgn )

https://www.vbforums.com/images/ieimages/2020/10/3.gif

Any ideas ?

Quote:

---

Originally Posted by JAAFAR

Since we cannot set the transparency of a control that has the WS_CHILD style, I resorted to an ugly hack...

---

No need. Child windows can be layered since about Windows 8.1 Fire Two (8.1 got re-released) or so.

Quote:

---

Originally Posted by dilettante

No need. Child windows can be layered since about Windows 8.1 Fire Two (8.1 got re-released) or so.

---

Thanks.

MSDN: "In order to use layered child windows, the application has to declare itself Windows 8-aware in the manifest."

Is there a run time code alternative to using a manifest file ?

I assume the application in this case refers to Excel.
And I assume Excel has the correct manifest.

I keep forgetting this is a VBA thread. Doh!

Quote:

---

Originally Posted by Arnoutdv

I assume the application in this case refers to Excel.
And I assume Excel has the correct manifest.

---

no. desn't work

Quote:

---

Originally Posted by dilettante

I keep forgetting this is a VBA thread. Doh!

---

So, back to post#17. Does anybody know why SelectClipRgn doesn't work, nor does SetWindowRgn ?

Thanks.

Quote:

---

Now the problem:
Since the static control is now an owned window (not a child) , the user can drag the control outside its owner bounderies which is not good

---

Why not subclass the owned form to prevent it from being dragged outside the owner's bounds? Subclassing in this case is only needed during the dragging operation, which you seem to have control over. ClientToScreen API can convert the owner's client X,Y coordinates to screen coordinates to test against in subclass procedure.

Edited:

Quote:

---

I think, I must be messing up the static dc with the screen dc but haven't been able figure out.

Debug.Print SelectClipRgn(hStaticDC, hStaticRgn) '<=== NULLREGION

---

hStaticDC is the image window's DC
hStaticRgn is an AND of the form's bounds with the image window's bounds. If you were to call GetRgnBox API on hStaticRgn after the CombineRgn call, you'll notice that the region is out of the physical client bounds of the image window. This is probably why your image is not being drawn. Maybe since the clipping rectangle you are setting is outside the physical bounds of the window, the API is returning null region?

I think you are attempting to clip the image window? If so, recommend some tweaks. Once you get the region you want to apply, you have to align it back to 0,0 coordinates of the target window (in client not screen coordinates). You'll probably need another API: OffsetRgn. Or maybe something like this:

Code:

---

Private Declare Function ScreenToClient Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As Any) As Long
Private Declare Function SetRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function IntersectRect Lib "user32.dll" (ByRef lpDestRect As RECT, ByRef lpSrc1Rect As RECT, ByRef lpSrc2Rect As RECT) As Long


    Dim stRect As RECT
   
    GetWindowRect hStatic, tStaticRect
    ' find intersection between form & static bounds
    If IntersectRect(stRect, tFormChildRect, tStaticRect) = 0 Then
        ' 2 rects do not intersect; hStatic is completely off Owner form
        Stop
    End If
   
    ' align from screen to hStatic
    ScreenToClient hStatic, stRect.Left
    ScreenToClient hStatic, stRect.Right
    ' create region and apply to hStatic
    hStaticRgn = CreateRectRgn(stRect.Left, stRect.Top, stRect.Right, stRect.Bottom)
    Debug.Print SetWindowRgn(hStatic, hStaticRgn, True)
    ' don't delete regions used with SetWindowRgn

---

See my previous reply also

So, your image windows are separate owned windows? If so, each time you move the owner, you have to synchronize moving the owned windows too. I'd imagine on some slower systems, those windows will have some lagging while they are being moved. Maybe consider a similar approach, the other way around.

1. Just before dragging occurs...
-- create a new top-level window (well call it WndMover)
-- assign the image to WndMover from the image about to be dragged
2. Align WndMover over the static window to be moved
3. Hide that static window
4. Start dragging operations for WndMover
5. After dragging is complete...
-- move the static window to the new position (same as WndMover)
-- make static window visible again
6. Destroy WndMover

Logic similar to above prevents having to relocate all your image windows when the owner window is moved or resized because the image windows are children, not top-level windows.

Would it be possible to forget that and use an ownerdrawn Static control?

That requires subclassing, but so does stuff like handling the mouse.

Something like this VB6 demo that uses a UserControl to stand in for a Static control? Here I only used the UserControl's plumbing for stuff like the mousing. The scaling and drawing is all API calls.

The demo just uses SourceConstantAlpha not per-pixel alpha, but it does offer a mechanism to simulate layering. The UserControl's Paint event stands in for WM_DRAWITEM.

Attachment 178946

The scrollbar is just used to vary the alpha level from 255 (startup) down to 64.

Quote:

---

Originally Posted by LaVolpe

Edited:

Code:

---

Private Declare Function ScreenToClient Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As Any) As Long
Private Declare Function SetRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function IntersectRect Lib "user32.dll" (ByRef lpDestRect As RECT, ByRef lpSrc1Rect As RECT, ByRef lpSrc2Rect As RECT) As Long


    Dim stRect As RECT
   
    GetWindowRect hStatic, tStaticRect
    ' find intersection between form & static bounds
    If IntersectRect(stRect, tFormChildRect, tStaticRect) = 0 Then
        ' 2 rects do not intersect; hStatic is completely off Owner form
        Stop
    End If
   
    ' align from screen to hStatic
    ScreenToClient hStatic, stRect.Left
    ScreenToClient hStatic, stRect.Right
    ' create region and apply to hStatic
    hStaticRgn = CreateRectRgn(stRect.Left, stRect.Top, stRect.Right, stRect.Bottom)
    Debug.Print SetWindowRgn(hStatic, hStaticRgn, True)
    ' don't delete regions used with SetWindowRgn

---

---

thanks LaVolpe.

The IntersectRect API + a couple of tweaks seem to be the answer instead of using CombineRgn\RGN_AND.

Quote:

---

Debug.Print SetWindowRgn(hStatic, hStaticRgn, True)
' don't delete regions used with SetWindowRgn

---

Won't that cause a memory leak.

In fact, I got the code working, but after a couple of dozens of draging operations, the screen freezes probably a symptom of a memory leak somewhere... This issue happens whether I delete the hStaticRng or not.

Note: The only open graphical handle I have inside the dragging loop is hStaticRgn (ie: no DC handles, bitmap handles ... etc )

Any idea what might be causing the freezing of the screen and eventual crashing after a few loops.

Quote:

---

Originally Posted by dilettante

Would it be possible to forget that and use an ownerdrawn Static control?

That requires subclassing, but so does stuff like handling the mouse.

Something like this VB6 demo that uses a UserControl to stand in for a Static control? Here I only used the UserControl's plumbing for stuff like the mousing. The scaling and drawing is all API calls.

The demo just uses SourceConstantAlpha not per-pixel alpha, but it does offer a mechanism to simulate layering. The UserControl's Paint event stands in for WM_DRAWITEM.

The scrollbar is just used to vary the alpha level from 255 (startup) down to 64.

---

Thanks dilettante.

I'll take a look at that attached file. I am sure I'll learn from it. But for the time being, I am trying to avoid subclassing as much as possible.

Ok - I seem to have succeeded in doing this and the memory leak that I was experiencng was due to a silly mistake as I was creating the Static Region twice.

Here is the final result... Looks quite good after all ! (looks and feels just like a true semi-transparent draggable child window with a frame )


https://www.vbforums.com/images/ieimages/2020/10/4.gif


Thanks everyone for helping me with this.

Can you post the method you ended up using please.

Quote:

---

Originally Posted by Steve Grant

Can you post the method you ended up using please.

---

I'll finish cleaning up the code and I'll post the code and a file demo later.

Quote:

---

Originally Posted by JAAFAR

Ok - I seem to have succeeded in doing this

---

Damn that looks fantastic! I've barely messed around with UI in VBA and have for a long while been yearning for a custom canvas control. Also been wanting to add a "highlight" function to my stdAcc library. I could surely learn a thing or two from your code when you get around to posting it.

Quote:

---

Originally Posted by JAAFAR

thanks LaVolpe.

The IntersectRect API + a couple of tweaks seem to be the answer instead of using CombineRgn\RGN_AND.

Quote:

---

Debug.Print SetWindowRgn(hStatic, hStaticRgn, True)
' don't delete regions used with SetWindowRgn

---

Won't that cause a memory leak.

In fact, I got the code working, but after a couple of dozens of draging operations, the screen freezes probably a symptom of a memory leak somewhere... This issue happens whether I delete the hStaticRng or not.

---

You discovered your leak which was due to a logic error. But regarding the question above, since it was not answered, I'll answer it should anyone come to this thread and be unsure... When in doubt, never take someone's statement as proof. Go to the source. In this case, looking at the remarks in MSDN documentation for SetWindowRgn, you will see these statements. That should be a definitive answer. The bolding was added by me:

Quote:

---

After a successful call to SetWindowRgn, the system owns the region specified by the region handle hRgn. The system does not make a copy of the region. Thus, you should not make any further function calls with this region handle. In particular, do not delete this region handle. The system deletes the region handle when it no longer needed.

---

So to prevent any leaks when using SetWndowRgn...

Code:

---

If SetWindowRgn(targetHwnd, newRgnHandle, True) = 0 Then
    DeleteObject newRgnHandle
    ' perform any other fallback logic if needed
Else
    ' perform any other logic as needed after region was applied
End If

---

@Steve Grant @sancarn

File Demo

This is what I ended up with:

- Allows moving and\or copying the images.
- The static control is semi-transparent and confined within the bounderies of the parent form.
- A colored border frame is drawn around the static control.
- The cursor changes dynamically depending on moving the images, copying them (Holding CTRL key down) or when -the image is being moved outside the parent form. (custom cursor not showing on the Gif below but works as expected in the file demo above)
- Right-click context menu for deleting the images.
- A label control can optionally be integrated into the class for displaying the current activity.

This is the Only Class Method that hooks the images :
Public Sub HookControl(ByVal ThisClassInstance As cls_DraggableControl, ByVal Ctrl As Control, Optional ByVal UILabel As Control)




https://www.vbforums.com/images/ieimages/2020/10/5.gif



There remains one issue that I haven't been able to solve and that is the transparency of the layered static control doesn't work if the machine's Desktop Composition has been disabled.

I have made a few attempts to resolve this problem by changing the Static Control owner, by using the UpdateLayeredWindow API to update the control ... etc but with no success.

Does anyone have an idea if\how this remaining issue could be addressed ?

Thanks.

Hi Jaafar, I've downloaded the demo but it is just an XLS file. No Code!

Quote:

---

Originally Posted by Steve Grant

Hi Jaafar, I've downloaded the demo but it is just an XLS file. No Code!

---

The uploaded demo file has all the code in it ...

Maybe the file is being opend in Protected View in which case you will have to Enable editing when being propmted upon opening... Also, make sure Macros are enabled.

Attachment 178963

I am trying to convert to vb6, but I got "out of memory". I thought I could do wrongly.

Code:

---

Set AddNewControl = Container.Controls.Add("Forms.Image.1")

---

Quote:

---

Originally Posted by DaveDavis

I am trying to convert to vb6, but I got "out of memory". I thought I could do wrongly.

Code:

---

Set AddNewControl = Container.Controls.Add("Forms.Image.1")

---

---

That code will only work in vba and requires the native msforms library that is integrated in office applications.

Why do you need to convert this from vba to vb6 when vb6 and its forms library are far richer than vba and offer the programmer plenty more tools than vba for achieving the same thing.

You should be able to find vb6 code examples if you look google around- For example, have you seen this thread here from fellow member dilettante?

Quote:

---

Originally Posted by JAAFAR

That code will only work in vba and requires the native msforms library that is integrated in office applications.

Why do you need to convert this from vba to vb6 when vb6 and its forms library are far richer than vba and offer the programmer plenty more tools than vba for achieving the same thing.

You should be able to find vb6 code examples if you look google around- For example, have you seen this thread here from fellow member dilettante?

---

your code is running ok in excel and it is good stuff to please our kids. Please do us a favor to write in vb6 if you got time..

FWIW, here's an RC5-based version for VB6, which does basically the same thing as the Excel-VBA-Demo...

One will need an empty VB6-Form-Project (with a reference to vbRichClient5),
and then add the following into a new VB6-(Widget)ClassModule, with the Name: cwMyImage

Code:

---

Option Explicit

Private WithEvents W As cWidgetBase, CtrlDown As Boolean

Private Sub Class_Initialize()
  Set W = Cairo.WidgetBase 'instantiate the internal W-WidgetBase
      W.Moveable = True    'make this widget moveable
End Sub

Property Get Widget():  Set Widget = W:          End Property 'the 2 default-Props, every cwClass requires
Property Get Widgets(): Set Widgets = W.Widgets: End Property
 
Private Sub W_MouseDown(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single)
  If Shift And vbCtrlMask Then CtrlDown = True Else W.MoveToFront
End Sub
Private Sub W_MouseMove(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single)
  If CtrlDown Then CtrlDown = False: W.RaiseBubblingEvent Me, "CopyMe": W.MoveToFront
End Sub
Private Sub W_MouseUp(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single)
  CtrlDown = False: W.Refresh
End Sub

Private Sub W_Paint(CC As vbRichClient5.cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object)
  CC.RenderSurfaceContent W.ImageKey, 0, 0, dx_Aligned, dy_Aligned, , IIf(W.MouseOver And W.Root.MouseKeyDown, 0.5, 1)
  If W.Focused Then Cairo.Theme.DrawTo CC, W, thmTypeBorder, thmStateSolidColor, 0, 0, dx_Aligned, dy_Aligned
End Sub

---

The above Class will later on "host" and render the Images ...defined via Image(Resource)Key.

What remains is the Code for the hosting VB6-Form:

Code:

---

Option Explicit

Private WithEvents Panel As cWidgetForm
 
Private Sub Form_Load()
  Caption = "Ctrl-Key for copy, DblClick for remove"
 
  Cairo.ImageList.AddIconFromResourceFile "imgBricks", "shell32", 167 'add two test-img-resources from shell32
  Cairo.ImageList.AddIconFromResourceFile "imgBtrFly", "shell32", 239
 
  Set Panel = Cairo.WidgetForms.CreateChild(hWnd) 'create a hosting Panel-Container-Object for the ImageWidgets
  AddImageWidget "imgBricks", 22, 22 'and finally add two Widget-instances (which make use of the above ensured Image-Resources)
  AddImageWidget "imgBtrFly", 99, 99
End Sub

Private Sub Form_Resize() 'ensure, the Widget-Parent-Panel covers the whole Form-ClientArea
  ScaleMode = vbPixels: Panel.Move 0, 0, ScaleWidth, ScaleHeight
End Sub

Private Sub AddImageWidget(ImageKey As String, ByVal x&, ByVal y&) 'Helper, which adds a new Widget
  Static kc@: kc = kc + 1 '<- to ensure an "ever increasing, unique Widgetkey"
  Panel.Widgets.Add(New cwMyImage, "K_" & kc, x, y, 64, 64).Widget.ImageKey = ImageKey
End Sub

Private Sub Panel_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant)
  Dim W As cWidgetBase: Set W = Sender.Widget 'derive the WidgetBase from the Sender-Widget
  Select Case EventName 'and act accordingly, depending on the EventName
    Case "CopyMe":    AddImageWidget W.ImageKey, W.Left, W.Top
    Case "W_DblClick": Panel.Widgets.Remove W.Key: Panel.Refresh
  End Select
End Sub

---

HTH

Olaf