Userform Listbox Mouse Tekerleği

Katılım
5 Ağustos 2015
Mesajlar
15
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
21,872
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:
 

Zeki Gürsoy

Uzman
Uzman
Katılım
31 Aralık 2005
Mesajlar
3,885
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.

.
 

ulutanas

Altın Üye
Katılım
8 Kasım 2008
Mesajlar
501
Excel Vers. ve Dili
excel 2007 turkçe
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:

ulutanas

Altın Üye
Katılım
8 Kasım 2008
Mesajlar
501
Excel Vers. ve Dili
excel 2007 turkçe
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
69
Excel Vers. ve Dili
Excel 2019 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
 
Üst