MouseWheel to Scroll long Cell Validation DopDown Lists ?

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,806
Office Version
  1. 2016
Platform
  1. Windows
Is there a way ,which i am missing, of scrolling a long validation dropdown list with the mouse wheel ?

I am thinking of setting a mouse hook for this (which i guess will be rather involved) but wonder if there is a simpler workround .

Regards.
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Sort by date Sort by votes
example workbook.

Rather involved code but functional - Although the code uses 2 system hooks, I haven't noticed any serious issues when tested on ( EXCEL 2003, Win XP)

Place this in a Standard module :

Code: 
Option Explicit
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" _
() As Long
 
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
 
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long

Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
 
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 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 WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
 
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
 
Private Type POINTAPI
  X As Long
  Y As Long
End Type
 
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
 
Private Const WH_CBT                      As Long = 5
Private Const HCBT_CREATEWND        As Long = 3
Private Const HCBT_DESTROYWND      As Long = 4
Private Const WH_MOUSE_LL             As Long = 14
Private Const WM_MOUSEWHEEL        As Long = &H20A
Private Const HC_ACTION                 As Long = 0
Private Const GWL_HINSTANCE          As Long = (-6)
 
Private lCBTHook                             As Long
Private lMouseHook                          As Long
Private lAppHwnd                            As Long
Private lDeskHwnd                           As Long
Private lWkbHwnd                           As Long
Private oValCell                              As Range
Private lDropDownHwnd                   As Long
 
Sub HookValidationList()
 
    On Error Resume Next
    
    If HasValidateList(ActiveCell) Then
    
        Set oValCell = ActiveCell
        lAppHwnd = _
        FindWindow("XLMAIN", Application.Caption)
        lDeskHwnd = FindWindowEx _
        (lAppHwnd, 0, "XLDESK", vbNullString)
        lWkbHwnd = FindWindowEx _
        (lDeskHwnd, 0, "EXCEL7", vbNullString)
        lCBTHook = SetWindowsHookEx _
        (WH_CBT, AddressOf CBTProc, _
        GetAppInstance, GetCurrentThreadId)
        
    Else
    
        UnhookWindowsHookEx lMouseHook
        UnhookWindowsHookEx lCBTHook
        
    End If
 
End Sub

Private Function CBTProc _
(ByVal idHook As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
    Dim strBuffer As String
    Dim lRetVal As Long
 
    On Error Resume Next
    
    Select Case idHook
    
        Case Is = HCBT_CREATEWND
        
            strBuffer = Space(256)
            lRetVal = GetClassName(wParam, strBuffer, 256)
            If Left(strBuffer, lRetVal) = "EXCEL:" Then
                lDropDownHwnd = wParam
                lMouseHook = SetWindowsHookEx _
                (WH_MOUSE_LL, _
                AddressOf LowLevelMouseProc, GetAppInstance, 0)
            End If
            
        Case Is = HCBT_DESTROYWND
        
            If wParam = lDropDownHwnd Then
                UnhookWindowsHookEx lMouseHook
                UnhookWindowsHookEx lCBTHook
                If ActiveCell.Address = oValCell.Address Then
                    Call HookValidationList
                End If
            End If
            
    End Select
    
    CBTProc = CallNextHookEx _
    (lCBTHook, idHook, ByVal wParam, ByVal lParam)
 
End Function

Private Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MSLLHOOKSTRUCT) As Long
 
    On Error Resume Next
    
    If (nCode = HC_ACTION) Then
    
        If wParam = WM_MOUSEWHEEL Then
        
            LowLevelMouseProc = True
            
            If lParam.mouseData > 0 Then
                SendKeys "{UP}"
            Else
                SendKeys "{DOWN}"
            End If
            
            Exit Function
            
        End If
        
        With lParam.pt
        
            If WindowFromPoint(.X, .Y) <> lDropDownHwnd _
            And WindowFromPoint(.X, .Y) <> lWkbHwnd Then
                ShowWindow lDropDownHwnd, 0
            End If
            
        End With
        
    End If
    
    LowLevelMouseProc = _
    CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
 
