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?
 
Sort by date Sort by votes
Hey Jaafar,

That fixed the problem! I am still curious though, what part of the code allows to turn the dimming of when you click outside of the frame? It would be nice to allow a parameter to enable to disable this feature and I would probably add it but a point in the right direction what is doing that would be great!

Thanks again. This is some very creative coding to make this work. Lightbox effects are used all the time in applications online so now being able to do it via userforms adds some nice aesthetics.
 
Last edited:
Upvote 0

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Jafaar,

I am still curious which part of the code controls the undimming from clicking on the transparent frame. I want to disable that for some cases.
 
Upvote 0
Hi Jafaar,
First of all, thanks again for sharing such brilliant stuff. All thumbs up.

I could slightly modify it to do exacly what I need, mainly guessing my way through your code vodoo.
Unfortunately I remain stuck with one annoyance feature, which also is present on your supplied Demo Workbook.

It only dims about 90% of the form in width as well as in height, and I cannot find out where it takes that from.
Is there any easy way to make it dim the entire form?
 
Upvote 0
pflosch said:
Hi Jafaar,
First of all, thanks again for sharing such brilliant stuff. All thumbs up.

I could slightly modify it to do exacly what I need, mainly guessing my way through your code vodoo.
Unfortunately I remain stuck with one annoyance feature, which also is present on your supplied Demo Workbook.

It only dims about 90% of the form in width as well as in height, and I cannot find out where it takes that from.
Is there any easy way to make it dim the entire form?
Click to expand...
Hi pflosch.

Sorry for not responding sooner.

I didn't experience the issue you are describing. Maybe it is due to the conversion from points to pixels of the userform InsideWidth and InsideHeight Properties.

I will post a sanitized version of the code later on and hope it will work for you.
 
Upvote 0
lol, sorry? sooner? Reply in 3 days on a 7yo thread sounds pretty much like rocket speed to me, thanks.

I meanwhile tried around a bit... so
  • It seems not related to the Windows zoom, which I have on 200% for 4k screen
  • It seems to react to the zoom setting of the userform. when I put that to 80%, the dimmed area covers the form, but it crashes when I call it the second time to "undim".
    But on 100% zoom (like in your Demo) it's not covering all.
    I am actually using the zoom property in this specific form, in order to resize it.
 
Upvote 0
Hi,

See if this works for you ... It still has a few limitations though, namely the fact that it only works with Modal userforms.

You should be able to set the desired form zoom before calling the EnableDim SUB.

The EnableDim SUB takes a ExcludedControls ParamArray for controls that you don't want to be dimmed.

FormBrightness.xlsm





1- In a Standard Module :
VBA Code: 
Option Explicit

#If Win64 Then
    Const NULL_PTR = 0^
    Const PTR_SIZE = 8&
#Else
    Const NULL_PTR = 0&
    Const PTR_SIZE = 4&
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom 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 SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF 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 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 LongPtr) 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 GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Private Declare PtrSafe Function ExtSelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr, ByVal fnMode As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function RegisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare PtrSafe Function UnregisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long) As Long
    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
#Else
    Private Enum LongPtr
        [_]
    End Enum
    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 IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare 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 LongPtr) As Long
    Private Declare 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 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 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 Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Private Declare Function ExtSelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr, ByVal fnMode As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If

Private hwnd As LongPtr, lPrevProc As LongPtr
Private hInitMemDC As LongPtr, hPrevInitBmp As LongPtr
Private hEllipRgn As LongPtr

Private oForm As UserForm
Private lBrightness As Long
Private lInitBrightness As Long
Private bInit As Boolean



Public Sub EnableDim( _
    ByVal Form As UserForm, _
    ParamArray ExcludedControls() _
)

    Const SM_CYCAPTION = 4&
    Const SM_CXBORDER = 5&
    Const SM_CXDLGFRAME = 7&
    Const RGN_OR = 2&
    
    Dim vExcludedControls() As Variant
    Dim Ctrl As MSForms.Control, oAcc As IAccessible
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim YOffset As Long, UpShift As Long
    Dim hRectRgn As LongPtr

    bInit = True
    Set oForm = Form
    Call IUnknown_GetWindow(Form, VarPtr(hwnd))
    If UBound(ExcludedControls) <> -1 Then
        vExcludedControls = ExcludedControls
    End If
    hEllipRgn = CreateRectRgn(0&, 0&, 0&, 0&)
    YOffset = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CXDLGFRAME)
    For Each Ctrl In Form.Controls
            If TypeOf Ctrl Is MSForms.TextBox Or _
                TypeOf Ctrl Is MSForms.ListBox Or IsControlExcluded(Ctrl, vExcludedControls) Then
            Set oAcc = Ctrl
            oAcc.accLocation lLeft, lTop, lWidth, lHeight, 0&
            If TypeOf Ctrl Is MSForms.ListBox Then
                UpShift = 10&
            Else
                UpShift = 0&
            End If
            hRectRgn = CreateRectRgn(lLeft - 2&, lTop - YOffset, lLeft + lWidth - 4&, _
                lTop + lHeight - YOffset - UpShift)
            Call CombineRgn(hEllipRgn, hRectRgn, hEllipRgn, RGN_OR)
            Call DeleteObject(hRectRgn)
        End If
    Next Ctrl
    Call DisableUpDownKeys
    Call HookForm(hwnd)
    Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TakeFormSnapshot)
    Call SetTimer(Application.hwnd, NULL_PTR, 0&, AddressOf TabKeyWatcher)

End Sub

Public Sub DisableDim(ByVal Form As MSForms.UserForm)
    Call Cleanup
    Call Form.Repaint
End Sub

Public Sub SetBrightness(Optional ByVal Brightness As Long)

    Const SRCCOPY = &HCC0020
    Const RGN_XOR As Long = 3&
    Const AC_SRC_OVER = &H0
    Dim hDC As LongPtr, hMemDC As LongPtr, hBmp As LongPtr, hPrevBmp As LongPtr
    Dim tBF As BLENDFUNCTION, lBF As LongPtr
    Dim tRect As RECT
    Dim lWidth As Long, lHeight As Long
    
    
    If oForm Is Nothing Then Exit Sub
    
    If Brightness < 0& Or Brightness > 255& Then
        Call Cleanup
        MsgBox "Brightness must be between 0 and 255.", , "Error."
        End
        Exit Sub
    End If
    
    lInitBrightness = Brightness
    If bInit Then bInit = False: oForm.Repaint:   Exit Sub
    lBrightness = Brightness
      
    With tBF
        .BlendOp = AC_SRC_OVER
        .BlendFlags = 0&
        .SourceConstantAlpha = Brightness  '<== (0 TO 255)
        .AlphaFormat = 0&
    End With
    Call CopyMemory(lBF, tBF, PTR_SIZE)
    hDC = GetDC(hwnd)
    Call GetClientRect(hwnd, tRect)
    With tRect
        lWidth = .Right - .Left
        lHeight = .Bottom - .Top
    End With
    hMemDC = CreateCompatibleDC(hDC)
    hBmp = CreateCompatibleBitmap(hDC, lWidth, lHeight)
    hPrevBmp = SelectObject(hMemDC, hBmp)
    Call ExtSelectClipRgn(hDC, hEllipRgn, RGN_XOR)
    Call AlphaBlend(hMemDC, 0&, 0&, lWidth, lHeight, hInitMemDC, 0&, 0&, lWidth, lHeight, lBF)
    Call BitBlt(hDC, 0&, 0&, lWidth, lHeight, hMemDC, 0&, 0&, SRCCOPY)
    Call SelectObject(hMemDC, hPrevBmp)
    Call DeleteObject(hPrevBmp)
    Call DeleteObject(hBmp)
    Call DeleteDC(hMemDC)
    Call ReleaseDC(hwnd, hDC)
    
End Sub



'_______________________________________ PRIVATE ROUTINES _____________________________________________

Private Sub Cleanup()

    Call KillTimer(Application.hwnd, NULL_PTR)
    Call HookForm(hwnd, False)
    Call DisableUpDownKeys(False)
    Call SelectObject(hInitMemDC, hPrevInitBmp)
    Call DeleteDC(hInitMemDC)
    Call DeleteObject(hPrevInitBmp)
    Call DeleteObject(hEllipRgn)
    Set oForm = Nothing
    lBrightness = 0&
    lInitBrightness = 0&
End Sub

Private Sub TakeFormSnapshot()
    Const SRCCOPY = &HCC0020
    Dim hDC As LongPtr, hInitMemBmp As LongPtr
    Dim tRect As RECT
    Dim lWidth As Long, lHeight As Long
    
    Call KillTimer(hwnd, NULL_PTR)
    Call GetClientRect(hwnd, tRect)
    lWidth = tRect.Right - tRect.Left
    lHeight = tRect.Bottom - tRect.Top
    hDC = GetDC(hwnd)
    hInitMemDC = CreateCompatibleDC(hDC)
    hInitMemBmp = CreateCompatibleBitmap(hDC, lWidth, lHeight)
    hPrevInitBmp = SelectObject(hInitMemDC, hInitMemBmp)
    Call BitBlt(hInitMemDC, 0&, 0&, lWidth, lHeight, hDC, 0&, 0&, SRCCOPY)
    Call ReleaseDC(hwnd, hDC)
    Call DeleteObject(hInitMemBmp)
    lBrightness = lInitBrightness
    DoEvents
    Call SetBrightness(lBrightness)
    
End Sub

Private Sub HookForm(ByVal hwnd As LongPtr, Optional ByVal bHook As Boolean = True)
    Const GWL_WNDPROC = (-4)
    If bHook Then
        If GetProp(hwnd, "lPrevProc") = 0 Then
            lPrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
            Call SetProp(hwnd, "lPrevProc", lPrevProc)
        End If
    Else
        If GetProp(hwnd, "lPrevProc") Then
            Call SetWindowLong(hwnd, GWL_WNDPROC, GetProp(hwnd, "lPrevProc"))
            Call RemoveProp(hwnd, "lPrevProc")
        End If
    End If
End Sub

Private Function WinProc( _
    ByVal hwnd As LongPtr, _
    ByVal uMsg As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr _
) As LongPtr

    Const WM_ACTIVATE = &H6
    Const WM_PARENTNOTIFY = &H210
    Const WM_CANCELMODE = &H1F
    Const WM_ENTERIDLE = &H121
    Const WM_SETREDRAW = &HB
    Const WM_ERASEBKGND = &H14
    Const WM_MOVE = &H3
    Const WM_EXITSIZEMOVE = &H232
    Const WM_DESTROY = &H2
    Const WM_HOTKEY = &H312


    Static bCaptureChanged As Boolean
    Dim hwndCtrl As LongPtr

    If lBrightness = 0& Then GoTo Xit
    
    If GetAsyncKeyState(VBA.vbKeyLButton) = 0& Then
        If bCaptureChanged Then
            bCaptureChanged = False
            Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
        End If
    End If
    
    Select Case uMsg
        Case WM_CANCELMODE, WM_ENTERIDLE
            If Is_Error Then
                Debug.Print "Error trapped!!"
                Call Cleanup: Exit Function
            End If
        Case WM_ACTIVATE, WM_HOTKEY
            Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
        Case WM_PARENTNOTIFY
            bCaptureChanged = True
            Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
        Case WM_MOVE, WM_ERASEBKGND
            Call SendMessage(hwnd, ByVal WM_SETREDRAW, 0&, 0&)
        Case WM_EXITSIZEMOVE
            Call SendMessage(hwnd, ByVal WM_SETREDRAW, 1&, 0&)
            oForm.Repaint
            Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
        Case WM_DESTROY
            bCaptureChanged = False
            Call Cleanup
            Exit Function
    End Select
