【发布时间】：2016-04-14 11:32:02
【问题描述】：
我使用 Excel 2016 创建了一个文件并保存为 .xls，因为它必须能够被企业中的其他计算机使用 Excel 2003 使用。除此之外，还有组合框弹出窗口。我输入了允许我使用鼠标滚轮滚动数据的代码。一切都在运行 Windows 10 和 64 位 Excel 2016、Excel 2003 和 Windows 7 64 位、Windows XP 32 位和 Excel 2003 的机器上完美运行。 当此文件在（多台）具有 Windows 7 64 位和 Excel 2010 的 PC 上打开时会出现问题：当用户双击受影响的单元格（应出现组合框）时出现错误：“错误编译：类型不匹配。 "
错误位于第 151 行，突出显示“CallNextHookEx”。
这是整个模块
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 GetWindowLong Lib "USER32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
#Else
Private Declare Function GetWindowLong 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.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib _
"USER32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As LongPtr, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As LongPtr) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "USER32" _
(ByVal hHook As LongPtr, _
ByVal nCode As LongPtr, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "USER32" _
(ByVal hHook As LongPtr) As LongPtr
#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)
Private uParamStruct As MSLLHOOKSTRUCT
Private oObject As Object
Private lLowLevelMouse As Long
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 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)
#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
Private Function GetAppInstance() As Long
GetAppInstance = GetWindowLong _
(FindWindow("XLMAIN", Application.Caption), GWL_HINSTANCE)
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
这是 Sheet1 代码：
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("TempCombo")
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
noindi:
With cboTemp
'show the combobox with the list
.Visible = True
.Left = target.Left
.Top = target.Top
.Width = target.Width + 5
.Height = target.Height + 5
.ListFillRange = str
.LinkedCell = target.Address
End With
cboTemp.Activate
'open the drop down list automatically
Me.TempCombo.DropDown
MakeScrollableWithMouseWheel(TempCombo) = True
errHandler:
Application.EnableEvents = True
Exit Sub
End Sub
'=========================================
Private Sub TempCOmbo_LostFocus()
MakeScrollableWithMouseWheel(TempCombo) = False
With Me.TempCombo
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End Sub
'====================================
'Optional code to move to next cell
'if Tab or Enter are pressed
'from code by Ted Lanham
'***NOTE: if KeyDown causes problems,
'change to KeyUp
'Table with numbers for other keys
'such as Right Arrow (39)
'https://msdn.microsoft.com/en-us/library/aa243025%28v=vs.60%29.aspx
'For dates or numbers in the data validation, you can use the KeyDown code in the Code for Numbers section below.
Private Sub TempCombo_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
'====================================
'Private WithEvents wb As Workbook
'Private Sub ComboBox1_GotFocus()
' Set wb = ThisWorkbook
' MakeScrollableWithMouseWheel(TempCombo) = True
'End Sub
'Private Sub ComboBox1_LostFocus()
' MakeScrollableWithMouseWheel(TempCombo) = False
'End Sub
'Private Sub wb_BeforeClose(Cancel As Boolean)
' If MakeScrollableWithMouseWheel(TempCombo) Then
' MakeScrollableWithMouseWheel(TempCombo) = False
' End If
'End Sub
P.S.：所有安装的 Office 套件都是 32 位的
你能帮帮我吗？
【问题讨论】：
标签： excel vba mouse mousewheel