End Function
 
Private Function GetAppInstance() As Long
 
    GetAppInstance = GetWindowLong(lAppHwnd, GWL_HINSTANCE)
 
End Function

Private Function HasValidateList(Cell As Range) As Boolean
 
    On Error Resume Next
    HasValidateList = Cell.Validation.InCellDropdown
 
End Function


...and this simple line goes inside the module of the worksheet where the Cell with the data validation dropdown is located:

Code: 
Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    Call HookValidationList
 
End Sub

I removed script comments to avoid cluttering of the code.

Hope someone finds this useful.

Regards.
 
Upvote 0
Jaafar,
Can this be tweaked to work with a Listbox, or would it have to be completely redone?

Thanks,
Mike
 
Upvote 0
Nice one Jaafar.

I noticed that while scrolling, it was also selecting the values and so if the mouse pointer moved even slightly a different value would be selected and the scrolling would begin from there.

Also... when I closed the workbook I get the message

"Microsoft Office Excel has encountered a problem and needs to close. We are sorry for the inconvenience"
<input id="gwProxy" type="hidden"><!--Session data--><input *******="jsCall();" id="jsProxy" type="hidden"><input id="gwProxy" type="hidden"><!--Session data--><input *******="jsCall();" id="jsProxy" type="hidden">
 
Upvote 0
There's a nice free utility called Kat Mouse which sends the scroll to the window below the mouse even if that window is not active.

This works with controls as well. I think you have to have the mouse over the scroll bar.

Ryan
 
Upvote 0
Hello Jafaar, thank you very much for posting this I have searched exhaustively for a way to scroll data validation lists with the mouse wheel and this is the only thing I could find! It appears to work very well, however when I go to close the workbook it says "Microsoft excel has stopped working", then it shuts down an opens up a blank workbook with the autorecovery pane. Is there a way to prevent this from happening every time? Its more of a nuisance as the workbook still allows me to save my data, its only after saving then closing (or just closing without saving) that this happens. Also, I am a novice at Excel VBA (obviously), but is there a way for the drop down scrolling to be automatically available, i.e. without having to click "run" for the macro. Thank you so much!
 
Upvote 0
The following changes to the code should eliminate the problem of crashing when closing the workbook.... I have also catered for the eventuality that the VBE is accidently reset for additionnal safety:

Workbook DEMO

1: Code in a Standard Module :

Code: 
Option Explicit
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" _
() As Long
 
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
 
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long

Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
 
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 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 WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
 
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long

Private Declare Function SetProp Lib "user32" Alias "SetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long

Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long

Private Declare Function GetProp Lib "user32" Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long

 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
 
Private Const WH_CBT                      As Long = 5
Private Const HCBT_CREATEWND              As Long = 3
Private Const HCBT_DESTROYWND             As Long = 4
Private Const WH_MOUSE_LL                 As Long = 14
Private Const WM_MOUSEWHEEL               As Long = &H20A
Private Const HC_ACTION                   As Long = 0
Private Const GWL_HINSTANCE               As Long = (-6)
 
Private lCBTHook                          As Long
Private lMouseHook                        As Long
Private lAppHwnd                          As Long
Private lDeskHwnd                         As Long
Private lWkbHwnd                          As Long
Private oValCell                          As Range
Private lDropDownHwnd                     As Long



Public Sub HookValidationList()
 
    On Error Resume Next
    
    Call RemoveHook

    If HasValidateList(ActiveCell) Then
    
        Set oValCell = ActiveCell
        lAppHwnd = _
        FindWindow("XLMAIN", Application.Caption)
        lDeskHwnd = FindWindowEx _
        (lAppHwnd, 0, "XLDESK", vbNullString)
        lWkbHwnd = FindWindowEx _
        (lDeskHwnd, 0, "EXCEL7", vbNullString)
        lCBTHook = SetWindowsHookEx _
        (WH_CBT, AddressOf CBTProc, _
        GetAppInstance, GetCurrentThreadId)
        SetProp Application.hwnd, "MouseHook", lMouseHook
        SetProp Application.hwnd, "CBTHook", lCBTHook
    Else
    
        Call RemoveHook
        
    End If
 
