Userform Listbox Mouse Tekerleği

ahmetxaksoy · 8 Eylül 2016

Merhabalar.
listbox1 için mouse tekerleği ile hareket ettirmek istiyorum.
Forumda ve çeşitli platformlarda araştırmama rağmen çalışan bir kod bulamadım.
Yardımlarınızı bekliyorum.

TEGCreative · 8 Eylül 2016

Merhaba sayın ahmetxaksoy ; Microsof Office Social sitesinde bulduğum kod çalışmakta.
Userform'a Listbox ekleyip bırakın ve kod sayfasına bunu yazın

Kod:

Private Sub ListBox1_Change()
' be sure to include Error handling for any code that
' might get called while the hook is running
     On Error GoTo errExit
     Me.Caption = Me.ListBox1.Value
     Exit Sub
errExit:
End Sub

Private Sub ListBox1_MouseMove( _
             ByVal Button As Integer, ByVal Shift As Integer, _
             ByVal x As Single, ByVal y As Single)
' start tthe hook
     HookListBoxScroll
End Sub

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

Bir modül açın ve içine bu kodları koyun ;

Kod:

''''''' normal module code

Option Explicit

Private Type POINTAPI
     x As Long
     y As Long
End Type

Private Type MOUSEHOOKSTRUCT
     pt As POINTAPI
     hwnd As Long
     wHitTestCode As Long
     dwExtraInfo As Long
End Type

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

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

Sub HookListBoxScroll()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
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

Private Function MouseProc( _
             ByVal nCode As Long, ByVal wParam As Long, _
             ByRef lParam As MOUSEHOOKSTRUCT) As Long
        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
                             MouseProc = 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
                     UnhookListBoxScroll
             End If
     End If
        MouseProc = CallNextHookEx( _
                             mLngMouseHook, nCode, wParam, ByVal lParam)
     Exit Function
errH:
        UnhookListBoxScroll
End Function

Daha sonra çalıştırıp deneyin .

Kaynak : https://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba

Orion1 · 8 Eylül 2016

Gördünüzmü mause tekerleğini?
Standart kodlardan vazgeçmemek lazım.
Attığın taş ürküttüğün kurbağaya değmez.

TEGCreative · 8 Eylül 2016

Sayın Orion1 hocam ; biraz fanteziye kaçıyor bu işler . Gerçi excel bu , sınırı yok mübareğin

:tongue::tongue::tongue:

asdsxx · 25 Mart 2020

Orion1' Alıntı:
Gördünüzmü mause tekerleğini?
Standart kodlardan vazgeçmemek lazım.
Attığın taş ürküttüğün kurbağaya değmez.

Sayın Orion Bey Textbox içine tıkladıktan sonra fare tekerleğini kullanmak için kod varmı nasıl yaparız

Zeki Gürsoy · 25 Mart 2020

Textbox nesnesi windows handle' a sahip olmadığından yukarıdaki kodlar çalışmayacaktır.

.

asdsxx · 25 Mart 2020

Zeki Gürsoy' Alıntı:
Textbox nesnesi windows handle' a sahip olmadığından yukarıdaki kodlar çalışmayacaktır.

.

Zeki Bey yukarıdaki kodlar zaten listbox için yazılmış sanırım. Ben textbox için fare tekerleğini nasıl kullanırız demiştim.

ulutanas · 25 Mart 2020

Zeki Gürsoy' Alıntı:
Textbox nesnesi windows handle' a sahip olmadığından yukarıdaki kodlar çalışmayacaktır.

.

Bende bu konuyla ilgili aynı hatayı aldım hocam nasıl bir ayarlama yapmamız gerekiyor, yardımcı olur musunuz rica etsem.

Hata değilmiş hocam ben TEGCreative hocamın verdiği kodu eksik yazmışım

asdsxx · 25 Mart 2020

ulutanas' Alıntı:
Bende bu konuyla ilgili aynı hatayı aldım hocam nasıl bir ayarlama yapmamız gerekiyor, yardımcı olur musunuz rica etsem.

Hata değilmiş hocam ben TEGCreative hocamın verdiği kodu eksik yazmışım

Sayın Ulutanas nerede çalıştırdınız. Textbox da mı yoksa Listbox da mı

ulutanas · 26 Mart 2020

asdsxx' Alıntı:
Sayın Ulutanas nerede çalıştırdınız. Textbox da mı yoksa Listbox da mı

Listbox da çalıştı. Textbox da nasıl çalışır bilmiyorum. Ama aynı işlem Combobox için de kullanılabilir sanki, hocalarımız bir çözüm yolu da onun için bulur bence

Haluk · 26 Mart 2020

ListBox+Combobox için (32 Bit Excel)

.

ulutanas · 26 Mart 2020

Haluk' Alıntı:
ListBox+Combobox için (32 Bit Excel)

