Mengaktifkan Scroll Mouse pada Listbox di VBA

Dalam userform di dalam VBA, kita bisa membuat data interaktif dengan menggunakan Listbox. Listbox ini akan menampilkan barisan data dalam bentuk table yang bisa kita pilih. Jika kita membuat sebuah Listbox dalam userform di VBA, kita bisa menggunakan Mouse untuk memilih data namun tidak bisa menggunakan Scroll Mouse untuk memilih data selanjutnya atau sebelumnya. Hal ini wajar karen di Listbox di VBA ini kita tidak bisa menggunakan scroll mouse.

Agar kita bisa menggunakan Scroll Mouse pada Control Listbox, kita bisa memaksakan menggunakan Scroll Mouse dengan bantuan Windows API. disini saya akan sebuah script agar pada listbox bisa menggunakan scroll Mouse seperti pada Aplikasi-aplikasi lain. Walaupun menggunakan Windows API, script dibawah ini sudah disesuikan untuk bisa berjalan di Mesin 32 Bit dan juta 64 bit. Pertama Insert Module pada VBA editor

Pada Module Baru, copy script dibawah ini

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 kode diatas kita copykan kedalam Module, untuk menggunaan Subrutine diatas, Pada Event Mouse Move Listbox tambahkan HookListBoxScroll seperti dibawah ini.

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

Jika sudah, coba jalankan Listbox. Sekarang Listbox sudah bisa menggunakn Scroll Mouse untuk memilih data. seperti pada Gif dibawah ini

File diatas juga bisa didownload Melalui Menu download dibawah ini