End Sub

Public Sub RemoveHook()

        UnhookWindowsHookEx GetProp(Application.hwnd, "MouseHook")
        UnhookWindowsHookEx GetProp(Application.hwnd, "CBTHook")
        RemoveProp Application.hwnd, "MouseHook"
        RemoveProp Application.hwnd, "CBTHook"
        
End Sub


Private Function CBTProc _
(ByVal idHook As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
    Dim strBuffer As String
    Dim lRetVal As Long
 
    On Error Resume Next
    
    Select Case idHook
    
        Case Is = HCBT_CREATEWND
        
            strBuffer = Space(256)
            lRetVal = GetClassName(wParam, strBuffer, 256)
            If Left(strBuffer, lRetVal) = "EXCEL:" Then
                lDropDownHwnd = wParam
                lMouseHook = SetWindowsHookEx _
                (WH_MOUSE_LL, _
                AddressOf LowLevelMouseProc, GetAppInstance, 0)
            End If
            
        Case Is = HCBT_DESTROYWND
        
            If wParam = lDropDownHwnd Then
                UnhookWindowsHookEx lMouseHook
                UnhookWindowsHookEx lCBTHook
                If ActiveCell.Address = oValCell.Address Then
                    Call HookValidationList
                End If
            End If
            
    End Select
    
    CBTProc = CallNextHookEx _
    (lCBTHook, idHook, ByVal wParam, ByVal lParam)
 
End Function

Private Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MSLLHOOKSTRUCT) As Long
 
    On Error Resume Next
    
    If (nCode = HC_ACTION) Then
    
        If wParam = WM_MOUSEWHEEL Then
        
            LowLevelMouseProc = True
            
            If lParam.mouseData > 0 Then
                SendKeys "{UP}"
            Else
                SendKeys "{DOWN}"
            End If
            
            Exit Function
            
        End If
        
        With lParam.pt
        
            If WindowFromPoint(.x, .y) <> lDropDownHwnd _
            And WindowFromPoint(.x, .y) <> lWkbHwnd Then
                ShowWindow lDropDownHwnd, 0
            End If
            
        End With
        
    End If
    
    LowLevelMouseProc = _
    CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
 
End Function
 
Private Function GetAppInstance() As Long
 
    GetAppInstance = GetWindowLong(lAppHwnd, GWL_HINSTANCE)
 
End Function

Private Function HasValidateList(Cell As Range) As Boolean
 
    On Error Resume Next
    HasValidateList = Cell.Validation.InCellDropdown
 
End Function


2: Code in the Module of the worksheet where the Cell with the DV list is located :

Code: 
Option Explicit

Private Sub Worksheet_Activate()

    Call HookValidationList

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    Call HookValidationList
 
End Sub

3: Code in the ThisWorkbook Module :

Code: 
Option Explicit

Private Sub Workbook_Open()

    Call HookValidationList
    
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    Call RemoveHook

End Sub

Tested on Excel 2007 Win XP
 
Upvote 0
Hi Jaafar, sorry for my delayed response, I was out backpacking for 5 days and had no internet connection. I tried your code changes and everything was working flawlessly, however, when I tried to open another excel workbook at the same time as the workbook containing the macro I received the error message "Excel has stopped Working". Then Excel stops responding (the screen turns opaque and cursor turns to the blue busy wheel) and I have to close it via the task manager. The original problem of crashing when the workbook was closed has been fixed, but now this problem is occurring. Any idea why this might be happening? Thank you very much for lending your time to help, it is sincerely appreciated.
 
Upvote 0

Workbook example

Hi DrewPA,

Yes you are right - When a new workbook is opened while the workbook containg the DV macro is open there is a bug that crashes the application - I wasn't aware of that issue.

Try this new code which should prevent the problem ... As an additional goody this new code also offers the possibility of applying the mouse-scroll functionality to all DV lists throughout the workbook if there happens to be more than one DV list :