.

Haluk bey paylaşım için çok teşekkürler.

asdsxx · 26 Mart 2020

Haluk' Alıntı:
ListBox+Combobox için (32 Bit Excel)

.

Haluk Bey teşekkürler. Fakat bende sizin dosyayı açınca şu hata mesajını veriyor Ben Excel 2019 64 bit kullanıyorum. Ondan olabilir mi? Gerçi ilk başlangıçta "PtrSafe" kodlarını ekledim ama...

Sezgin77 · 17 Aralık 2020

TEGCreative' Alıntı:

Merhaba sayın ahmetxaksoy ; Microsof Office Social sitesinde bulduğum kod çalışmakta.
Userform'a Listbox ekleyip bırakın ve kod sayfasına bunu yazın

Kod:

Private Sub ListBox1_Change()
' be sure to include Error handling for any code that
' might get called while the hook is running
     On Error GoTo errExit
     Me.Caption = Me.ListBox1.Value
     Exit Sub
errExit:
End Sub

Private Sub ListBox1_MouseMove( _
             ByVal Button As Integer, ByVal Shift As Integer, _
             ByVal x As Single, ByVal y As Single)
' start tthe hook
     HookListBoxScroll
End Sub

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

Bir modül açın ve içine bu kodları koyun ;

Kod:

''''''' normal module code

Option Explicit

Private Type POINTAPI
     x As Long
     y As Long
End Type

Private Type MOUSEHOOKSTRUCT
     pt As POINTAPI
     hwnd As Long
     wHitTestCode As Long
     dwExtraInfo As Long
End Type

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

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

Sub HookListBoxScroll()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
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

Private Function MouseProc( _
             ByVal nCode As Long, ByVal wParam As Long, _
             ByRef lParam As MOUSEHOOKSTRUCT) As Long
        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
                             MouseProc = 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
                     UnhookListBoxScroll
             End If
     End If
        MouseProc = CallNextHookEx( _
                             mLngMouseHook, nCode, wParam, ByVal lParam)
     Exit Function
errH:
        UnhookListBoxScroll
End Function

Daha sonra çalıştırıp deneyin .

Kaynak : https://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba

Hocam merhaba,
Kodu gerekli yerlere kopyaladım ama, Private Declare Function fonksiyonları altına End Function girmemi istiyor ama yazdığımda da kabul etmiyor,
Yardımcı olabilirmisiniz.

Sezgin77 · 17 Aralık 2020

Çok teşekkürler,
Ben de çalıştırdım sonunda, harika oldu

asdsxx · 17 Aralık 2020

Sezgin77' Alıntı:
Çok teşekkürler,
Ben de çalıştırdım sonunda, harika oldu

Nasıl çalıştırdınız acaba 2. mesajdaki kod'u mu çalıştırdınız yoksa 11. mesajdaki dosyayı mı
Bende 11. mesajdaki dosya bir türlü çalışmadı. Eklediğim hata mesajı çıkıyor.

Mahmut Bayram · 18 Aralık 2020

Belki bu dosya işinize yarar.

Sezgin77 · 6 Ocak 2021

asdsxx' Alıntı:
Nasıl çalıştırdınız acaba 2. mesajdaki kod'u mu çalıştırdınız yoksa 11. mesajdaki dosyayı mı
Bende 11. mesajdaki dosya bir türlü çalışmadı. Eklediğim hata mesajı çıkıyor.

Hocam kusura bakmayın, yeni gördüm...

Ben ikinci mesaj içeriğini kopyaladığımda çalıştı.

Saygılar,

hyilmaz27 · 20 Temmuz 2021

Mahmut Bayram' Alıntı:
Belki bu dosya işinize yarar.

üyelik tarifesi hk bilgi verebilir misiniz. mouse scroll.xlm e benim de ihtiyacım var

ulutanas · 27 Aralık 2021

Haluk' Alıntı:
ListBox+Combobox için (32 Bit Excel)

.

Haluk hocam merhaba ben office 2021'e geçtim de bu kodlar 32 bit'e göre ayarlandığından aşağıda ki kırmızı bölümlerde hata veriyor.
Nasıl düzeltebiliriz.

Kod:

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type

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 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

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 mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
Private mCtl As MSForms.Control

Dim n As Long

Userform Listbox Mouse Tekerleği

ahmetxaksoy

TEGCreative

Orion1

Uzman

TEGCreative

asdsxx

Zeki Gürsoy

Uzman

asdsxx

ulutanas

asdsxx

ulutanas

Haluk

Özel Üye

Ekli dosyalar

ulutanas

asdsxx

Sezgin77

Sezgin77

asdsxx

Mahmut Bayram

Özel Üye

Ekli dosyalar

Sezgin77

hyilmaz27

ulutanas