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.
 
Sort by date Sort by votes
Here is an update of the code that :

A- Works in 32 as well as 64 bit systems
B- Doesn't disable the Num Lock key

Workbook demo


1- 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


#If VBA7 Then
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long


    Dim hMouseHook As LongPtr, hDropDown As LongPtr
#Else
    Declare Function FindWindow Lib "user32" Alias "FindWindowA"(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    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
    Declare Function CallNextHookEx Lib "user32"(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32"(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    
    Dim hMouseHook As Long, hDropDown As Long
#End If


Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0
Const WM_KEYDOWN = &H100




Public Sub HookValidationList(Cell As Range)
    Call RemoveHook
    If HasValidateList(Cell) Then
        SetTimer Application.hwnd, 0, 100, AddressOf TimerProc
    Else
        Call RemoveHook
    End If
End Sub


Public Sub RemoveHook()
    If GetProp(Application.hwnd, "MouseHook") Then
        KillTimer Application.hwnd, 0
        UnhookWindowsHookEx GetProp(Application.hwnd, "MouseHook")
        RemoveProp Application.hwnd, "MouseHook"
    End If
End Sub


Sub TimerProc()
    hDropDown = FindWindow("EXCEL:", vbNullString)
    If hDropDown <> 0 Then
        Call RemoveHook
        #If VBA7 Then
            hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.HinstancePtr, 0)
        #Else
            hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
        #End If
        SetProp Application.hwnd, "MouseHook", hMouseHook
    End If
End Sub




#If VBA7 Then
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
#Else
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
#End If
 
    On Error GoTo ErrHandler
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            If lParam.mouseData > 0 Then
                Call PostMessage(hDropDown, WM_KEYDOWN, vbKeyUp, 0)
            Else
                Call PostMessage(hDropDown, WM_KEYDOWN, vbKeyDown, 0)
            End If
            Exit Function
        End If
    End If
    If IsWindow(hDropDown) Then Call HookValidationList(ActiveCell)
ErrHandler:
    If Err.Number <> 0 Then Err.Clear: RemoveHook
    LowLevelMouseProc = CallNextHookEx(GetProp(Application.hwnd, "MouseHook"), nCode, wParam, ByVal lParam)
End Function


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


2- 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
 
Last edited:
Upvote 0

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Sorry. Too late to edit the post ... I just discovered a small bug in the above code which may compromise the stability of the code

In the RemoveHook routine, the If clause should be commented out
Code: 
Public Sub RemoveHook()
[B][COLOR=#008000]   'If GetProp(Application.hwnd, "MouseHook") Then[/COLOR][/B]
        KillTimer Application.hwnd, 0
        UnhookWindowsHookEx GetProp(Application.hwnd, "MouseHook")
        RemoveProp Application.hwnd, "MouseHook"
[B][COLOR=#008000]    'End If[/COLOR][/B]
End Sub
 
Last edited:
Upvote 0
I am unable to understand all these concepts. From where should I study the material to understand whatever you have explained.



Jaafar Tribak said:
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
Click to expand...
 
Upvote 0
gentle2005 said:
I am unable to understand all these concepts. From where should I study the material to understand whatever you have explained.
Click to expand...

Hello,

Old poster but no longer have my login info, so I had to create a new account.

This is a great code, however, it is working on workbooks I open after the main workbook where the code is housed is in use. How can I make it work only on the one workbook. I have other workbooks that I need to open while this one is in use and run code from them.

Thanks!
 
Upvote 0
djpeter08 said:
Hello,

Old poster but no longer have my login info, so I had to create a new account.

This is a great code, however, it is working on workbooks I open after the main workbook where the code is housed is in use. How can I make it work only on the one workbook. I have other workbooks that I need to open while this one is in use and run code from them.

Thanks!
Click to expand...

The code should work for only the workbook where the code is housed.. Are you sure you added the second part of the code ( The part that goes in the ThisWorkbook Module)
 
Upvote 0
Jaafar Tribak said:
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.
Click to expand...

Greetings from the future!
It's 2017 and I'm posting in case anyone lands on this page.

Place the mouse pointer over the scroll bar and turn the wheel.
 
Upvote 0
Jaafar Tribak said:
Sorry. Too late to edit the post ... I just discovered a small bug in the above code which may compromise the stability of the code

In the RemoveHook routine, the If clause should be commented out
Code: 
Public Sub RemoveHook()
[B][COLOR=#008000]   'If GetProp(Application.hwnd, "MouseHook") Then[/COLOR][/B]
        KillTimer Application.hwnd, 0
        UnhookWindowsHookEx GetProp(Application.hwnd, "MouseHook")
        RemoveProp Application.hwnd, "MouseHook"
[B][COLOR=#008000]    'End If[/COLOR][/B]
End Sub
Click to expand...

Hi

this doesnt seem to work in Excel 2013 64bit. Anything that you think I might be doing wrong?

Thanks.
 
Upvote 0
katsumiblisk said:
Greetings from the future!
It's 2017 and I'm posting in case anyone lands on this page.

Place the mouse pointer over the scroll bar and turn the wheel.
Click to expand...

Thanks for the info from the future. A small note to anyone reading this, you can use the scroll wheel in only 1 direction. If the pointer is located below the scrolling bar, whether you scroll up or down on the mouse wheel, it will go only down.
 
Upvote 0
Jaafar Tribak said:
Here is an update of the code that :

A- Works in 32 as well as 64 bit systems
B- Doesn't disable the Num Lock key

Workbook demo


1- 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


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long


    Dim hMouseHook As LongPtr, hDropDown As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Declare Function FindWindow Lib "user32" Alias "FindWindowA"(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    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
    Declare Function CallNextHookEx Lib "user32"(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32"(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    
    Dim hMouseHook As Long, hDropDown As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0
Const WM_KEYDOWN = &H100




Public Sub HookValidationList(Cell As Range)
    Call RemoveHook
    If HasValidateList(Cell) Then
        SetTimer Application.hwnd, 0, 100, AddressOf TimerProc
    Else
        Call RemoveHook
    End If
End Sub


Public Sub RemoveHook()
    If GetProp(Application.hwnd, "MouseHook") Then
        KillTimer Application.hwnd, 0
        UnhookWindowsHookEx GetProp(Application.hwnd, "MouseHook")
        RemoveProp Application.hwnd, "MouseHook"
    End If
End Sub


Sub TimerProc()
    hDropDown = FindWindow("EXCEL:", vbNullString)
    If hDropDown <> 0 Then
        Call RemoveHook
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
            hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.HinstancePtr, 0)
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
        SetProp Application.hwnd, "MouseHook", hMouseHook
    End If
End Sub




[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
    On Error GoTo ErrHandler
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            If lParam.mouseData > 0 Then
                Call PostMessage(hDropDown, WM_KEYDOWN, vbKeyUp, 0)
            Else
                Call PostMessage(hDropDown, WM_KEYDOWN, vbKeyDown, 0)
            End If
            Exit Function
        End If
    End If
    If IsWindow(hDropDown) Then Call HookValidationList(ActiveCell)
ErrHandler:
    If Err.Number <> 0 Then Err.Clear: RemoveHook
    LowLevelMouseProc = CallNextHookEx(GetProp(Application.hwnd, "MouseHook"), nCode, wParam, ByVal lParam)
End Function


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


2- 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
Click to expand...

Good Day sir, Just trying to add this function to my excel sheet but the workbook module is conflicting with the existing code i have... any way to make them work?

I am using the following code to lock modified cells after the spreadsheet is saved

Private Sub Workbook_BeforeClose(Cancel As Boolean)
LockUsed
Me.Save
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
LockUsed
End Sub
Sub LockUsed()
Dim trg As Range
Dim rng As Range
With Worksheets("Book")
.Unprotect Password:="Apple123"
Set trg = Worksheets("Book").Range("A1:N5000")
On Error Resume Next
Set rng = trg.SpecialCells(xlCellTypeConstants)
If Not rng Is Nothing Then
rng.Locked = True
End If
Set rng = Nothing
Set rng = trg.SpecialCells(xlCellTypeFormulas)
If Not rng Is Nothing Then
rng.Locked = True
End If
.Protect Password:="Apple123"
End With
End Sub


I want to add your scroll wheel ability but the line



Private Sub Workbook_BeforeClose(Cancel As Boolean)

is thrwoing an error...

how would I combine them to work?

Thanks.
 
Upvote 0
forget it I think i figured it out... its working now... so far no errors but lets see how it works out in the wild....

Code: 
Option ExplicitPrivate Sub Workbook_BeforeClose(Cancel As Boolean)
    LockUsed
    Me.Save
    Call RemoveHook
End Sub


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


Private Sub Workbook_Open()
    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_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    LockUsed
End Sub


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


Sub LockUsed()
    Dim trg As Range
    Dim rng As Range
    With Worksheets("Book")
        .Unprotect Password:="Apple123"
        Set trg = Worksheets("Book").Range("A1:N5000")
        On Error Resume Next
        Set rng = trg.SpecialCells(xlCellTypeConstants)
        If Not rng Is Nothing Then
            rng.Locked = True
        End If
        Set rng = Nothing
        Set rng = trg.SpecialCells(xlCellTypeFormulas)
        If Not rng Is Nothing Then
            rng.Locked = True
        End If
        .Protect Password:="Apple123"
    End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
VBA to protect/unprotect sheet...
Replies
6
Views
311
jkpieterse
jkpieterse
D
  • Question Question
Modify a worksheet without registering it as a change
Replies
1
Views
128
Kaper
Kaper
T
  • Question Question
Data validation with conditional list
Replies
5
Views
509
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,823
Messages
6,181,178
Members
453,021
Latest member
Justyna P

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