Xit:
    
    WinProc = CallWindowProc(GetProp(hwnd, "lPrevProc"), hwnd, uMsg, wParam, lParam)
End Function

Private Sub TimerProc()
    Call KillTimer(hwnd, NULL_PTR)
    Call SetBrightness(lBrightness)
End Sub

Private Function Is_Error() As Boolean
    Dim sBuffer As String * 256, lRet As Long
    lRet = GetWindowText(GetActiveWindow, sBuffer, 256)
    If InStr(Left(sBuffer, lRet), "Visual Basic") Then Is_Error = True
End Function

Private Function IsControlExcluded(ByVal Ctrl As Control, vExcluded() As Variant) As Boolean
    Dim vCtrl As Variant
    If Not (Not vExcluded) Then
        For Each vCtrl In vExcluded
            If vCtrl Is Ctrl Then
                IsControlExcluded = True
                Exit Function
            End If
        Next vCtrl
    End If
End Function

Private Function IsControlKeyboardInteractive(Ctrl As Control) As Boolean
    On Error Resume Next
    If TypeOf Ctrl Is MSForms.ListBox Or TypeOf Ctrl Is MSForms.ComboBox _
        Or TypeOf Ctrl Is MSForms.TextBox Then
        IsControlKeyboardInteractive = True
    End If
End Function

Private Sub TabKeyWatcher()
    Static oPrev As Control
    If oForm.ActiveControl Is oPrev Then
    Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
    End If
    Set oPrev = oForm.ActiveControl
End Sub

Private Sub DisableUpDownKeys(Optional ByVal bDisbale As Boolean = True)
    If bDisbale Then
        Call RegisterHotKey(hwnd, 1&, 0&, vbKeyUp)
        Call RegisterHotKey(hwnd, 2&, 0&, vbKeyDown)
    Else
        Call UnregisterHotKey(hwnd, 1&)
        Call UnregisterHotKey(hwnd, 2&)
    End If
End Sub


2- Code Usage example (UserForm Module):
VBA Code: 
Private Sub UserForm_Initialize()

    Dim i As Long
    
    'Init form controls.
    For i = 0 To 255&
        ComboBox1.AddItem Format(i / 100&, "#0%")
    Next i
    ScrollBar1.Min = 0&
    ScrollBar1.Max = 255&
    ScrollBar1.Value = 255&
    ComboBox1.Value = ScrollBar1.Value
    Label1.Caption = Format(ScrollBar1.Value / 100&, "#0%")
    'Me.Zoom = 80&
    
    'Enable form dimming.
    Call EnableDim(Me, ScrollBar1, ComboBox1, Label1, Label2)

    'Set initial brightness.
    Call SetBrightness(255&)

End Sub

Private Sub UserForm_Terminate()
    Call DisableDim(Me)
End Sub


Private Sub ScrollBar1_Change()
    Label1.Caption = Format(ScrollBar1.Value / 100&, "#0%")
    ComboBox1.Value = ScrollBar1.Value
    Call SetBrightness(ScrollBar1.Value)
End Sub

Private Sub ScrollBar1_Scroll()
    Label1.Caption = Format(ScrollBar1.Value / 100&, "#0%")
    ComboBox1.Value = ScrollBar1.Value
    Call SetBrightness(ScrollBar1.Value)
End Sub

Private Sub ComboBox1_Change()
    Call SetBrightness(Replace(ComboBox1.Value, "%", ""))
    ScrollBar1.Value = Replace(ComboBox1.Value, "%", "")
End Sub

Private Sub CommandButton1_Click()
    MsgBox "Test"
End Sub
Private Sub CommandButton2_Click()
    Err.Raise 1&
