Đang tập tành và còn nhờ cao thủ chỉ giúp thì đừng đưa ra "TẶNG" bạn nhé, mình không rành code, mình nghĩ mang ra tặng thì đó phải là sản phẩm đảm bảo hữu ích, sử dụng trơn tru, tốt. Ở đây nhiều tiền bối lắm, coi chừng bị sửa "cốt" .
Private Sub ComboBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.ComboBox1.DropDown
MakeScrollableWithMouseWheel(ComboBox1) = True
End SubPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$F$9" Then
Target.Value = ""
With ComboBox1
.Top = Target.Top
.Left = Target.Left
.Width = Target.Width
.ListFillRange = ""
.LinkedCell = "F9"
.Visible = True
.Activate
End With
End If
End SubPrivate Sub Combobox1_GotFocus()
Dim str As String
Dim cboTemp As OLEObject
Set cboTemp = Me.OLEObjects("Combobox1")
On Error Resume Next
cboTemp.ListFillRange = "list"
ComboBox1.DropDown
MakeScrollableWithMouseWheel(ComboBox1) = True
Set cboTemp = Nothing
End SubPrivate Sub ComboBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ComboBox1.DropDown
End SubPrivate Sub ComboBox1_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
'Hide combo box and move to next cell on Enter and Tab
Select Case KeyCode
Case 9 'tab key
ActiveCell.Offset(0, 1).Activate
Case 13 'enter key
ActiveCell.Offset(1, 0).Activate
Case 37 'left
ActiveCell.Offset(0, -1).Activate
Case 39 'right
ActiveCell.Offset(0, 1).Activate
Case 46 ' delete key
Me.ComboBox1.Value = ""
Me.ComboBox1.DropDown
Case 8 ' Backspace key
Me.ComboBox1.Value = ""
Me.ComboBox1.DropDown
End Select
End SubPrivate Sub ComboBox1_LostFocus()
Range("F9").Comment.Visible = False
ComboBox1.Visible = False
MakeScrollableWithMouseWheel(ComboBox1) = False
End SubPrivate Sub ComboBox1_Enter()
MakeScrollableWithMouseWheel(ComboBox1) = True
End Sub
Private Sub ComboBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ComboBox1.DropDown
End Sub
Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
MakeScrollableWithMouseWheel(ComboBox1) = False
End SubPrivate Sub ListBox1_Enter()
MakeScrollableWithMouseWheel(ListBox1) = True
End Sub
Private Sub ListBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
MakeScrollableWithMouseWheel(ListBox1) = False
End Sub
Vì tôi không có máy 64bit nên không thể test được, bạn thử thay thế trong Module1 dòng API này:
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long#If VBA7 And Win64 Then 'Office 64-bit
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else ' Office 32-bit
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Option Explicit
' Developed D.T.NAM.
' CFT VINA COPPER CO.,
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 And Win64 Then 'Office 64-bit
Private Declare PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
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 GetWindowLong Lib "user32" _
Alias "GetWindowLongA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As LongPtr) 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 ' Office 32-bit
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" ( _
ByVal Destination As Long, _
ByVal Source As Long, _
ByVal Length 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
#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 '
'====================='
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 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 SubBạn chụp cái hình module đó lên lần nữa xem sao.Không được luôn anh
Option Explicit
' Developed D.T.NAM.
' CFT VINA COPPER CO.,
Private Type POINTAPI
X As LongPtr
Y As LongPtr
End Type
Private Type MSLLHOOKSTRUCT
pt As POINTAPI
mousedata As LongPtr
flags As LongPtr
time As LongPtr
dwExtraInfo As LongPtr
End Type
Private Declare PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
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 GetWindowLong Lib "user32" _
Alias "GetWindowLongA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As LongPtr) 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
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 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
Function LowLevelMouseProc(ByVal nCode As LongPtr, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) 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)
End Function
Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
CopyMemory VarPtr(uParamStruct), lParam, LenB(uParamStruct)
GetHookStruct = uParamStruct
End Function
Private Function GetAppInstance() As LongPtr
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
