How to make UserForm Frame Controls transparent

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,806
Office Version
  1. 2016
Platform
  1. 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:
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 Sub

2- 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 Sub

One limitation is that the code will not work propperly with Modeless Useforms.
 
Last edited:

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Hallo Jaafar Tribak

The <acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-top-style: initial; border-right-style: initial; border-bottom-style: dotted; border-left-style: initial; border-top-color: initial; border-right-color: initial; border-bottom-color: rgb(0, 0, 0); border-left-color: initial; border-image: initial; cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">vba</acronym> for making frame controls transparent in userforms.


Test Excel 2016Pro 64 Bit Ok

- I detect extreme slowness by moving form,
- Background applications refer to the locations present at the start of the form
 
Upvote 0
Hallo Jaafar Tribak



Test Excel 2016Pro 64 Bit Ok

- I detect extreme slowness by moving form,
- Background applications refer to the locations present at the start of the form

Thanks for the feedback ISY.

1- "I detect extreme slowness by moving form,"

The slowness I experienced when moving the form around was hardly noticeable.. I tested the code in a couple of different PCs and the slowness was minimal on all of them.

Having said that, I know what is causing this slight lag. The culprit is the following section in the code:
Code:
[COLOR=#333333]SavePicture oPic, Environ("Temp") & "\" & frm.Name & ".bmp"
[/COLOR][COLOR=#333333]Set frm.Picture = LoadPicture(Environ("Temp") & "\" & frm.Name & ".bmp") [/COLOR][COLOR=#333333]
[/COLOR][COLOR=#333333]Kill Environ("Temp") & "\" & frm.Name & ".bmp"[/COLOR]

In theory, the following should work:
Code:
[COLOR=#574123] Set frm.Picture = oPic[/COLOR]
Without having to first save the bitmap to disk and then re-load it. Unfortunately, for some reason that didn't work... I'll investigate this issue further

2- "Background applications refer to the locations present at the start of the form"

Yes that's true.

In order to refresh the screen when its state changes, I tried brievely hiding and showing the userform to allow for taking a fresh shot of the screen underneath the userform but that didn't work fast enough... I' have different approach in mind which, if successful, I'll post the results here afterwards.
 
Last edited:
Upvote 0
Very impressive, Jaafar. I tested your workbook on Windows 10 64-bit and Excel 2016 32-bit and there was no sign of slowness when dragging the userform around the screen (i7-6700HQ CPU).

It also works with the modeless userform:

Code:
    UserForm1.Show vbModeless
and I couldn't see any difference with the modal userform.
 
Last edited:
Upvote 0
Hallo

A possibility by cutting the form
Original code in vb6 and adapted in vba

Code:
Sub Test()
  Userform1.Show vbModeless
End Sub

1- Add a new Class Module to the VbProject
Code:
' *********************************************************************
'  Copyright ©2002-05 Karl E. Peterson, All Rights Reserved
'  http://vb.mvps.org
' *********************************************************************
'  You are free to use this code within your own applications, but you
'  are expressly forbidden from selling or otherwise distributing this
'  source code without prior written consent.
' *********************************************************************
Option Explicit


Public Function WindowProc(hWnd As Long, msg As Long, wp As Long, lp As Long) As Long
   ' Stub to be used with MHookMe.bas
End Function
2- And here is how to implement the Class code in the UserForm Module :
Code:
Option Explicit
Option Compare Text


Private Type POINTAPI
    X As Long
    Y As Long
End Type


#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
#End If


Private Sub UserForm_Initialize()
Const RGN_DIFF = 4


Dim outer_rgn As Long
Dim inner_rgn As Long
Dim combined_rgn As Long
Dim wid As Single
Dim hgt As Single
Dim border_width As Single
Dim title_height As Single


'    If WindowState = vbMinimized Then Exit Sub
    
    ' Create the regions.
    wid = Me.Width * 1.35 'ScaleX(Width, vbTwips, vbPixels)
    hgt = Me.Height * 1.35 'ScaleY(Height, vbTwips, vbPixels)
    outer_rgn = CreateRectRgn(0, 0, wid, hgt)
    
    border_width = (wid)
    title_height = hgt - border_width
    inner_rgn = CreateRectRgn( _
        wid * 0.25, hgt * 0.25, _
        wid * 0.75, hgt * 0.75)


    ' Subtract the inner region from the outer.
    combined_rgn = CreateRectRgn(0, 0, 0, 0)
    CombineRgn combined_rgn, outer_rgn, _
        inner_rgn, RGN_DIFF
Dim hWnd
hWnd = FindWindow("ThunderDFrame", Me.Caption)
    ' Restrict the window to the region.
    SetWindowRgn hWnd, combined_rgn, True
    
End Sub
 
Upvote 0
Very impressive, Jaafar. I tested your workbook on Windows 10 64-bit and Excel 2016 32-bit and there was no sign of slowness when dragging the userform around the screen (i7-6700HQ CPU).

It also works with the modeless userform:

Code:
    UserForm1.Show vbModeless
and I couldn't see any difference with the modal userform.

Hi John,

When using a modeless form, the user can for example move a window, activate another worksheet or simply update a cell while the form is showing and those new changes will not show under the frames.
 
Upvote 0
@ISY

The SetWindowRgn API approach has two major issues so It won't be useful for what we are doing here :

1- It prevents the drawing of any existing controls located inside the frame controls. This is because the whole region becomes excluded from painting.

2- The userform title bar (caption) loses its normal look and the reverts to the Windows Classic appearance !
 
Last edited:
Upvote 0
Version 2 ... Works with Modal as well as Modeless userforms .

Workbook Demo

Since this new code uses a Windows Timer, I have paid special attention to defensive error handling in order to avoid potential crashings should an unhandled error occur while the form is being used.


1- Class Module code : (CTransparentFrameMaker)
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 StdPicture) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function DwmGetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As LongPtr, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetShellWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private hMemDc As LongPtr, hUserForm 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 StdPicture) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As Long) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function DwmGetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As Long, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetShellWindow Lib "user32" () As Long
    Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
    Private hMemDc As Long, hUserForm As Long
#End If

Private Const SRCCOPY = &HCC0020
Private Const PICTYPE_BITMAP = &H1
Private Const SM_CYFRAME = 33
Private Const GW_HWNDPREV = 3
Private Const HORZ = 8
Private Const VERT = 10
Private Const DWMWA_CLOAKED = 14

Private WithEvents oCmbars As CommandBars
Private WithEvents oForm As UserForm

Private arFramesArray() As Control
Private arWindowsArray() As Variant
Private i As Long

Private Sub Class_Initialize()
    i = -1
    VBA.AppActivate Application.Caption
    Call BuildCurrentWindowsConfigurationArray
    Call CreateMemDC
    Set oCmbars = Application.CommandBars
End Sub

Private Sub Class_Terminate()
    KillTimer Application.hwnd, 0
    DeleteDC hMemDc
End Sub


'====================
' Class Methods.
'====================
Public Sub AddFrame(ByVal Frame As Control)
    i = i + 1
    ReDim Preserve arFramesArray(i)
    Set arFramesArray(i) = Frame
    Set oForm = GetUserForm(Frame)
    Set oClassInstance = Me
    Call IUnknown_GetWindow(oForm, hUserForm)
    DoEvents
    Application.OnTime Now, "TimerProc"
End Sub

'WARNING::: This Method must not to be called from code !!!!!!!!!
'=======
Public Sub Do_Not_Use_ThisTimerMethod(Optional ByVal Flag As String)
    
    #If VBA7 Then
        Dim hwnd As LongPtr
    #Else
        Dim hwnd As Long
    #End If

    Dim tWindowRect As RECT
    Dim sJointArray As String
   
    KillTimer Application.hwnd, 0

    If Flag <> "CalledFromTimer" Then
        Err.Raise vbObjectError + 513, , "You can't call 'CTransparentFrameMaker::Do_Not_Use_ThisTimerMethod' from code."
        End
    End If

    sJointArray = Join(arWindowsArray, "-")
    hwnd = GetShellWindow
    
    Do While hwnd <> 0
        If GetParent(hwnd) = 0 Then
            If IsWindowVisible(hwnd) And IsIconic(hwnd) = 0 And hwnd <> hUserForm Then
                GetWindowRect hwnd, tWindowRect
                With tWindowRect
                    If InStr(1, sJointArray, .Left & .Top & .Right - .Left & .Bottom - .Top & hwnd) = 0 Then
                        Call BuildCurrentWindowsConfigurationArray
                        Call TakeScreenShot
                        oForm_Layout
                        GoTo Xit
                    End If
                End With
            End If
        End If
        hwnd = GetNextWindow(hwnd, GW_HWNDPREV)
    Loop
Xit:
    If IsWindow(hUserForm) = 0 Then KillTimer Application.hwnd, 0: Set oClassInstance = Nothing: Exit Sub
    Call SetTimer(Application.hwnd, 0, 250, AddressOf TimerProc)
End Sub


'====================
'Supporting routines.
'====================
Private Sub CreateMemDC()

    #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 lScrWidth As Long
    Dim lScrHeight As Long

    scrDc = GetDC(0)
    lScrWidth = GetDeviceCaps(scrDc, HORZ)
    lScrHeight = GetDeviceCaps(scrDc, VERT)
    hMemDc = CreateCompatibleDC(scrDc)
    hMemBmp = CreateCompatibleBitmap(scrDc, lScrWidth, lScrHeight)
    SelectObject hMemDc, hMemBmp
    Call TakeScreenShot
    ReleaseDC 0, scrDc
    DeleteObject hMemBmp
End Sub

Private Sub TakeScreenShot()

    #If VBA7 Then
        Dim hwnd As LongPtr, hDC As LongPtr, hShellDC As LongPtr
        Dim lWindowAttribute As LongPtr, hLib As LongPtr, hProc As LongPtr
    #Else
        Dim hwnd As Long, hDC As Long, hShellDC As Long
        Dim lWindowAttribute As Long, hLib As Long, hProc As Long
    #End If

    Dim tWindowRect As RECT

    On Error Resume Next
    
    hwnd = GetShellWindow
    hShellDC = GetWindowDC(hwnd)
    GetWindowRect hwnd, tWindowRect
    
    With tWindowRect
    
        BitBlt hMemDc, 0, 0, .Right - .Left, .Bottom - .Top, hShellDC, 0, 0, SRCCOPY
        ReleaseDC hwnd, hShellDC
        hLib = LoadLibrary("dwmapi.dll")
        
        Do While hwnd <> 0
            If IsWindowVisible(hwnd) And IsIconic(hwnd) = 0 And hwnd <> hUserForm Then
                GetWindowRect hwnd, tWindowRect
                hDC = GetWindowDC(hwnd)
                If hLib Then
                    hProc = GetProcAddress(hLib, "DwmGetWindowAttribute")
                    If hProc Then
                        CallWindowProc hProc, hwnd, DWMWA_CLOAKED, VarPtr(lWindowAttribute), LenB(lWindowAttribute)
                        If lWindowAttribute = 0 Then
                            BitBlt hMemDc, .Left, .Top, .Right - .Left, .Bottom - .Top, hDC, 0, 0, SRCCOPY
                        End If
                    End If
                Else
                    BitBlt hMemDc, .Left, .Top, .Right - .Left, .Bottom - .Top, hDC, 0, 0, SRCCOPY
                End If
            End If
            hwnd = GetNextWindow(hwnd, GW_HWNDPREV)
        Loop
        
        FreeLibrary hLib
        
    End With
    
    ReleaseDC hwnd, hDC
    Call oForm_Layout
End Sub


Private Sub BuildCurrentWindowsConfigurationArray()
    
    #If VBA7 Then
        Dim hwnd As LongPtr
    #Else
        Dim hwnd As Long
    #End If
    
    Dim i As Long
    Dim tWindowRect As RECT
    
    hwnd = GetShellWindow
    
    Do While hwnd <> 0
        If GetParent(hwnd) = 0 Then
            If IsWindowVisible(hwnd) And IsIconic(hwnd) = 0 And hwnd <> hUserForm Then
                GetWindowRect hwnd, tWindowRect
                ReDim Preserve arWindowsArray(i)
                With tWindowRect
                    arWindowsArray(i) = .Left & .Top & .Right - .Left & .Bottom - .Top & hwnd
                End With
                i = i + 1
            End If
        End If
        hwnd = GetNextWindow(hwnd, GW_HWNDPREV)
    Loop
End Sub


Private Sub UpdateFrameBackGround(ByVal frm As Control)
    #If VBA7 Then
        Dim hTempMemDC As LongPtr, hMemBmp As LongPtr
    #Else
        Dim hTempMemDC As Long, hMemBmp As Long
    #End If
    
    Dim tFrameRect As RECT
    Dim oPic As StdPicture

    GetWindowRect frm.[_GethWnd], tFrameRect
    With tFrameRect
        hTempMemDC = CreateCompatibleDC(hMemDc)
        hMemBmp = CreateCompatibleBitmap(hMemDc, .Right - .Left, .Bottom - .Top)
        SelectObject hTempMemDC, hMemBmp
        BitBlt hTempMemDC, 0, 0, .Right - .Left, .Bottom - .Top, hMemDc, .Left, .Top + GetSystemMetrics(SM_CYFRAME), SRCCOPY
    End With
    
    Set oPic = CreatePic(hMemBmp)
    SavePicture oPic, Environ("Temp") & "\" & frm.Name & ".bmp"
    Set frm.Picture = LoadPicture(Environ("Temp") & "\" & frm.Name & ".bmp")
    Kill Environ("Temp") & "\" & frm.Name & ".bmp"
    DeleteObject hMemBmp
    DeleteDC hTempMemDC
End Sub


#If VBA7 Then
    Private Function CreatePic(ByVal hbmp As LongPtr) As StdPicture
#Else
    Private Function CreatePic(ByVal hbmp As Long) As StdPicture
#End If

    Dim IID_IDispatch As GUID
    Dim uPicinfo As PICTDESC
    Dim IPic As StdPicture

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    With uPicinfo
        .Size = LenB(uPicinfo) '
        .Type = PICTYPE_BITMAP
        .hPic = hbmp
        .hPal = 0
    End With
    
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, 1, IPic
    Set CreatePic = IPic
End Function

Private Function GetUserForm(ByVal Frame As Control) As Object
    
    Dim obj As Object
    Dim oTmpObj As Object
    
    On Error GoTo Xit
    
    Set oTmpObj = Frame.Parent
    Do
        Set obj = oTmpObj.Parent
        Set oTmpObj = obj
    Loop Until obj Is Nothing
Xit:
    Set GetUserForm = oTmpObj
End Function

'====================
' Event routines.
'====================
Private Sub oCmbars_OnUpdate()
    TakeScreenShot
    oForm_Layout
End Sub

Private Sub oForm_Layout()
    Dim j As Long
    For j = LBound(arFramesArray) To UBound(arFramesArray)
        UpdateFrameBackGround arFramesArray(j)
    Next
End Sub

2- Standard Module code:
Code:
Option Explicit

Public oClassInstance As Object

#If VBA7 Then
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If


Public Sub TimerProc()
    On Error GoTo Xit
    Call CallByName(oClassInstance, "Do_Not_Use_ThisTimerMethod", VbMethod, "CalledFromTimer")
    Exit Sub
Xit:
    KillTimer Application.hwnd, 0
    Set oClassInstance = Nothing
End Sub

3- Implementation code in the UserForm Module :
Code:
Option Explicit

Public 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 Sub

Code tested in Win7 and Win10 ... I would be happy to know if this also works in versions of Windows prior to Vista such as XP.
 
Last edited:
Upvote 0
Hello from france
woaw! So much line of code for that!!?

If your wish is simply to make the controls "frame" completely transparent this is enough ample

it's very easy with the user32.dll api only

look that
Code:
Const WS_EX_LAYERED As Long = &H80000
Const LWA_COLORKEY As Long = &H1
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub CommandButton1_Click()
    Dim MeHwnd As Long, Lcolor
    'francais Recupere le handle de la fenêtre
    'anglais capture the form handle
    MeHwnd = FindWindowA(vbNullString, Me.Caption)
    'francais determine la couleur a supprimer
    'anglais determine the color off suppress
    Lcolor = Me.Frame1.BackColor
    'francais Rajoute l'attribut transparent à la fenêtre..(canal alpha pour tout la fenetre)
    'anglais add canal alpha(blind transparency)in  all surface off form
    SetWindowLong MeHwnd, -20, &H101 Or WS_EX_LAYERED
    'francais application de la transparence sur la couleur des frames
    'anglais apply transparency to the color of frame.color in all form inside 
    SetLayeredWindowAttributes MeHwnd, Lcolor, 255, LWA_COLORKEY


End Sub

it"s all you need
 
Upvote 0
Non Monsieur Patrick :)

You code makes the whole userform transparent not just the frames within it.

Also, any controls located inside the form or inside the frame(s) will be transparent as well which is not what we are discussing in this thread.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,818
Messages
6,181,151
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top