using a transparent image for userform label or frame

B

bradyboyy88

Well-known Member
Joined
Feb 25, 2015
Messages
562
I need to assign an image to the picture attribute of a label or frame. The only issue is the image has transparency to it. Is there any format that excel supports which allows transparency or a way to make this work?
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Sort by date Sort by votes
So it seems bitmaps support transparency but when I tried it I guess the resoloution of the bitmap file was not so great so it looked like just a bunch of boxes or a checkerboard lol.
 
Upvote 0
I am not sure I understand. Do you want the picture in the image or frame control to be transparent\semi-transparent so that you can see through it what is underneath it ? If so, do you have anything underneath that you want to be seen like for example another control or something ? And if there is nothing underneath then all you will see is the userform background which is useless .

If you can clearly and logically explain what you need maybe someone would help.
 
Upvote 0
Jaafar Tribak said:
I am not sure I understand. Do you want the picture in the image or frame control to be transparent\semi-transparent so that you can see through it what is underneath it ? If so, do you have anything underneath that you want to be seen like for example another control or something ? And if there is nothing underneath then all you will see is the userform background which is useless .

If you can clearly and logically explain what you need maybe someone would help.
Click to expand...

An example of what I am trying to create would be similar to this example. I have a company website I put together using this link:
https://www.chesapeaketees.com/

Click on the menu item contact us at the top.

This is the effect I am trying to create in excel. Imagine your browser window being the userform. The frame inside the userform is the popup box with all the content. And the semi transparent background is either a label or another frame set to the width and height of the userform and the picture attribute being set to some semi transparent image type which is png or bitmap or whatever I could make work.

To answer your question, there is stuff that needs to be seen under this semi transparent background, in fact all of the content on the userform should still be there just under this overlay similar to the effect on my website. Does that make sense?
 
Upvote 0
Ok - So you want the userform to be dimmed except the foreground frame - Right ?

I don't think that achieving that dimmed visual effect will be a sipmle task. I'll try using some GDI API calls to see if I can pull this through.

If I get a staisfying result , I'll post the code here.
 
Last edited:
Upvote 0
Hi bradyboyy88,

I seem to have managed to get something that works for obtaining a dim effect on the userform similar to the visual effect in the link you provided... I wrote and tested the code on Excel2010 64bit; Win10 64Bit.

Description :

1- The userform has a frame control placed in the middle with an image in the frame... The whole userform surface will become dimmed including any existing controls EXCEPT the above mentioned frame which will stay bright as it is excluded from the dimming area of the userform.

2- Clicking on any part of the userform outside the above frame will remove the dimming effect.

Workbook Demo

1- Code in a Standard module :
Code: 
Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    X As Long
    y As Long
End Type

Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     #End If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    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 DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    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 SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private hwnd As LongPtr, lPrevProc As LongPtr
#Else
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (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 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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT 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 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 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 GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private hwnd As Long, lPrevProc As Long
#End If

Private Const GWL_WNDPROC = (-4)
Private Const WM_NCDESTROY = &H82
Private Const WM_ERASEBKGND = &H14
Private Const WM_EXITSIZEMOVE = &H232
Private Const WM_MOVE = &H3
Private Const WM_PARENTNOTIFY = &H210
Private Const WM_SETREDRAW = &HB
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const POINTSPERINCH = 72
Private Const AC_SRC_OVER = &H0
Private Const SRCCOPY = &HCC0020
Private Const BRIGHTNESS = 60 [COLOR=#008000]'Change as required from (0 TO 255)[/COLOR]

Private oForm As UserForm
Private oExcludeCtrl As Control


Sub DimTheForm(ByVal Form As UserForm, ExcludedControl As Control)

    Set oForm = Form
    Set oExcludeCtrl = ExcludedControl
    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
    Call WindowFromAccessibleObject(Form, hwnd)
    With oExcludeCtrl
        If .Visible = True Then
            .Visible = False
            .BorderStyle = fmBorderStyleNone
            .Caption = ""
        End If
    End With
    Application.OnTime Now, "DimNow"
    lPrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
End Sub

Private Sub DimNow()
    #If VBA7 Then
        Dim hdc As LongPtr, hMemDC As LongPtr, hBmp As LongPtr
    #Else
        Dim hdc As Long, hMemDC As Long, hBmp As Long
    #End If
    Dim BF As BLENDFUNCTION, lBF As Long

    With oForm
        .Repaint
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = BRIGHTNESS [COLOR=#008000]'<== Change as required from (0 TO 255)[/COLOR]
            .AlphaFormat = 0
        End With
        CopyMemory lBF, BF, 4
        hdc = GetDC(hwnd)
        hMemDC = CreateCompatibleDC(hdc)
        hBmp = CreateCompatibleBitmap(hdc, PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True))
        DeleteObject SelectObject(hMemDC, hBmp)
        AlphaBlend hMemDC, 0, 0, PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True), hdc, 0, 0, _
        PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True), (lBF)
        BitBlt GetDC(hwnd), 0, 0, PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True), hMemDC, 0, 0, SRCCOPY
    End With
    oExcludeCtrl.Visible = True
    ReleaseDC hwnd, hdc
    DeleteDC hMemDC
    DeleteObject hBmp
