In the office we use an Excel file with macros and one of them enables the mouse wheel in the combobox. We had several 32-bit versions of Excel from 2003 to 2016 and Excel 2010 64-bit. Everything worked perfectly until we have updated the computer with Office 2016 64-bit: the mouse wheel scroll works for a few seconds then inevitably the application crashes and restarts.
If I disable the use of the wheel application works perfectly but we would like to use it.
the sheet module:
Code
Private Sub Worksheet_BeforeDoubleClick(ByVal target As range, Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim parola As String
Set ws = ActiveSheet
parola = "INDIRETTO"
Set cboTemp = ws.OLEObjects("TempCombo2")
cboTemp.Activate
cboTemp.Visible = True
On Error Resume Next
With cboTemp
'clear and hide the combo box
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
On Error GoTo errHandler
If target.Validation.Type = 3 Then
'if the cell contains
'a data validation list
Cancel = True
Application.EnableEvents = True
'get the data validation formula
str = target.Validation.Formula1
str = Right(str, Len(str) - 1)
If InStr(str, parola) = 0 Then GoTo noindi
str = Replace(str, "INDIRETTO(", "") 'Remove INDIRECT and opening parenthesis
str = Left(str, Len(str) - 1) 'Remove last closing parenthesis
str = Evaluate(str) 'Evaluate the formula to return named range
End If
'If str <> "" And Target.Address = "$C$9" Then ActiveSheet.Buttons(button12).Visible = True
' If str <> "" And Target.Address = "$C$10" Then ActiveSheet.Buttons(button13).Visible = True
If str = "ABB_SPA_-_POWER_PRODUCTS_DIV." Then
Sheets("airmet").Visible = True
Sheets("esamet").Visible = True
Sheets("airmet").Activate
End
End If
noindi:
With cboTemp
'show the combobox with the list
.Visible = True
.Left = target.Left
.Top = target.Top
.Width = target.Width
.Height = target.Height
.ListFillRange = str
.LinkedCell = target.Address
End With
cboTemp.Activate
'open the drop down list automatically
Me.TempCombo2.DropDown
MakeScrollableWithMouseWheel(TempCombo2) = True
errHandler:
Application.EnableEvents = True
Exit Sub
End Sub
'=========================================
Private Sub TempCombo2_LostFocus()
MakeScrollableWithMouseWheel(TempCombo2) = False
With Me.TempCombo2
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
Call VerificaCelle
End Sub
Private Sub TempCombo2_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
Case Else
'do nothing
End Select
End Sub
Display More
the code 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
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
#Else
Private Declare Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(ByVal Destination As LongPtr, _
ByVal Source As LongPtr, _
ByVal Length As LongPtr)
Private Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private 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
Private Declare PtrSafe Function CallNextHookEx Lib "USER32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "USER32" (ByVal hhk As LongPtr) As Long
#Else
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(ByVal Destination As Long, _
ByVal Source As Long, _
ByVal Length As Long)
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) 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
#End If
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private Const GWL_HINSTANCE = (-6)
#If VBA7 Then
Private hHook As LongPtr
#Else
Private hHook As Long
#End If
Private uParamStruct As MSLLHOOKSTRUCT
Private oObject As Object
#If VBA7 Then
Private lLowLevelMouse As LongPtr
#Else
Private lLowLevelMouse As Long
#End If
Private bHooked As Boolean
'====================='
'\\ Public Routines '
'====================='
Public Property Let MakeScrollableWithMouseWheel _
(ByVal Obj As Object, ByVal vNewValue As Boolean)
If vNewValue Then
Hook_Mouse
Else
UnHook_Mouse
End If
Set oObject = Obj
bHooked = vNewValue
End Property
Public Property Get MakeScrollableWithMouseWheel _
(ByVal Obj As Object) As Boolean
MakeScrollableWithMouseWheel = bHooked
End Property
'====================='
'\\ Private Routines '
'====================='
#If VBA7 Then
Function LowLevelMouseProc _
(ByVal ncode As Long, ByVal wParam As LongPtr, ByVal lParam As Long) As LongPtr
Static iTopIndex As Integer
On Error Resume Next
If (ncode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
With oObject
If GetHookStruct(lParam).mousedata > 0 Then
.TopIndex = iTopIndex - 1
iTopIndex = .TopIndex
Else
.TopIndex = iTopIndex + 1
iTopIndex = .TopIndex
End If
End With
LowLevelMouseProc = -1
Exit Function
End If
End If
LowLevelMouseProc = _
CallNextHookEx(lLowLevelMouse, ncode, wParam, ByVal lParam)
#Else
Function LowLevelMouseProc _
(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static iTopIndex As Integer
On Error Resume Next
If (ncode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
With oObject
If GetHookStruct(lParam).mousedata > 0 Then
.TopIndex = iTopIndex - 1
iTopIndex = .TopIndex
Else
.TopIndex = iTopIndex + 1
iTopIndex = .TopIndex
End If
End With
LowLevelMouseProc = -1
Exit Function
End If
End If
LowLevelMouseProc = _
CallNextHookEx(lLowLevelMouse, ncode, wParam, ByVal lParam)
#End If
End Function
Private Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
CopyMemory VarPtr(uParamStruct), lParam, LenB(uParamStruct)
GetHookStruct = uParamStruct
End Function
#If VBA7 Then
Private Function GetAppInstance() As LongPtr
GetAppInstance = GetWindowLongPtr _
(FindWindow("XLMAIN", Application.Caption), GWL_HINSTANCE)
#Else
Private Function GetAppInstance() As Long
GetAppInstance = GetWindowLongPtr _
(FindWindow("XLMAIN", Application.Caption), GWL_HINSTANCE)
#End If
End Function
Private Sub Hook_Mouse()
If lLowLevelMouse = 0 Then
lLowLevelMouse = SetWindowsHookEx _
(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetAppInstance, 0)
End If
End Sub
Private Sub UnHook_Mouse()
If lLowLevelMouse <> 0 Then _
UnhookWindowsHookEx lLowLevelMouse: lLowLevelMouse = 0
End Sub
Display More