• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Userform Listbox Mouse Tekerleği

A

ahmetxaksoy

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.
 
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
 
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 Orion1 hocam ; biraz fanteziye kaçıyor bu işler . Gerçi excel bu , sınırı yok mübareğin :) :tongue::tongue::tongue:
 
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.:cool:
Genişletmek için tıkla ...

Sayın Orion Bey Textbox içine tıkladıktan sonra fare tekerleğini kullanmak için kod varmı nasıl yaparız
 
Textbox nesnesi windows handle' a sahip olmadığından yukarıdaki kodlar çalışmayacaktır.

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

.
Genişletmek için tıkla ...

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.
 
Zeki Gürsoy' Alıntı:
Textbox nesnesi windows handle' a sahip olmadığından yukarıdaki kodlar çalışmayacaktır.

.
Genişletmek için tıkla ...
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' 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 :)
Genişletmek için tıkla ...
Sayın Ulutanas nerede çalıştırdınız. Textbox da mı yoksa Listbox da mı
 
asdsxx' Alıntı:
Sayın Ulutanas nerede çalıştırdınız. Textbox da mı yoksa Listbox da mı
Genişletmek için tıkla ...

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' Alıntı:
ListBox+Combobox için (32 Bit Excel)

.
Genişletmek için tıkla ...

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
 
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/F...n-userform-listbox-in-excel-2010?forum=isvvba
Genişletmek için tıkla ...

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' Alıntı:
Çok teşekkürler,
Ben de çalıştırdım sonunda, harika oldu
Genişletmek için tıkla ...

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.
 
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.
Genişletmek için tıkla ...
Hocam kusura bakmayın, yeni gördüm...

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

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

.
Genişletmek için tıkla ...

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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst