Cara Membuat Fungsi Scroll Data ListBox

More Info:

Fungsi Mouse Scroll Data ListBox

Fungsi Mouse Scroll adalah untuk menggulung layar pada suatu tampilan/visual, biasanya digunakan untuk menggulung layar secara vertikal, sementara fungsi mouse scrroll pada listbox dalam vba excel digunakan untuk menggulung isi/data yang ditampilkan dalam listbox tersebut.

Mouse scroll pada listbox vba excel secara default belum berfungsi/belum bisa digunakan. Untuk mengguanakannya harus membuat beberapa fungsi khusus yang harus ditambahkan dan di eksekusi dengan memanggil fungsi khusus tersebut pada Private Sub Mouse_Move

Langkah-langkah Membuat dan Menambahkan Fungsi Mouse Scroll pada ListBox

Sebelum membuat fungsi mouse scroll pada listbox dengan vba excel, harus sudah membuat dulu form untuk menampilkan data tabel/sheet pada sebuah listbox. Caranya bisa dilihat pada beberapa posting sebelumnya:

Referensi Menampilkan Data ListBox

bagaimana cara menampilkan dan mencari data listbox

cara membuat dan menampilkan data listbox dengan progressbar

cara mengurutkan/sort data listbox yang dilengkapi progressbar

Fungsi-fungsi Mouse Scroll Data ListBox

Misalnya, sebagai contoh pada project dalam posting "cara mengurutkan/sort data listbox yang dilengkapi progressbar" (link di atas) sudah dibuat form "Form_Sort_PorgressBar_ListBox" dengan sebuah listbox "LB_Detail_KARYAWAN"

Langkah selajutnya...

Sepert biasa, buka visual basic editor (ALT + F11)
Buat/insert sebuam Module baru (misalnya Module2)
Pada Module2 ini tambahkan beberapa fungsi mouse scroll seperti berikut: Option Explicit

Private Type JTPediaPointAPI
X As Long
Y As Long
End Type

Private Type JTPediaMouseStructure
pt As JTPediaPointAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type

#If VBA7 And Win64 Then
Private Declare PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#Else
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#End If

#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
#Else
Private Declare Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
#End If

#If VBA7 And Win64 Then
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As LongPtr, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As LongPtr) As Long
#Else
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
#End If

#If VBA7 And Win64 Then
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
#Else
Private Declare Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
#End If

#If VBA7 And Win64 Then
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
#Else
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
#End If

#If VBA7 And Win64 Then
Private Declare PtrSafe 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
#Else
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
#End If

#If VBA7 And Win64 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
#Else
Private Declare Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
#End If

#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As JTPediaPointAPI) As Long
#Else
Private Declare Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As JTPediaPointAPI) As Long
#End If

Private Const WH_MOUSE_LL As Long = 14
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

Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean

Private Function MouseScrollProcess( _
ByVal ncode As Long, ByVal wParam As Long, _
ByRef lParam As JTPediaMouseStructure) As Long

On Error Resume Next
On Error GoTo errH 'Resume Next
If (ncode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseScrollProcess = True
If lParam.hwnd > 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
UnScrollMyListBox
End If
End If
MouseScrollProcess = CallNextHookEx( _
mLngMouseHook, ncode, wParam, ByVal lParam)
Exit Function
errH:
UnScrollMyListBox

On Error GoTo 0
End Function

Sub ScrollMyListBox()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPt As JTPediaPointAPI

GetCursorPos tPt
hwndUnderCursor = WindowFromPoint(tPt.X, tPt.Y)
If mListBoxHwnd <> hwndUnderCursor Then
UnScrollMyListBox
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseScrollProcess, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub

Sub UnScrollMyListBox()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Lalu pada form "Form_Sort_PorgressBar_ListBox tambahkan kode baru seperti berikut:
Private Sub LB_Detail_KARYAWAN_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Not Me.ActiveControl Is Me.LB_Detail_KARYAWAN Then
Me.LB_Detail_KARYAWAN.SetFocus
End If
ScrollMyListBox
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnScrollMyListBox
End Sub
Terakhir, sesuai contoh ini untuk mencobanya silahkan runing project / load form "Form_Sort_PorgressBar_ListBox". Jika form sudah terbuka arahkan mouse pada data ListBox dan coba scroll mouse.
Jika semua kode di atas sudah benar dan tidak ada kesalahan, maka scroll mouse akan berfungsi normal untuk menggulung data listbox