Cuộn chuột trong Listbox Combobox WINDOWN API, bằng cách sử dụng cái bánh xe nằm giữa chuột phải và chuột trái. Được dùng chủ yếu để cuộn trang web. Nhưng nó còn có những tác dụng, thú vị mà không phải ai cũng biết được, hoặc ít ai để ý. Sử dụng nút lăn chuột trong Userform. Áp dụng cho các Listbox.
Nhưng chúng ta biết rằng khi dữ liệu quá nhiều, chúng ta mong muốn có thể sử dụng chuột giữa, để cuộn lên cuộn xuống dữ liệu trong listbox. Tuy nhiên điều này không thể thực hiện được trong VBA, do đó chúng ta phải sử dụng các hàm thư viện API trong window. Bài viết này sẽ hướng dẫn bạn làm điều đó.
Cuộn chuột trong Listbox Combobox WINDOWN API
I.Công dụng Cuộn chuột trong Listbox Combobox WINDOWN API.
- Thao tác tìm kiếm nhanh trong danh sách 1 cách chính xác
- Thao tác tiềm kiếm tùy chọn 10 dòng 1 lần hoặc tùy biến theo bạn chỉnh sửa
II.Hướng dẫn Cuộn chuột trong Listbox Combobox WINDOWN API.
BƯỚC 1: Vào trình xoạn thảo VBA , tạo 1 model -> rồi coppy toàn bộ code phía dưới vào.
Option Explicit
' Jaafar Tribak @ MrExcel.com on 22/04/20 (last update on 05/10/2020)
' Generic code that enables mousewheel scrolling in vba ListBoxes & ComboBoxes
' in worksheests and Userforms .
'Property.
'EnableMouseWheelScroll (Write Boolean )
'Args :1- ListOrComboControl As Object
' 2- Optional WheelScrollLines As Long =1
' 3- Optional ChangeControlValueAsYouScroll As Boolean = False
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type MSG
#If Win64 Then
hwnd As LongLong
message As Long
wParam As LongLong
lParam As LongLong
#Else
hwnd As Long
message As Long
wParam As Long
lParam As Long
#End If
time As Long
pt As POINTAPI
End Type
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private 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
Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetQueueStatus Lib "user32" (ByVal fuFlags As Long) As Long
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#Else
Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private 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
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetQueueStatus Lib "user32" (ByVal fuFlags As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
#End If
Public sUserFeedBack As String
Private bMonitoringMouseWheel As Boolean
Private bSomeKeyIsBeingPressed As Boolean
Public Property Let EnableMouseWheelScroll _
( _
ByVal ListOrComboControl As Object, _
Optional ByVal WheelScrollLines As Long = 1, _
Optional ByVal ChangeControlValueAsYouScroll As Boolean, _
ByVal Enable As Boolean _
)
Const WM_MOUSEWHEEL = &H20A
Const WHEEL_DELTA = 120
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const MK_LBUTTON = &H1
Const WM_KEYDOWN = &H100
Const WM_KEYUP = &H101
Const VK_ESCAPE = &H1B
Const PM_NOREMOVE = &H0
Const PM_NOYIELD = &H2
Const QS_KEY = &H1
Const SM_CXVSCROLL = 2
#If VBA7 Then
Static hActualList As LongPtr
Dim hwnd As LongPtr
#Else
Static hActualList As Long
Dim hwnd As Long
#End If
Dim tRect As RECT, tMsg As MSG, tCurPos As POINTAPI
Dim Low As Integer, High As Integer, i As Integer
Dim vChild As Variant, oIA As IAccessible
Call WindowFromAccessibleObject(ListOrComboControl, hwnd)
If Not bMonitoringMouseWheel Then
bMonitoringMouseWheel = True
If Enable Then
Call UserFeedBack("Start Monitoring MouseWheel Messages for : (" & ListOrComboControl.Name & ")")
On Error Resume Next
Application.EnableCancelKey = xlDisabled
On Error GoTo 0
Do While IsWindow(hwnd)
Call GetCursorPos(tCurPos)
If IsMouseOverControl(ListOrComboControl, ChangeControlValueAsYouScroll, tCurPos) = False Then
Exit Do
End If
#If Win64 Then
Dim lPt As LongLong
Call CopyMemory(lPt, tCurPos, LenB(lPt))
Call AccessibleObjectFromPoint(lPt, oIA, vChild)
#Else
Call AccessibleObjectFromPoint(tCurPos.x, tCurPos.y, oIA, vChild)
#End If
If oIA.accRole(0&) = 46 Then
tCurPos.y = tCurPos.y + PTtoPX(ListOrComboControl.Height, False)
End If
#If Win64 Then
Dim lPt2 As LongLong
Call CopyMemory(lPt2, tCurPos, LenB(lPt2))
hActualList = WindowFromPoint(lPt2)
#Else
hActualList = WindowFromPoint(tCurPos.x, tCurPos.y)
#End If
Call WaitMessage
If PeekMessage(tMsg, 0, 0, 0, PM_NOREMOVE + PM_NOYIELD) Then
If GetQueueStatus(QS_KEY) Then
bSomeKeyIsBeingPressed = True
Else
bSomeKeyIsBeingPressed = False
End If
If tMsg.message = WM_MOUSEWHEEL Then
Call GetClientRect(hActualList, tRect)
#If Win64 Then
Dim lParm As LongLong
If IsMouseOverControl(ListOrComboControl, ChangeControlValueAsYouScroll, tMsg.pt) = True Then
If (HighWord64(tMsg.wParam) / WHEEL_DELTA) > 0 Or (HighWord64(tMsg.wParam) = WHEEL_DELTA) Then
#Else
Dim lParm As Long
If IsMouseOverControl(ListOrComboControl, ChangeControlValueAsYouScroll, tMsg.pt) = True Then
If (HighWord32(tMsg.wParam) / WHEEL_DELTA) > 0 Or (HighWord32(tMsg.wParam) = WHEEL_DELTA) Then
#End If
Call UserFeedBack("MouseWheel Scrolling (Up)")
Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
High = tRect.Top + ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
Else
Call UserFeedBack("MouseWheel Scrolling (Down)")
Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
High = tRect.Bottom - ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
End If 'End If HighWord
lParm = MakeDWord(Low, High)
For i = 1 To WheelScrollLines
Call PostMessage(hActualList, WM_LBUTTONDOWN, MK_LBUTTON, lParm)
Call PostMessage(hActualList, WM_LBUTTONUP, MK_LBUTTON, lParm)
Next i
If TypeName(ListOrComboControl.Parent) = "Worksheet" Then SetFocus hActualList
End If 'End If IsMouseOverControl
End If ' End If WM_MOUSEWHEEL
End If ' End If PeekMessage
DoEvents
Loop
If TypeName(ListOrComboControl) = "ListBox" Then
Call PostMessage(GetParent(hActualList), WM_KEYDOWN, VK_ESCAPE, Build_lParam_WM_KEYDOWN(1, &H0, False, False, False))
Call PostMessage(GetParent(hActualList), WM_KEYUP, VK_ESCAPE, Build_lParam_WM_KEYUP(1, &H0, False, False))
End If
On Error Resume Next
Application.EnableCancelKey = xlInterrupt
On Error GoTo 0
bMonitoringMouseWheel = False
Call UserFeedBack("Stopped Monitoring MouseWheel Messages for : (" & ListOrComboControl.Name & ")")
End If 'End If Enable
End If 'End If bMonitoringMouseWheel
End Property
'_____________________________________Helper Private Routines_____________________________________________________
Private Function IsMouseOverControl( _
ByVal ListOrComboControl As Object, _
ByVal ChangeControlValueAsYouScroll As Boolean, _
ByRef CusPos As POINTAPI) As Boolean
Dim vChild As Variant, oIA As IAccessible
#If Win64 Then
Dim lPt As LongLong
CopyMemory lPt, CusPos, LenB(lPt)
Call AccessibleObjectFromPoint(lPt, oIA, vChild)
#Else
Call AccessibleObjectFromPoint(CusPos.x, CusPos.y, oIA, vChild)
#End If
On Error Resume Next
If Not ListOrComboControl Is Nothing Then
If oIA.accRole(0&) <> 46 Then
If bSomeKeyIsBeingPressed = False Then
If ChangeControlValueAsYouScroll Then
ListOrComboControl.value = ListOrComboControl.List(vChild - 1)
End If
End If
End If
End If
IsMouseOverControl = oIA.accRole(0&) = 33 Or oIA.accRole(0&) = 46
End Function
Private Sub UserFeedBack(ByVal Feedback As String)
Debug.Print Feedback
sUserFeedBack = Feedback
End Sub
Private Function MakeDWord(ByVal loword As Integer, ByVal hiword As Integer) As Long
MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function
Private Function HighWord32(ByVal wParam As Long) As Integer
CopyMemory HighWord32, ByVal VarPtr(wParam) + 2, 2
End Function
#If Win64 Then
Private Function HighWord64(ByVal wParam As LongLong) As Long
CopyMemory HighWord64, ByVal VarPtr(wParam) + 2, 4
End Function
#End If
Private Function ScreenDPI(ByVal bVert As Boolean) As Long
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Static lDPI(1), hDc
If lDPI(0) = 0 Then
hDc = GetDC(0)
lDPI(0) = GetDeviceCaps(hDc, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(hDc, LOGPIXELSY)
hDc = ReleaseDC(0, hDc)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
Const POINTSPERINCH As Long = 72
PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
Private Function Build_lParam( _
ByVal RepeatCount As Integer, _
ByVal ScanCode As Byte, _
ByVal ContextCode As Boolean, _
ByVal ExtendedKey As Boolean, _
ByVal PreviousKeyState As Boolean, _
ByVal TransitionState As Boolean) As Long
Dim lParamBits As Long
lParamBits = RepeatCount Or (ScanCode) Or 2 ^ 16
If ExtendedKey Then lParamBits = lParamBits Or 2 ^ 24
If ContextCode Then lParamBits = lParamBits Or 2 ^ 29
If PreviousKeyState Then lParamBits = lParamBits Or 2 ^ 30
If TransitionState Then lParamBits = lParamBits Or -2 ^ 31
Build_lParam = lParamBits
End Function
Private Function Build_lParam_WM_KEYDOWN( _
ByVal RepeatCount As Integer, _
ByVal ScanCode As Byte, _
ByVal ExtendedKey As Boolean, _
ByVal ContextCode As Boolean, _
ByVal PreviousKeyState As Boolean) _
As Long
Build_lParam_WM_KEYDOWN = Build_lParam(RepeatCount, ScanCode, ExtendedKey, ContextCode, PreviousKeyState, False)
End Function
Private Function Build_lParam_WM_KEYUP( _
ByVal RepeatCount As Integer, _
ByVal ScanCode As Byte, _
ByVal ExtendedKey As Boolean, _
ByVal ContextCode As Boolean) _
As Long
Build_lParam_WM_KEYUP = Build_lParam(RepeatCount, ScanCode, ExtendedKey, ContextCode, True, True)
End Function
BƯỚC 2 : Tạo 1 USERFORM, tạo 1 listbox hoặc combobox với sự kiện MouseMove . Rồi coppy code này vào và sửa lại
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
EnableMouseWheelScroll(ListOrComboControl:=ListBox1, WheelScrollLines:=1, ChangeControlValueAsYouScroll:=False) = True
End Sub
BƯỚC 3 : bạn cần chỉnh sửa lại như sau.
ListOrComboControl:=ListBox1 : bạn thay tên Listbox1 thành tên listbox vừa tạo.
WheelScrollLines:=1 : Số dòng bạn muốn di chuyển khi cuộn chuột.
ChangeControlValueAsYouScroll:=False : có 2 trường hợp , Nếu Là FASLE thì bạn cần chọn , còn TRUE thì nó chọn cho bạn luôn.
III.DOWN FILE
LICK VÀO ĐÂY ĐỂ TẢI DEMO
Như vây, chúng tôi đã hướng dẫn xong bài viết Cuộn chuột trong Listbox Combobox WINDOWN API. Chúc các bạn thực hiện thành công.
Tham khảo thêm các bài viết.
Cho phép nhập liệu số trong TEXTBOX
Zoom Picture Frame In Userform VBA EXCEL 2021
Tạo Userform resize with VBA or Windows API