End Sub


Code tested on Excel 2016 x64bit , Win 10 x64 bit under different screen resolutions. Not sure how it will behave under different settings... More testings required.
 
Upvote 0
Please, ignore the code in post#16 . Moderators are kindly requested to delete that post.

See if this works for you : The code still has a few limitations though, particularly the fact that it only works with Modal UserForms , the need to disable the arrow keys and the frozen-like feel when pressing buttons.

You should be able to set the desired form zoom prior to calling the EnableDim SUB.

The EnableDim SUB has a ExcludedControls ParamArray to flexibly pass the controls that you don't want to be dimmed.

I have also included a safety clause ( error trap ) in the form window procedure to prevent crashing should an unhandled runtime error occur. This precautious step is needed because the form is subclassed.

FormBrightness.xlsm






1- In a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Const NULL_PTR = 0^
    Const PTR_SIZE = 8&
#Else
    Const NULL_PTR = 0&
    Const PTR_SIZE = 4&
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom 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 SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF 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 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 LongPtr) 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 GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Private Declare PtrSafe Function ExtSelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr, ByVal fnMode As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function RegisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare PtrSafe Function UnregisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long) As Long
    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
#Else
    Private Enum LongPtr
        [_]
    End Enum
    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 IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare 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 LongPtr) As Long
    Private Declare 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 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 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 Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Private Declare Function ExtSelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr, ByVal fnMode As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If

Private hwnd As LongPtr, lPrevProc As LongPtr
Private hInitMemDC As LongPtr, hPrevInitBmp As LongPtr
Private hEllipRgn As LongPtr

Private oForm As UserForm
Private lBrightness As Long
Private lInitBrightness As Long
Private bInit As Boolean



Public Sub EnableDim( _
    ByVal Form As UserForm, _
    ParamArray ExcludedControls() _
)

    Const SM_CYCAPTION = 4&
    Const SM_CXBORDER = 5&
    Const SM_CXDLGFRAME = 7&
    Const RGN_OR = 2&
 
    Dim vExcludedControls() As Variant
    Dim Ctrl As MSForms.Control, oAcc As IAccessible
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim YOffset As Long, UpShift As Long
    Dim hRectRgn As LongPtr

    bInit = True
    Set oForm = Form
    Call IUnknown_GetWindow(Form, VarPtr(hwnd))
    If UBound(ExcludedControls) <> -1 Then
        vExcludedControls = ExcludedControls
    End If
    hEllipRgn = CreateRectRgn(0&, 0&, 0&, 0&)
    YOffset = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CXDLGFRAME)
    For Each Ctrl In Form.Controls
            If TypeOf Ctrl Is MSForms.TextBox Or _
                TypeOf Ctrl Is MSForms.ListBox Or IsControlExcluded(Ctrl, vExcludedControls) Then
            Set oAcc = Ctrl
            oAcc.accLocation lLeft, lTop, lWidth, lHeight, 0&
            If TypeOf Ctrl Is MSForms.ListBox Then
                UpShift = 10&
            Else
                UpShift = 0&
            End If
            hRectRgn = CreateRectRgn(lLeft - 2&, lTop - YOffset, lLeft + lWidth - 4&, _
                lTop + lHeight - YOffset - UpShift)
            Call CombineRgn(hEllipRgn, hRectRgn, hEllipRgn, RGN_OR)
            Call DeleteObject(hRectRgn)
        End If
    Next Ctrl
    Call DisableUpDownKeys
    Call HookForm(hwnd)
    Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TakeFormSnapshot)
    Call SetTimer(Application.hwnd, NULL_PTR, 0&, AddressOf TabKeyWatcher)

End Sub

Public Sub DisableDim(ByVal Form As MSForms.UserForm)
    Call Cleanup
    Call Form.Repaint
End Sub