1: Code in the Thisworkbook module :
Code: 
Option Explicit

Private Sub Workbook_Open()
    Call HookValidationList(ActiveCell)
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call RemoveHook
End Sub

Private Sub Workbook_Activate()
    Call HookValidationList(ActiveCell)
End Sub

Private Sub Workbook_Deactivate()
    Call RemoveHook
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Call HookValidationList(ActiveCell)
End Sub

Private Sub Workbook_SheetSelectionChange _
(ByVal Sh As Object, ByVal Target As Range)
    Call HookValidationList(Target)
End Sub


2: Code in a Standard Module :

Code: 
Option Explicit
 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
  
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
 
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) 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 WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
 
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long

Private Declare Function SetProp Lib "user32" Alias "SetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long

Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long

Private Declare Function GetProp Lib "user32" Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
 
Private Const WH_MOUSE_LL                 As Long = 14
Private Const WM_MOUSEWHEEL               As Long = &H20A
Private Const HC_ACTION                   As Long = 0
Private Const GWL_HINSTANCE               As Long = (-6)
 
Private lMouseHook                        As Long
Private lAppHwnd                          As Long
Private lDeskHwnd                         As Long
Private lWkbHwnd                          As Long
Private lDropDownHwnd                     As Long


Public Sub HookValidationList(Cell As Range)
    
    Call RemoveHook
    KillTimer Application.hwnd, 0
    
    If HasValidateList(Cell) Then
        lAppHwnd = _
        FindWindow("XLMAIN", Application.Caption)
        lDeskHwnd = FindWindowEx _
        (lAppHwnd, 0, "XLDESK", vbNullString)
        lWkbHwnd = FindWindowEx _
        (lDeskHwnd, 0, "EXCEL7", vbNullString)
        SetTimer Application.hwnd, 0, 100, AddressOf TimerProc
    Else
        KillTimer Application.hwnd, 0
        Call RemoveHook
    End If
 
End Sub

Public Sub RemoveHook()

    KillTimer Application.hwnd, 0
    UnhookWindowsHookEx GetProp(Application.hwnd, "MouseHook")
    RemoveProp Application.hwnd, "MouseHook"

End Sub


Private Sub TimerProc()

    lDropDownHwnd = FindWindow("EXCEL:", vbNullString)
    If lDropDownHwnd <> 0 Then
        Call RemoveHook
        lMouseHook = SetWindowsHookEx _
        (WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetAppInstance, 0)
        SetProp Application.hwnd, "MouseHook", lMouseHook
    End If

End Sub


Private Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MSLLHOOKSTRUCT) As Long
 
    If (nCode = HC_ACTION) Then
      
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            If lParam.mouseData > 0 Then
                SendKeys "{UP}"
            Else
                SendKeys "{DOWN}"
            End If
            Exit Function
        End If
        With lParam.pt
            If WindowFromPoint(.x, .y) <> lDropDownHwnd _
            And WindowFromPoint(.x, .y) <> lWkbHwnd Then
                ShowWindow lDropDownHwnd, 0
            End If
        End With
    End If
    
    LowLevelMouseProc = _
    CallNextHookEx(GetProp(Application.hwnd, "MouseHook"), nCode, wParam, ByVal lParam)
 
End Function
 
Private Function GetAppInstance() As Long
 
    GetAppInstance = GetWindowLong(lAppHwnd, GWL_HINSTANCE)
 
End Function

Private Function HasValidateList(Cell As Range) As Boolean
 
    On Error Resume Next
    HasValidateList = Cell.Validation.InCellDropdown
 
End Function

Hope this helps.
 
Upvote 0
Hi DrewPA,

Workbook example

Please ignore the previous post - I just tested that code on a different PC at work today and it failed to work consistently .... I think I have figured out the offending bug .... Pls, report back if any problems

Try this new update of the previous code - hopefully, this time, it will not cause the application to crash when another workbook is opened:

1: Code in the Thisworkbook module :
Code: 
Option Explicit