End Sub

Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC
 
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
 
Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

#If VBA7 Then
Private Function WinProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim hwndCtrl As LongPtr
#Else
Private Function WinProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hwndCtrl As Long
#End If

    Dim tRect As RECT
    Dim tCurPos As POINTAPI
    Dim tPt1 As POINTAPI
    Dim tPt2 As POINTAPI
    
    Select Case uMsg
        Case WM_PARENTNOTIFY
            hwndCtrl = oExcludeCtrl.[_GethWnd]
            Call GetClientRect(hwndCtrl, tRect)
            With tRect
                tPt1.X = tRect.Left: tPt1.y = tRect.Top
                tPt2.X = tRect.Right: tPt2.y = tRect.Bottom
            End With
            ClientToScreen hwndCtrl, tPt1
            ClientToScreen hwndCtrl, tPt2
            GetCursorPos tCurPos
            With tCurPos
                If .X < tPt1.X Or .X > tPt2.X Or .y < tPt1.y Or .y > tPt2.y Then
                    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
                    oForm.Repaint
                Else
                    Call DimTheForm(oForm, oExcludeCtrl)
                End If
            End With
        Case WM_MOVE, WM_ERASEBKGND
            SendMessage hwnd, ByVal WM_SETREDRAW, 0, 0
        Case WM_EXITSIZEMOVE
            SendMessage hwnd, ByVal WM_SETREDRAW, 1, 0
        Case WM_NCDESTROY
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
    End Select
    
    WinProc = CallWindowProc(lPrevProc, hwnd, uMsg, wParam, lParam)
End Function

2- To dim the UserForm :
Code: 
Private Sub CommandButton1_Click()
    Call DimTheForm(Form:=Me, ExcludedControl:=Me.Frame1)
End Sub
 
Last edited:
Upvote 0
Jaafar Tribak said:
Hi bradyboyy88,

I seem to have managed to get something that works for obtaining a dim effect on the userform similar to the visual effect in the link you provided... I wrote and tested the code on Excel2010 64bit; Win10 64Bit.

Description :

1- The userform has a frame control placed in the middle with an image in the frame... The whole userform surface will become dimmed including any existing controls EXCEPT the above mentioned frame which will stay bright as it is excluded from the dimming area of the userform.

2- Clicking on any part of the userform outside the above frame will remove the dimming effect.

Workbook Demo

1- Code in a Standard module :
Code: 
Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    X As Long
    y As Long