Public Sub SetBrightness(Optional ByVal Brightness As Long)

    Const SRCCOPY = &HCC0020
    Const RGN_XOR As Long = 3&
    Const AC_SRC_OVER = &H0
    Dim hDC As LongPtr, hMemDC As LongPtr, hBmp As LongPtr, hPrevBmp As LongPtr
    Dim tBF As BLENDFUNCTION, lBF As LongPtr
    Dim tRect As RECT
    Dim lWidth As Long, lHeight As Long
 
 
    If oForm Is Nothing Then Exit Sub
 
    If Brightness < 0& Or Brightness > 255& Then
        Call Cleanup
        MsgBox "Brightness must be between 0 and 255.", , "Error."
        End
        Exit Sub
    End If
 
    lInitBrightness = Brightness
    If bInit Then bInit = False: oForm.Repaint:   Exit Sub
    lBrightness = Brightness
   
    With tBF
        .BlendOp = AC_SRC_OVER
        .BlendFlags = 0&
        .SourceConstantAlpha = Brightness  '<== (0 TO 255)
        .AlphaFormat = 0&
    End With
    Call CopyMemory(lBF, tBF, PTR_SIZE)
    hDC = GetDC(hwnd)
    Call GetClientRect(hwnd, tRect)
    With tRect
        lWidth = .Right - .Left
        lHeight = .Bottom - .Top
    End With
    hMemDC = CreateCompatibleDC(hDC)
    hBmp = CreateCompatibleBitmap(hDC, lWidth, lHeight)
    hPrevBmp = SelectObject(hMemDC, hBmp)
    Call ExtSelectClipRgn(hDC, hEllipRgn, RGN_XOR)
    Call AlphaBlend(hMemDC, 0&, 0&, lWidth, lHeight, hInitMemDC, 0&, 0&, lWidth, lHeight, lBF)
    Call BitBlt(hDC, 0&, 0&, lWidth, lHeight, hMemDC, 0&, 0&, SRCCOPY)
    Call SelectObject(hMemDC, hPrevBmp)
    Call DeleteObject(hPrevBmp)
    Call DeleteObject(hBmp)
    Call DeleteDC(hMemDC)
    Call ReleaseDC(hwnd, hDC)
 
End Sub



'_______________________________________ PRIVATE ROUTINES _____________________________________________

Private Sub Cleanup()

    Call KillTimer(Application.hwnd, NULL_PTR)
    Call HookForm(hwnd, False)
    Call DisableUpDownKeys(False)
    Call SelectObject(hInitMemDC, hPrevInitBmp)
    Call DeleteDC(hInitMemDC)
    Call DeleteObject(hPrevInitBmp)
    Call DeleteObject(hEllipRgn)
    Set oForm = Nothing
    lBrightness = 0&
    lInitBrightness = 0&
End Sub

Private Sub TakeFormSnapshot()
    Const SRCCOPY = &HCC0020
    Dim hDC As LongPtr, hInitMemBmp As LongPtr
    Dim tRect As RECT
    Dim lWidth As Long, lHeight As Long
 
    Call KillTimer(hwnd, NULL_PTR)
    Call GetClientRect(hwnd, tRect)
    lWidth = tRect.Right - tRect.Left
    lHeight = tRect.Bottom - tRect.Top
    hDC = GetDC(hwnd)
    hInitMemDC = CreateCompatibleDC(hDC)
    hInitMemBmp = CreateCompatibleBitmap(hDC, lWidth, lHeight)
    hPrevInitBmp = SelectObject(hInitMemDC, hInitMemBmp)
    Call BitBlt(hInitMemDC, 0&, 0&, lWidth, lHeight, hDC, 0&, 0&, SRCCOPY)
    Call ReleaseDC(hwnd, hDC)
    Call DeleteObject(hInitMemBmp)
    lBrightness = lInitBrightness
    DoEvents
    Call SetBrightness(lBrightness)
 
End Sub

