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?
You mean besides the point that this is VBA/Office apparently?
Last edited by Zvoni; Tomorrow at 31:69 PM.
----------------------------------------------------------------------------------------
One System to rule them all, One Code to find them,
One IDE to bring them all, and to the Framework bind them,
in the Land of Redmond, where the Windows lie
---------------------------------------------------------------------------------
People call me crazy because i'm jumping out of perfectly fine airplanes.
---------------------------------------------------------------------------------
Code is like a joke: If you have to explain it, it's bad
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.
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
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.
Of course to see the animation you'll need to run it.
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)
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 ?
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:
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.
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
My understanding has been that the Handle of a StdPicture object is the same as the BITMAP handle but that's probably wrong.
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
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.
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.
Insomnia is just a byproduct of, "It can't be done"
'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
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.
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
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)
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:
I think, I must be messing up the static dc with the screen dc but haven't been able figure out.
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
Last edited by LaVolpe; Oct 6th, 2020 at 03:29 PM.
Insomnia is just a byproduct of, "It can't be done"
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.
Insomnia is just a byproduct of, "It can't be done"
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.
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.
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.
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 )
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.
The IntersectRect API + a couple of tweaks seem to be the answer instead of using CombineRgn\RGN_AND.
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:
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
Last edited by LaVolpe; Oct 7th, 2020 at 11:56 AM.
Insomnia is just a byproduct of, "It can't be done"
- 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)
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 ?
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.
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?
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