End Type

Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    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 DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    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 SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private hwnd As LongPtr, lPrevProc As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (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 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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT 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 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 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 GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private hwnd As Long, lPrevProc As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const GWL_WNDPROC = (-4)
Private Const WM_NCDESTROY = &H82
Private Const WM_ERASEBKGND = &H14
Private Const WM_EXITSIZEMOVE = &H232
Private Const WM_MOVE = &H3
Private Const WM_PARENTNOTIFY = &H210
Private Const WM_SETREDRAW = &HB
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const POINTSPERINCH = 72
Private Const AC_SRC_OVER = &H0
Private Const SRCCOPY = &HCC0020
Private Const BRIGHTNESS = 60 [COLOR=#008000]'Change as required from (0 TO 255)[/COLOR]

Private oForm As UserForm
Private oExcludeCtrl As Control


Sub DimTheForm(ByVal Form As UserForm, ExcludedControl As Control)

    Set oForm = Form
    Set oExcludeCtrl = ExcludedControl
    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
    Call WindowFromAccessibleObject(Form, hwnd)
    With oExcludeCtrl
        If .Visible = True Then
            .Visible = False
            .BorderStyle = fmBorderStyleNone
            .Caption = ""
        End If
    End With
    Application.OnTime Now, "DimNow"
    lPrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
End Sub

Private Sub DimNow()
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        Dim hdc As LongPtr, hMemDC As LongPtr, hBmp As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Dim hdc As Long, hMemDC As Long, hBmp As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Dim BF As BLENDFUNCTION, lBF As Long

    With oForm
        .Repaint
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = BRIGHTNESS [COLOR=#008000]'<== Change as required from (0 TO 255)[/COLOR]
            .AlphaFormat = 0
        End With
        CopyMemory lBF, BF, 4
        hdc = GetDC(hwnd)
        hMemDC = CreateCompatibleDC(hdc)
        hBmp = CreateCompatibleBitmap(hdc, PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True))
        DeleteObject SelectObject(hMemDC, hBmp)
        AlphaBlend hMemDC, 0, 0, PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True), hdc, 0, 0, _
        PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True), (lBF)
        BitBlt GetDC(hwnd), 0, 0, PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True), hMemDC, 0, 0, SRCCOPY
    End With
    oExcludeCtrl.Visible = True
    ReleaseDC hwnd, hdc
    DeleteDC hMemDC
    DeleteObject hBmp
End Sub

Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC
 
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
 
Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Function WinProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim hwndCtrl As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Function WinProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hwndCtrl As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim tRect As RECT
    Dim tCurPos As POINTAPI
    Dim tPt1 As POINTAPI
    Dim tPt2 As POINTAPI
    
    Select Case uMsg
        Case WM_PARENTNOTIFY
            hwndCtrl = oExcludeCtrl.[_GethWnd]
            Call GetClientRect(hwndCtrl, tRect)
            With tRect
                tPt1.X = tRect.Left: tPt1.y = tRect.Top
                tPt2.X = tRect.Right: tPt2.y = tRect.Bottom
            End With
            ClientToScreen hwndCtrl, tPt1
            ClientToScreen hwndCtrl, tPt2
            GetCursorPos tCurPos
            With tCurPos
                If .X < tPt1.X Or .X > tPt2.X Or .y < tPt1.y Or .y > tPt2.y Then
                    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
                    oForm.Repaint
                Else
                    Call DimTheForm(oForm, oExcludeCtrl)
                End If
            End With
        Case WM_MOVE, WM_ERASEBKGND
            SendMessage hwnd, ByVal WM_SETREDRAW, 0, 0
        Case WM_EXITSIZEMOVE
            SendMessage hwnd, ByVal WM_SETREDRAW, 1, 0
        Case WM_NCDESTROY
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
    End Select
    
    WinProc = CallWindowProc(lPrevProc, hwnd, uMsg, wParam, lParam)
End Function

2- To dim the UserForm :
Code: 
Private Sub CommandButton1_Click()
    Call DimTheForm(Form:=Me, ExcludedControl:=Me.Frame1)
End Sub
Click to expand...

The code works incredibly well so thank you!!! The only thing I cannot seem to figure out is why does clicking on the frame cause the screen to flicker? Is it due to the code that results in the dimming turning off when you click outside of the frame? You seriously are a genius though. This is incredible.
 
Upvote 0
If removing the ability to un dim by clicking off the frame is removed would that fix it? I am having trouble figuring out which segment in the module is what is allowing that.
 
Upvote 0
Try this :
Code: 
Option Explicit
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    X As Long
    y As Long