Private Sub HookForm(ByVal hwnd As LongPtr, Optional ByVal bHook As Boolean = True)
    Const GWL_WNDPROC = (-4)
    If bHook Then
        If GetProp(hwnd, "lPrevProc") = 0 Then
            lPrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
            Call SetProp(hwnd, "lPrevProc", lPrevProc)
        End If
    Else
        If GetProp(hwnd, "lPrevProc") Then
            Call SetWindowLong(hwnd, GWL_WNDPROC, GetProp(hwnd, "lPrevProc"))
            Call RemoveProp(hwnd, "lPrevProc")
        End If
    End If
End Sub

Private Function WinProc( _
    ByVal hwnd As LongPtr, _
    ByVal uMsg As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr _
) As LongPtr

    Const WM_ACTIVATE = &H6
    Const WM_PARENTNOTIFY = &H210
    Const WM_CANCELMODE = &H1F
    Const WM_ENTERIDLE = &H121
    Const WM_SETREDRAW = &HB
    Const WM_ERASEBKGND = &H14
    Const WM_MOVE = &H3
    Const WM_EXITSIZEMOVE = &H232
    Const WM_DESTROY = &H2
    Const WM_HOTKEY = &H312


    Static bCaptureChanged As Boolean
    Dim hwndCtrl As LongPtr

    If lBrightness = 0& Then GoTo Xit
 
    If GetAsyncKeyState(VBA.vbKeyLButton) = 0& Then
        If bCaptureChanged Then
            bCaptureChanged = False
            Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
        End If
    End If
 
    Select Case uMsg
        Case WM_CANCELMODE, WM_ENTERIDLE
            If Is_Error Then
                Debug.Print "Error trapped!!"
                Call Cleanup: Exit Function
            End If
        Case WM_ACTIVATE, WM_HOTKEY
            Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
        Case WM_PARENTNOTIFY
            bCaptureChanged = True
            Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
        Case WM_MOVE, WM_ERASEBKGND
            Call SendMessage(hwnd, ByVal WM_SETREDRAW, 0&, 0&)
        Case WM_EXITSIZEMOVE
            Call SendMessage(hwnd, ByVal WM_SETREDRAW, 1&, 0&)
            oForm.Repaint
            Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
        Case WM_DESTROY
            bCaptureChanged = False
            Call Cleanup
            Exit Function
    End Select
Xit:
 
    WinProc = CallWindowProc(GetProp(hwnd, "lPrevProc"), hwnd, uMsg, wParam, lParam)
End Function

Private Sub TimerProc()
    Call KillTimer(hwnd, NULL_PTR)
    Call SetBrightness(lBrightness)
End Sub

Private Function Is_Error() As Boolean
    Dim sBuffer As String * 256, lRet As Long
    lRet = GetWindowText(GetActiveWindow, sBuffer, 256)
    If InStr(Left(sBuffer, lRet), "Visual Basic") Then Is_Error = True
End Function

Private Function IsControlExcluded(ByVal Ctrl As Control, vExcluded() As Variant) As Boolean
    Dim vCtrl As Variant
    If Not (Not vExcluded) Then
        For Each vCtrl In vExcluded
            If vCtrl Is Ctrl Then
                IsControlExcluded = True
                Exit Function
            End If
        Next vCtrl
    End If
End Function

Private Function IsControlKeyboardInteractive(Ctrl As Control) As Boolean
    On Error Resume Next
    If TypeOf Ctrl Is MSForms.ListBox Or TypeOf Ctrl Is MSForms.ComboBox _
        Or TypeOf Ctrl Is MSForms.TextBox Then
        IsControlKeyboardInteractive = True
    End If
End Function

Private Sub TabKeyWatcher()
    Static oPrev As Control
    If oForm.ActiveControl Is oPrev Then
    Call SetTimer(hwnd, NULL_PTR, 0&, AddressOf TimerProc)
    End If
    Set oPrev = oForm.ActiveControl
End Sub

