Userform Listbox Mouse Tekerleği

Katılım
5 Ağustos 2015
Mesajlar
17
Excel Vers. ve Dili
2010
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.
 
Katılım
3 Aralık 2014
Mesajlar
213
Excel Vers. ve Dili
Microsoft Excel 2007
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

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Gördünüzmü mause tekerleğini?
Standart kodlardan vazgeçmemek lazım.
Attığın taş ürküttüğün kurbağaya değmez.:cool:
 
Katılım
3 Aralık 2014
Mesajlar
213
Excel Vers. ve Dili
Microsoft Excel 2007
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

Altın Üye
Katılım
22 Mayıs 2012
Mesajlar
479
Excel Vers. ve Dili
Excel 2016 Türkçe
Gördünüzmü mause tekerleğini?
Standart kodlardan vazgeçmemek lazım.
Attığın taş ürküttüğün kurbağaya değmez.:cool:
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

Uzman
Uzman
Katılım
31 Aralık 2005
Mesajlar
4,225
Excel Vers. ve Dili
Office 2019 (64 bit) - Türkçe
Textbox nesnesi windows handle' a sahip olmadığından yukarıdaki kodlar çalışmayacaktır.

.
 

asdsxx

Altın Üye
Katılım
22 Mayıs 2012
Mesajlar
479
Excel Vers. ve Dili
Excel 2016 Türkçe
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

Altın Üye
Katılım
8 Kasım 2008
Mesajlar
578
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2021 TR 32 Bit
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 :)
 
Son düzenleme:

asdsxx

Altın Üye
Katılım
22 Mayıs 2012
Mesajlar
479
Excel Vers. ve Dili
Excel 2016 Türkçe
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

Altın Üye
Katılım
8 Kasım 2008
Mesajlar
578
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2021 TR 32 Bit
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 :)
 

asdsxx

Altın Üye
Katılım
22 Mayıs 2012
Mesajlar
479
Excel Vers. ve Dili
Excel 2016 Türkçe
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...

215679
 
Katılım
10 Aralık 2019
Mesajlar
3
Excel Vers. ve Dili
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
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.
 

asdsxx

Altın Üye
Katılım
22 Mayıs 2012
Mesajlar
479
Excel Vers. ve Dili
Excel 2016 Türkçe
Ç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.
 
Katılım
10 Aralık 2019
Mesajlar
3
Excel Vers. ve Dili
2016
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,
 

ulutanas

Altın Üye
Katılım
8 Kasım 2008
Mesajlar
578
Excel Vers. ve Dili
Excel Vers. ve Dili Ofis 2021 TR 32 Bit
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
 
Üst