End Type

Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    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 DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    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 SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private hwnd As LongPtr, lPrevProc As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (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 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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT 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 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 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 GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private hwnd As Long, lPrevProc As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const GWL_WNDPROC = (-4)
Private Const WM_NCDESTROY = &H82
Private Const WM_ERASEBKGND = &H14
Private Const WM_EXITSIZEMOVE = &H232
Private Const WM_MOVE = &H3
Private Const WM_PARENTNOTIFY = &H210
Private Const WM_SETREDRAW = &HB
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const POINTSPERINCH = 72
Private Const AC_SRC_OVER = &H0
Private Const SRCCOPY = &HCC0020
Private Const BRIGHTNESS = 60 'Change as required from (0 TO 255)

Private oForm As UserForm
Private oExcludeCtrl As Control

Sub DimTheForm(ByVal Form As UserForm, ExcludedControl As Control)

    Set oForm = Form
    Set oExcludeCtrl = ExcludedControl
    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
    Call WindowFromAccessibleObject(Form, hwnd)
    With oExcludeCtrl
        If .Visible = True Then
            .Visible = False
            .BorderStyle = fmBorderStyleNone
            .Caption = ""
        End If
    End With
    Application.OnTime Now, "DimNow"
    lPrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
End Sub

Private Sub DimNow()
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hdc As LongPtr, hMemDC As LongPtr, hBmp As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hdc As Long, hMemDC As Long, hBmp As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    Dim BF As BLENDFUNCTION, lBF As Long

    With oForm
        .Repaint
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = BRIGHTNESS '<== Change as required from (0 TO 255)
            .AlphaFormat = 0
        End With
        CopyMemory lBF, BF, 4
        hdc = GetDC(hwnd)
        hMemDC = CreateCompatibleDC(hdc)
        hBmp = CreateCompatibleBitmap(hdc, PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True))
        DeleteObject SelectObject(hMemDC, hBmp)
        AlphaBlend hMemDC, 0, 0, PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True), hdc, 0, 0, _
        PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True), (lBF)
        BitBlt GetDC(hwnd), 0, 0, PTtoPX(.InsideWidth, False), PTtoPX(.InsideHeight, True), hMemDC, 0, 0, SRCCOPY
    End With
    oExcludeCtrl.Visible = True
    ReleaseDC hwnd, hdc
    DeleteDC hMemDC
    DeleteObject hBmp
End Sub

Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC
 
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
 
Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
Private Function WinProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim hwndCtrl As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
Private Function WinProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hwndCtrl As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim tRect As RECT
    Dim tCurPos As POINTAPI
    Dim tPt1 As POINTAPI
    Dim tPt2 As POINTAPI
    
    Select Case uMsg
        Case WM_PARENTNOTIFY
            hwndCtrl = oExcludeCtrl.[_GethWnd]
            Call GetClientRect(hwndCtrl, tRect)
            With tRect
                tPt1.X = tRect.Left: tPt1.y = tRect.Top
                tPt2.X = tRect.Right: tPt2.y = tRect.Bottom
            End With
            ClientToScreen hwndCtrl, tPt1
            ClientToScreen hwndCtrl, tPt2
            GetCursorPos tCurPos
            With tCurPos
                If .X < tPt1.X Or .X > tPt2.X Or .y < tPt1.y Or .y > tPt2.y Then
                    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
                    oForm.Repaint
                Else
                    SendMessage hwnd, ByVal WM_SETREDRAW, 0, 0
                    Application.OnTime Now, "RestoreRedraw"
                End If
            End With
        Case WM_MOVE, WM_ERASEBKGND
            SendMessage hwnd, ByVal WM_SETREDRAW, 0, 0
        Case WM_EXITSIZEMOVE
            SendMessage hwnd, ByVal WM_SETREDRAW, 1, 0
        Case WM_NCDESTROY
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
    End Select
    
    WinProc = CallWindowProc(lPrevProc, hwnd, uMsg, wParam, lParam)
End Function

Private Sub RestoreRedraw()
    SendMessage hwnd, ByVal WM_SETREDRAW, 1, 0
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Clicking on a Userform label puts its label name automatically in a textbox
Replies
3
Views
581
chazrab
C
D
  • Question
Working with images in VBA - Displaying PNG files
2
Replies
11
Views
10K
Dan_W
D
U
  • Question
Excel Ribbon button icon change effect
Replies
3
Views
548
jkpieterse
jkpieterse
novabond
  • Question
VBA to add/change loaded ´Picture´ of an Image within a UserForm
Replies
9
Views
1K
bobsan42
bobsan42
C
  • Question
Drag frames
Replies
3
Views
241
My Aswer Is This
My Aswer Is This

Forum statistics

Threads
1,214,812
Messages
6,121,699
Members
449,048
Latest member
81jamesacct

Share this page

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