
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
Leave a Reply