Private Sub DisableUpDownKeys(Optional ByVal bDisbale As Boolean = True)
    If bDisbale Then
        Call RegisterHotKey(hwnd, 1&, 0&, vbKeyUp)
        Call RegisterHotKey(hwnd, 2&, 0&, vbKeyDown)
    Else
        Call UnregisterHotKey(hwnd, 1&)
        Call UnregisterHotKey(hwnd, 2&)
    End If
End Sub


2- Code Usage example: ( UserForm Module)
VBA Code: 
Option Explicit

Private Sub UserForm_Initialize()

    Dim i As Long
 
    'Init form controls.
    For i = 0 To 255&
        ComboBox1.AddItem i
    Next i
    ScrollBar1.Min = 0&
    ScrollBar1.Max = 255&
    ScrollBar1.Value = 255&
    Label1.Caption = Format((ScrollBar1.Value) / 255&, "#0%")
    'Me.Zoom = 80&
 
    'Enable form dimming.
    Call EnableDim(Me, ScrollBar1, ComboBox1, Label1, Label2)

    'Set initial brightness.
    Call SetBrightness(255&)

End Sub

Private Sub UserForm_Terminate()
    Call DisableDim(Me)
End Sub


Private Sub ScrollBar1_Change()
    Label1.Caption = Format((ScrollBar1.Value) / 255&, "#0%")
    ComboBox1.Value = ScrollBar1.Value
    Call SetBrightness(ScrollBar1.Value)
End Sub

Private Sub ScrollBar1_Scroll()
    Label1.Caption = Format((ScrollBar1.Value) / 255&, "#0%")
    ComboBox1.Value = ScrollBar1.Value
    Call SetBrightness(ScrollBar1.Value)
End Sub

Private Sub ComboBox1_Change()
    Call SetBrightness(ComboBox1.Value)
    ScrollBar1.Value = ComboBox1.Value
End Sub

Private Sub CommandButton1_Click()
    MsgBox "Test"
End Sub
Private Sub CommandButton2_Click()
    Err.Raise 1&
End Sub


I tested the code in excel 2016 x64bit , Win 10 x64 under different screen resolutions and it worked ok.
Not sure how it will behave under different settings ... More testing will probably be required.
 
Last edited:
Upvote 0
Wow... Yep that now dims the entire thing.
I really cannot follow your voodoo code, but it worx like a charm.

I tested it just on one of the forms so far.

If I understand right:
- Only 1 form at the time can have dimming enabled, so I need to disable dimming on one form, before enabling on another?
Is that correct? (Not a problem, I only need to know in order to write the calls...)

Thanks a real big heap. This will make my Interface much clearer.
 
Upvote 0
hmm... celebrated too early.

So what happens is:
If I "enableDim me" in the initialize routine, it prevents from scrolling a listbox with arrow keys, which I need (when a row is selected, it gets immediately unselected)
It also prevents this Mouse Scroll to work.

My aim is to dim the main form when some other (smaller) forms are shown on top.
So I do not really need Dim enabled while the form is active.

So I tried to open the second form with:

VBA Code: 
    EnableDim Me
    SetBrightness (80&)
    frmManage.Show
    DisableDim Me

But now again it dims only the upper half of the main form :/
 
Upvote 0
You must log in or register to reply here.

Similar threads

Artik
  • Question Question
VBA code to click Image in WebBrowser control.
Replies
4
Views
172
Artik
Artik
S
  • Solved
VBA Populate userform dynamically with custom class Frame
Replies
1
Views
347
saboh12617
S
N
  • Solved
Frame scrollbar resets when clicking on/in frame
Replies
5
Views
314
Micron
M
U
  • Question Question
Inserting images into Excel workbook - loss of image quality problem
Replies
1
Views
227
ranman256
ranman256
C
  • Question Question
Embedding and displaying a Powepoint slide presentation in an Excel Userform. Possible?
Replies
0
Views
294
chazrab
C

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

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