Scroll Mouse Pada Listbox

Listbox adalah komponen antarmuka pengguna yang berguna untuk menampilkan daftar item yang dapat dipilih.

Namun, seringkali kita menghadapi situasi di mana daftar item yang ditampilkan terlalu panjang untuk ditampilkan secara keseluruhan di area yang tersedia, menyebabkan beberapa item tidak terlihat tanpa adanya fitur scroll.

Dalam materi kali ini, saya akan membahas bagaimana cara menambahkan fungsi scroll mouse pada Listbox menggunakan VBA.

Fungsi scroll mouse ini memungkinkan pengguna untuk dengan mudah menavigasi melalui daftar item yang panjang dengan menggunakan roda mouse, sehingga mempermudah proses pemilihan item.

Menggunakan Windows API

Untuk menambahkan scroll Mouse kedalam Listbox di Userform VBA, kita harus menambahkan sebuah Windows API.

Listbox bawaan VBA pada dasarnya tidak memiliki akses Scroll Mouse.

Berikut ini adalah langkah-langkahnya untuk menambahkan scroll mouse pada Listbox dengan menggunakan Windows API.

Script dibawah ini bisa berjalan dengan baik di 32bit ataupun 64bit.

Simpan script dibawah ini kedalam Standard Module.

Option Explicit
Option Private Module
#If Win64 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As Long, ByVal yPoint As Long) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowLong Lib "user32.dll" 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
    Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
#End If
Private Type POINTAPI
    X                               As Long
    Y                               As Long
End Type

#If Win64 Then
Private Type MSLLHOOKSTRUCT
    pt                              As POINTAPI
    mouseData                       As Long
    flags                           As Long
    time                            As Long
    dwExtraInfo                     As LongPtr
End Type
#Else
Private Type MSLLHOOKSTRUCT
    pt                              As POINTAPI
    mouseData                       As Long
    flags                           As Long
    time                            As Long
    dwExtraInfo                     As Long
End Type
#End If

Private Const WH_MOUSE_LL           As Long = 14
Private Const WH_MOUSE              As Long = 7
Private Const WM_MOUSEWHEEL         As Long = &H20A
Private Const HC_ACTION             As Long = 0
Private Const GWL_HINSTANCE         As Long = (-6)
Private Const WM_KEYDOWN            As Long = &H100
Private Const WM_KEYUP              As Long = &H101
Private Const VK_UP                 As Long = &H26
Private Const VK_DOWN               As Long = &H28
Private Const WM_LBUTTONDOWN        As Long = &H201

#If Win64 Then
    Private mLngMouseHook           As LongPtr
    Private mListBoxHwnd            As LongPtr
#Else
    Private mLngMouseHook           As Long
    Private mListBoxHwnd            As Long
#End If
Private mbHook                      As Boolean

Sub HookListBoxScroll()
#If Win64 Then
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
#Else
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
#End If
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
If mListBoxHwnd <> hwndUnderCursor Then
    UnhookListBoxScroll
    mListBoxHwnd = hwndUnderCursor
    lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
    PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
    If Not mbHook Then
        mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
        mbHook = mLngMouseHook <> 0
    End If
End If
End Sub

Sub UnhookListBoxScroll()
If mbHook Then
    UnhookWindowsHookEx mLngMouseHook
    mLngMouseHook = 0
    mListBoxHwnd = 0
    mbHook = False
End If
End Sub

#If Win64 Then
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MSLLHOOKSTRUCT) As LongPtr
#Else
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MSLLHOOKSTRUCT) As Long
#End If
On Error GoTo errH
If (nCode = HC_ACTION) Then
    If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
        If wParam = WM_MOUSEWHEEL Then
            MouseProc = True
            Debug.Print lParam.mouseData
            If lParam.mouseData > 0 Then
                PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
            Else
                PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
            End If
            PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
            Exit Function
        End If
    Else
        UnhookListBoxScroll
    End If
End If
MouseProc = CallNextHookEx(mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function

Setelah Script windows API ditambahkan, untuk mengaktifkan scroll Mouse pada Listbox, bisa tambahkan script dibawah ini kedalam events Listbox MouseMove.

Artinya ketika ada pergerakan mouse pada listbox, maka Sub HookListBoxScroll akan dijalankan.

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll
End Sub