1
我使用Excel 2016創建了一個文件，並將其保存爲.xls，因爲它必須能夠被企業中的其他計算機與Excel 2003一起使用。除此之外，是組合框彈出。我輸入了允許使用鼠標滾輪瀏覽數據的代碼。在運行Windows 10和64位Excel 2016，Excel 2003和Windows 7 64位，Windows XP 32位和Excel 2003的計算機上，一切正常運行。 在Windows 7 64位和Excel（多個）PC上打開此文件時出現此問題2010：當用戶雙擊受影響的單元格（應顯示組合框）時出現錯誤：「錯誤編譯：類型不匹配」。在Excel中使用鼠標滾輪動態組合框無法在Excel 2010上工作
錯誤位於第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位
你能幫助我嗎？