Hook ListBox Scroll VBA Excel

 Mas Operator. Selamat datang kembali di blog sederhana Saya ini, pada kesempatan kali ini kembali Saya akan memberikan sebuah tutorial sederhana mengenai Macro VBA Excel. Dan sesuai dengan judul artikel ini, Saya akan memberikan tutorial mengenai Hook ListBox Scroll tentunya pada Aplikasi Ms. Excel. Bagi Sobat Blogger yang suka atau masih belajar VBA Excel seperti halnya Saya pasti sudah mengenal salah satu control yang ada di Ms. Excel yaitu ListBox, dimana ListBox bisa kita manfaatkan untuk menampilkan deretan data dari cell yang kita inginkan.

Agar mempermudah berpindah dari deret data yang satu ke data yang lainnya yang didalam control ListBox kita bisa mengaktifkan HookScroll pada control ListBox yang sudah kita sisipkan didalam Userform. Karena dengan kita mengaktifkan HookScroll pada control ListBox tersebut baik pengguna/kita bisa dengan mudah berpindah dari deret data yang satu ke deret data yang lainnya dengan menggunakan Scroll yang ada di Mouse.

Berikut gambaran jika kita mengaktifkan HookScroll pada control ListBox:

Dan berikut merupakan langkah-langkah untuk mengaktifkan HookScroll pada Control ListBox VBA Excel:

1. Sisipkan sebuah Module, kemudian Copas script di bawah ini kedalam Module tersebut:

Option Private Module

'https://masoperator.blogspot.com
#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. Silahkan Copas Script di bawah ini kedalam Userform yang terdapat Control 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
    HookListBoxScroll
End Sub

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

'https://masoperator.blogspot.com

Application.ScreenUpdating = False

UnhookListBoxScroll

End Sub

Jika sudah, silahkan jalankan Userform yang terdapat Control ListBox didalamnya. Dan sebagai catatan, ubah teks ListBox1 sesuai dengan nama ListBox yang ada di Userform Sobat semuanya, barangkali Sobat Blogger mengubah nama dari ListBox yang ada Userform Sobat Blogger.

Contoh hasil jadinya juga bisa dilihat secara langsung DISINI

Demikian pembahasan/artikel mengenai Hook ListBox Scroll VBA Excel, mudah-mudahan apa yang sudah Saya sampaikan pada kesempatan kali ini bisa bermanfaat untuk kita semuanya, sekian, terimakasih, dan Salam Mas Operator!!!

Share :