Cuộn chuột trong Listbox Combobox WINDOWN API

23/06/21
Thủ thuật Excel, VBA Excel
1286
0

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

Cuộn chuột trong Listbox Combobox WINDOWN API
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.

Cuộn chuột trong Listbox Combobox WINDOWN API
Cuộn chuột trong Listbox Combobox WINDOWN API
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.

Cuộn chuột trong Listbox Combobox WINDOWN API
Cuộn chuột trong Listbox Combobox WINDOWN API

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

5/5 - (1 bình chọn)

Trả lời

Email của bạn sẽ không được hiển thị công khai. Các trường bắt buộc được đánh dấu *