Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi all,
In case anyone is interested, here is the vba for making frame controls transparent in userforms.
A couple of testings of the code revealed that it is very flexible and it is stable as it doesn't use hooking or subclassing for updating the frames backgrounds when moving around the userform. Instead, it relies entirely on the native Form's _Layout event .
Workbook Demo.
1- Add a new Class Module to the VbProject and give it the name of : CTransparentFrameMaker
Place this code in the class module:
2- And here is how to implement the Class code in the UserForm Module :
One limitation is that the code will not work propperly with Modeless Useforms.
In case anyone is interested, here is the vba for making frame controls transparent in userforms.
A couple of testings of the code revealed that it is very flexible and it is stable as it doesn't use hooking or subclassing for updating the frames backgrounds when moving around the userform. Instead, it relies entirely on the native Form's _Layout event .
Workbook Demo.
1- Add a new Class Module to the VbProject and give it the name of : CTransparentFrameMaker
Place this code in the class module:
Code:
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom 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 PICTDESC
Size As Long
Type As Long
#If VBA7 Then
hPic As LongPtr
#Else
hPic As Long
#End If
hPal As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private hMemDc As LongPtr
#Else
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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject 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 GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private hMemDc As Long
#End If
Private Const SRCCOPY = &HCC0020
Private Const PICTYPE_BITMAP = &H1
Private Const SM_CYFRAME = 33
Private Const HORZ = 8
Private Const VERT = 10
Private arFramesArray() As Control
Private i As Long
Private WithEvents oForm As UserForm
Private Sub Class_Initialize()
i = -1
VBA.AppActivate Application.Caption
Call TakeFirstScreenSnapShot
End Sub
Private Sub Class_Terminate()
DeleteDC hMemDc
End Sub
'====================
'Unique Class Method.
'====================
Public Sub AddFrame(ByVal Frame As Control)
i = i + 1
ReDim Preserve arFramesArray(i)
Set arFramesArray(i) = Frame
Set oForm = Frame.Parent
End Sub
'====================
'Supporting routines.
'====================
Private Sub UpdateFrameBackGround(ByVal frm As Control)
#If VBA7 Then
Dim hMemDc2 As LongPtr, hMemBmp2 As LongPtr
#Else
Dim hMemDc2 As Long, hMemBmp2 As Long
#End If
Dim tFrameRect As RECT
Dim oPic As IPicture
On Error Resume Next
GetWindowRect frm.[_GethWnd], tFrameRect
With tFrameRect
hMemDc2 = CreateCompatibleDC(hMemDc)
hMemBmp2 = CreateCompatibleBitmap(hMemDc, .Right - .Left, .Bottom - .Top)
SelectObject hMemDc2, hMemBmp2
BitBlt hMemDc2, 0, 0, .Right - .Left, .Bottom - .Top, hMemDc, .Left, .Top + GetSystemMetrics(SM_CYFRAME), SRCCOPY
End With
Set oPic = CreatePic(hMemBmp2)
SavePicture oPic, Environ("Temp") & "\" & frm.Name & ".bmp"
Set frm.Picture = LoadPicture(Environ("Temp") & "\" & frm.Name & ".bmp")
Kill Environ("Temp") & "\" & frm.Name & ".bmp"
DeleteObject hMemBmp2
DeleteDC hMemDc2
End Sub
#If VBA7 Then
Private Function CreatePic(ByVal hbmp As LongPtr) As IPicture
#Else
Private Function CreatePic(ByVal hbmp As Long) As IPicture
#End If
Dim IID_IDispatch As GUID
Dim uPicinfo As PICTDESC
Dim IPic As IPicture
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPicinfo
.Size = Len(uPicinfo) '
.Type = PICTYPE_BITMAP
.hPic = hbmp
.hPal = 0
End With
OleCreatePictureIndirect uPicinfo, IID_IDispatch, 1, IPic
Set CreatePic = IPic
End Function
Private Sub TakeFirstScreenSnapShot()
#If VBA7 Then
Dim scrDc As LongPtr, hMemBmp As LongPtr, hwnd As LongPtr
#Else
Dim scrDc As Long, hMemBmp As Long, hwnd As Long
#End If
Dim w As Long
Dim h As Long
scrDc = GetDC(0)
w = GetDeviceCaps(scrDc, HORZ)
h = GetDeviceCaps(scrDc, VERT)
hMemDc = CreateCompatibleDC(scrDc)
hMemBmp = CreateCompatibleBitmap(scrDc, w, h)
SelectObject hMemDc, hMemBmp
BitBlt hMemDc, 0, 0, w, h, scrDc, 0, 0, SRCCOPY
ReleaseDC 0, scrDc
DeleteObject hMemBmp
End Sub
Private Sub oForm_Layout()
Dim k As Long
For k = LBound(arFramesArray) To UBound(arFramesArray)
UpdateFrameBackGround arFramesArray(k)
Next
End Sub2- And here is how to implement the Class code in the UserForm Module :
Code:
Option Explicit
Private oCTransparent As CTransparentFrameMaker
Private Sub UserForm_Initialize()
Dim oCtl As Control
Set oCTransparent = New CTransparentFrameMaker
For Each oCtl In Me.Controls
If TypeName(oCtl) = "Frame" Then
oCTransparent.AddFrame oCtl
End If
Next
End SubOne limitation is that the code will not work propperly with Modeless Useforms.
Last edited:
