Mengaktifkan Scroll Mouse Di ListBox VBA Excel

 Aplikasi Excelku. Selamat datang kembali di Blog Aplikasi Excelku, pada kesempatan ini kembali Saya akan berbagi sebuah tutorial mengenai VBA Excel, dan sesuai dengan judul artikel ini yang akan Saya bagikan adalah mengenai Mengaktifkan Scroll Mouse (HookScroll) di ListBox VBA Excel. 

Pastinya cara ini akan sangat bermanfaat sekali bagi kita pada saat menggunakan sebuah Control ListBox yang kita buat/sisipkan di Useform pada aplikasi berbasis Excel yang kita buat, karena dengan kita mengaktifkan Scroll Mouse/HookScroll ini kita bisa dengan mudah berpindah dari deret data yang satu ke data yang lainnya hanya dengan menggunakan Scroll Mouse. 

Mengaktifkan Scroll Mouse Di ListBox VBA Excel

Berikut Merupakan script VBA untuk mengaktifkan Scroll Mouse/HookScroll di ListBox VBA Excel:

1. Copas script di bawah ini kedalam module :

Option Explicit

'https://aplikasiexcelku.blogspot.com/
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

2. Kemudian Copas script di bawah ini dan masukkan kedalam Userform yang terdapat ListBox:

Private Sub ListBox1_MouseMove( _

             ByVal Button As Integer, ByVal Shift As Integer, _

             ByVal X As Single, ByVal Y As Single)

    If Not Me.ActiveControl Is Me.ListBox1Then

             Me.ListBox1.SetFocus

    End If

    'https://aplikasiexcelku.blogspot.com/

    HookListBoxScroll

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

'https://aplikasiexcelku.blogspot.com/

Application.ScreenUpdating = False

UnhookListBoxScroll

End Sub

Note:

Ubah LitBox1 sesuai dengan nama LitBox masing-masing (jika Sobat Blogger memang mengubah nama dari LitBox1).

Demikian pembahasan mengenai Mengaktifkan Scroll Mouse Di ListBox VBA Excel, mudah-mudahan apa yang sudah Saya sampaikan pada kesempatan ini bisa bermanfaat untuk kita semuanya. Sekian, terimakasih, dan salam belajar.

#HookScroll_ListBox

#HookScroll_VBA

#ScrollMouse_Hook

Share :