Private Sub Workbook_Open()
    Call HookValidationList(ActiveCell)
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call RemoveHook
End Sub

Private Sub Workbook_Activate()
    Call HookValidationList(ActiveCell)
End Sub
'
Private Sub Workbook_Deactivate()
    Call RemoveHook
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Call HookValidationList(ActiveCell)
End Sub

Private Sub Workbook_SheetSelectionChange _
(ByVal Sh As Object, ByVal Target As Range)
    Call HookValidationList(Target)
End Sub


2: The following code goes in a normal module :
Code: 
Option Explicit
 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
  
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
 
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) 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 WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
 
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long

Private Declare Function SetProp Lib "user32" Alias "SetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long

Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long

Private Declare Function GetProp Lib "user32" Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
 
Private Const WH_MOUSE_LL                 As Long = 14
Private Const WM_MOUSEWHEEL               As Long = &H20A
Private Const HC_ACTION                   As Long = 0
Private Const GWL_HINSTANCE               As Long = (-6)
 
Private lMouseHook                        As Long
Private lAppHwnd                          As Long
Private lDeskHwnd                         As Long
Private lWkbHwnd                          As Long
Private lDropDownHwnd                     As Long

Public Sub HookValidationList(Cell As Range)
    
    Call RemoveHook
    If HasValidateList(Cell) Then
        lAppHwnd = _
        FindWindow("XLMAIN", Application.Caption)
        lDeskHwnd = FindWindowEx _
        (lAppHwnd, 0, "XLDESK", vbNullString)
        lWkbHwnd = FindWindowEx _
        (lDeskHwnd, 0, "EXCEL7", vbNullString)
        SetTimer Application.hwnd, 0, 100, AddressOf TimerProc
    Else
        Call RemoveHook
    End If
 
End Sub

Public Sub RemoveHook()

    KillTimer Application.hwnd, 0
    UnhookWindowsHookEx GetProp(Application.hwnd, "MouseHook")
    RemoveProp Application.hwnd, "MouseHook"

End Sub


Private Sub TimerProc()

    lDropDownHwnd = FindWindow("EXCEL:", vbNullString)
    If lDropDownHwnd <> 0 Then
        Call RemoveHook
        lMouseHook = SetWindowsHookEx _
        (WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetAppInstance, 0)
        SetProp Application.hwnd, "MouseHook", lMouseHook
    End If

End Sub


Private Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MSLLHOOKSTRUCT) As Long
 
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            If lParam.mouseData > 0 Then
                SendKeys "{UP}"
            Else
                SendKeys "{DOWN}"
            End If
            Exit Function
        End If
        With lParam.pt
            If WindowFromPoint(.x, .y) <> lDropDownHwnd _
            And WindowFromPoint(.x, .y) <> lWkbHwnd Then
                Call RemoveHook
                ShowWindow lDropDownHwnd, 0
            End If
        End With
    End If
    
    LowLevelMouseProc = _
    CallNextHookEx(GetProp(Application.hwnd, "MouseHook"), nCode, wParam, ByVal lParam)
 
End Function
 
Private Function GetAppInstance() As Long
 
    GetAppInstance = GetWindowLong(lAppHwnd, GWL_HINSTANCE)
 
End Function

Private Function HasValidateList(Cell As Range) As Boolean
 
    On Error Resume Next
    HasValidateList = Cell.Validation.InCellDropdown
 
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
VBA to protect/unprotect sheet...
Replies
6
Views
307
jkpieterse
jkpieterse
D
  • Question Question
Modify a worksheet without registering it as a change
Replies
1
Views
118
Kaper
Kaper
T
  • Question Question
Data validation with conditional list
Replies
5
Views
508
RoryA
RoryA
J
  • Solved
Data Validation List - Not Including Blanks
2
Replies
12
Views
774
kevin9999
K
M
  • Question Question
VBA to return a list of ranges used by data validation
Replies
2
Views
272
Micron
M

Forum statistics

Threads
1,224,768
Messages
6,180,850
Members
453,002
Latest member
anifnisar

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