Skip to main content

AccessTr.neT


Listbox İle İlgili Sayfaya Gitmek

Listbox İle İlgili Sayfaya Gitmek

#13
(13/06/2019, 13:33)nightashes yazdı: 4- Son olarak bu listelerde mouse scroll kullanılmıyor. Yani aşağı indirmek için listeyi yan çubuğu kullanmak zorunda kalıyorum. Acaba scroll ile aşağı yukarı listeyi nasıl hareket ettirebilirim.
nihayet çalışan bir kod buldum ))))
öncelikle bir modül ekleyin aşağıdaki kodu module yapıştırın
Option Explicit
'Fare tekerinin listbox'ta çalışması için
#If Win64 Then
   Private Type POINTAPI
      XY As LongLong
   End Type
#Else
   Private Type POINTAPI
          X As Long
          Y As Long
   End Type
#End If


Private Type MOUSEHOOKSTRUCT
   Pt As POINTAPI
   hWnd As Long
   wHitTestCode As Long
   dwExtraInfo As Long
End Type

#If VBA7 Then
   Private Declare PtrSafe Function FindWindow Lib "user32" _
                                           Alias "FindWindowA" ( _
                                                           ByVal lpClassName As String, _
                                                           ByVal lpWindowName As String) As Long ' not sure if this should be LongPtr
   #If Win64 Then
       Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
                                           Alias "GetWindowLongPtrA" ( _
                                                           ByVal hWnd As LongPtr, _
                                                           ByVal nIndex As Long) As LongPtr
   #Else
       Private Declare PtrSafe Function GetWindowLong Lib "user32" _
                                           Alias "GetWindowLongA" ( _
                                                           ByVal hWnd As LongPtr, _
                                                           ByVal nIndex As Long) As LongPtr
   #End If
   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 LongPtr ' MAYBE Long
     #If Win64 Then
       Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                           ByVal Point As LongLong) As LongPtr    '
   #Else
       Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                           ByVal xPoint As Long, _
                                                           ByVal yPoint As Long) As LongPtr    '
   #End If
   Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                                           ByRef lpPoint As POINTAPI) As LongPtr   'MAYBE 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 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 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)
Dim n As Long
Private mCtl As Object
Private mbHook As Boolean
#If VBA7 Then
   Private mLngMouseHook As LongPtr
   Private mListBoxHwnd As LongPtr
#Else
   Private mLngMouseHook As Long
   Private mListBoxHwnd As Long
#End If
   
Sub HookListBoxScroll(frm As Object, ctl As Object)
   Dim tPT As POINTAPI
   #If VBA7 Then
       Dim lngAppInst As LongPtr
       Dim hwndUnderCursor As LongPtr
   #Else
       Dim lngAppInst As Long
       Dim hwndUnderCursor As Long
   #End If
   GetCursorPos tPT
   #If Win64 Then
       hwndUnderCursor = WindowFromPoint(tPT.XY)
   #Else
       hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
   #End If
   If TypeOf ctl Is UserForm Then
       If Not frm Is ctl Then
              ctl.SetFocus
       End If
   Else
       If Not frm.ActiveControl Is ctl Then
            ctl.SetFocus
       End If
   End If
   If mListBoxHwnd <> hwndUnderCursor Then
       UnhookListBoxScroll
       Set mCtl = ctl
       mListBoxHwnd = hwndUnderCursor
       #If Win64 Then
           lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
       #Else
           lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
       #End If

       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
       Set mCtl = Nothing
       UnhookWindowsHookEx mLngMouseHook
       mLngMouseHook = 0
       mListBoxHwnd = 0
       mbHook = False
   End If
End Sub
#If VBA7 Then
   Private Function MouseProc( _
                           ByVal nCode As Long, ByVal wParam As Long, _
                           ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
       Dim idx As Long
       On Error GoTo errH
       If (nCode = HC_ACTION) Then
           #If Win64 Then
               If WindowFromPoint(lParam.Pt.XY) = mListBoxHwnd Then
                   If wParam = WM_MOUSEWHEEL Then
                       MouseProc = True
                       If TypeOf mCtl Is Frame Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       ElseIf TypeOf mCtl Is UserForm Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                       End If
                   Exit Function
                   End If
               Else
                   UnhookListBoxScroll
               End If
           #Else
               If WindowFromPoint(lParam.Pt.X, lParam.Pt.Y) = mListBoxHwnd Then
                   If wParam = WM_MOUSEWHEEL Then
                       MouseProc = True
                       If TypeOf mCtl Is Frame Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       ElseIf TypeOf mCtl Is UserForm Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                       End If
                       Exit Function
                   End If
               Else
                   UnhookListBoxScroll
               End If
           #End If
       End If
       MouseProc = CallNextHookEx( _
                               mLngMouseHook, nCode, wParam, ByVal lParam)
       Exit Function
errH:
       UnhookListBoxScroll
   End Function
#Else
   Private Function MouseProc( _
                           ByVal nCode As Long, ByVal wParam As Long, _
                           ByRef lParam As MOUSEHOOKSTRUCT) As Long
       Dim idx As Long
       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

                   If TypeOf mCtl Is Frame Then
                       If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                       idx = idx + mCtl.ScrollTop
                       If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                           mCtl.ScrollTop = idx
                       End If
                   ElseIf TypeOf mCtl Is UserForm Then
                       If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                       idx = idx + mCtl.ScrollTop
                       If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                           mCtl.ScrollTop = idx
                       End If
                   Else
                        If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                        idx = idx + mCtl.ListIndex
                        If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                   End If
                   Exit Function
               End If
           Else
               UnhookListBoxScroll
           End If
       End If
       MouseProc = CallNextHookEx( _
       mLngMouseHook, nCode, wParam, ByVal lParam)
       Exit Function
errH:
       UnhookListBoxScroll
   End Function
#End If

aşağıdaki kodlar da forma eklenecek
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.ListBox1
End Sub

Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.ListBox2
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub
.rar Listboxa ekleme İlgili Sayfaya Gitmek ve hücrelerdeAramaBulma_FareTekeri_hy3.rar (Dosya Boyutu: 52,33 KB | İndirme Sayısı: 10)
Cevapla
Star #14
(19/06/2019, 13:03)halily yazdı:
(13/06/2019, 13:33)nightashes yazdı: 4- Son olarak bu listelerde mouse scroll kullanılmıyor. Yani aşağı indirmek için listeyi yan çubuğu kullanmak zorunda kalıyorum. Acaba scroll ile aşağı yukarı listeyi nasıl hareket ettirebilirim.
nihayet çalışan bir kod buldum ))))
öncelikle bir modül ekleyin aşağıdaki kodu module yapıştırın
Option Explicit
'Fare tekerinin listbox'ta çalışması için
#If Win64 Then
   Private Type POINTAPI
      XY As LongLong
   End Type
#Else
   Private Type POINTAPI
          X As Long
          Y As Long
   End Type
#End If


Private Type MOUSEHOOKSTRUCT
   Pt As POINTAPI
   hWnd As Long
   wHitTestCode As Long
   dwExtraInfo As Long
End Type

#If VBA7 Then
   Private Declare PtrSafe Function FindWindow Lib "user32" _
                                           Alias "FindWindowA" ( _
                                                           ByVal lpClassName As String, _
                                                           ByVal lpWindowName As String) As Long ' not sure if this should be LongPtr
   #If Win64 Then
       Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
                                           Alias "GetWindowLongPtrA" ( _
                                                           ByVal hWnd As LongPtr, _
                                                           ByVal nIndex As Long) As LongPtr
   #Else
       Private Declare PtrSafe Function GetWindowLong Lib "user32" _
                                           Alias "GetWindowLongA" ( _
                                                           ByVal hWnd As LongPtr, _
                                                           ByVal nIndex As Long) As LongPtr
   #End If
   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 LongPtr ' MAYBE Long
     #If Win64 Then
       Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                           ByVal Point As LongLong) As LongPtr    '
   #Else
       Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                           ByVal xPoint As Long, _
                                                           ByVal yPoint As Long) As LongPtr    '
   #End If
   Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                                           ByRef lpPoint As POINTAPI) As LongPtr   'MAYBE 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 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 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)
Dim n As Long
Private mCtl As Object
Private mbHook As Boolean
#If VBA7 Then
   Private mLngMouseHook As LongPtr
   Private mListBoxHwnd As LongPtr
#Else
   Private mLngMouseHook As Long
   Private mListBoxHwnd As Long
#End If
   
Sub HookListBoxScroll(frm As Object, ctl As Object)
   Dim tPT As POINTAPI
   #If VBA7 Then
       Dim lngAppInst As LongPtr
       Dim hwndUnderCursor As LongPtr
   #Else
       Dim lngAppInst As Long
       Dim hwndUnderCursor As Long
   #End If
   GetCursorPos tPT
   #If Win64 Then
       hwndUnderCursor = WindowFromPoint(tPT.XY)
   #Else
       hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
   #End If
   If TypeOf ctl Is UserForm Then
       If Not frm Is ctl Then
              ctl.SetFocus
       End If
   Else
       If Not frm.ActiveControl Is ctl Then
            ctl.SetFocus
       End If
   End If
   If mListBoxHwnd <> hwndUnderCursor Then
       UnhookListBoxScroll
       Set mCtl = ctl
       mListBoxHwnd = hwndUnderCursor
       #If Win64 Then
           lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
       #Else
           lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
       #End If

       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
       Set mCtl = Nothing
       UnhookWindowsHookEx mLngMouseHook
       mLngMouseHook = 0
       mListBoxHwnd = 0
       mbHook = False
   End If
End Sub
#If VBA7 Then
   Private Function MouseProc( _
                           ByVal nCode As Long, ByVal wParam As Long, _
                           ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
       Dim idx As Long
       On Error GoTo errH
       If (nCode = HC_ACTION) Then
           #If Win64 Then
               If WindowFromPoint(lParam.Pt.XY) = mListBoxHwnd Then
                   If wParam = WM_MOUSEWHEEL Then
                       MouseProc = True
                       If TypeOf mCtl Is Frame Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       ElseIf TypeOf mCtl Is UserForm Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                       End If
                   Exit Function
                   End If
               Else
                   UnhookListBoxScroll
               End If
           #Else
               If WindowFromPoint(lParam.Pt.X, lParam.Pt.Y) = mListBoxHwnd Then
                   If wParam = WM_MOUSEWHEEL Then
                       MouseProc = True
                       If TypeOf mCtl Is Frame Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       ElseIf TypeOf mCtl Is UserForm Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                       End If
                       Exit Function
                   End If
               Else
                   UnhookListBoxScroll
               End If
           #End If
       End If
       MouseProc = CallNextHookEx( _
                               mLngMouseHook, nCode, wParam, ByVal lParam)
       Exit Function
errH:
       UnhookListBoxScroll
   End Function
#Else
   Private Function MouseProc( _
                           ByVal nCode As Long, ByVal wParam As Long, _
                           ByRef lParam As MOUSEHOOKSTRUCT) As Long
       Dim idx As Long
       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

                   If TypeOf mCtl Is Frame Then
                       If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                       idx = idx + mCtl.ScrollTop
                       If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                           mCtl.ScrollTop = idx
                       End If
                   ElseIf TypeOf mCtl Is UserForm Then
                       If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                       idx = idx + mCtl.ScrollTop
                       If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                           mCtl.ScrollTop = idx
                       End If
                   Else
                        If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                        idx = idx + mCtl.ListIndex
                        If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                   End If
                   Exit Function
               End If
           Else
               UnhookListBoxScroll
           End If
       End If
       MouseProc = CallNextHookEx( _
       mLngMouseHook, nCode, wParam, ByVal lParam)
       Exit Function
errH:
       UnhookListBoxScroll
   End Function
#End If

aşağıdaki kodlar da forma eklenecek
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.ListBox1
End Sub

Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.ListBox2
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub

Vallahi süpersiniz...
Diyecek laf yok. Harika bir şekilde işe yaramakta
(19/06/2019, 13:03)halily yazdı:
(13/06/2019, 13:33)nightashes yazdı: 4- Son olarak bu listelerde mouse scroll kullanılmıyor. Yani aşağı indirmek için listeyi yan çubuğu kullanmak zorunda kalıyorum. Acaba scroll ile aşağı yukarı listeyi nasıl hareket ettirebilirim.
nihayet çalışan bir kod buldum ))))
öncelikle bir modül ekleyin aşağıdaki kodu module yapıştırın
Option Explicit
'Fare tekerinin listbox'ta çalışması için
#If Win64 Then
   Private Type POINTAPI
      XY As LongLong
   End Type
#Else
   Private Type POINTAPI
          X As Long
          Y As Long
   End Type
#End If


Private Type MOUSEHOOKSTRUCT
   Pt As POINTAPI
   hWnd As Long
   wHitTestCode As Long
   dwExtraInfo As Long
End Type

#If VBA7 Then
   Private Declare PtrSafe Function FindWindow Lib "user32" _
                                           Alias "FindWindowA" ( _
                                                           ByVal lpClassName As String, _
                                                           ByVal lpWindowName As String) As Long ' not sure if this should be LongPtr
   #If Win64 Then
       Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
                                           Alias "GetWindowLongPtrA" ( _
                                                           ByVal hWnd As LongPtr, _
                                                           ByVal nIndex As Long) As LongPtr
   #Else
       Private Declare PtrSafe Function GetWindowLong Lib "user32" _
                                           Alias "GetWindowLongA" ( _
                                                           ByVal hWnd As LongPtr, _
                                                           ByVal nIndex As Long) As LongPtr
   #End If
   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 LongPtr ' MAYBE Long
     #If Win64 Then
       Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                           ByVal Point As LongLong) As LongPtr    '
   #Else
       Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                           ByVal xPoint As Long, _
                                                           ByVal yPoint As Long) As LongPtr    '
   #End If
   Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                                           ByRef lpPoint As POINTAPI) As LongPtr   'MAYBE 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 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 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)
Dim n As Long
Private mCtl As Object
Private mbHook As Boolean
#If VBA7 Then
   Private mLngMouseHook As LongPtr
   Private mListBoxHwnd As LongPtr
#Else
   Private mLngMouseHook As Long
   Private mListBoxHwnd As Long
#End If
   
Sub HookListBoxScroll(frm As Object, ctl As Object)
   Dim tPT As POINTAPI
   #If VBA7 Then
       Dim lngAppInst As LongPtr
       Dim hwndUnderCursor As LongPtr
   #Else
       Dim lngAppInst As Long
       Dim hwndUnderCursor As Long
   #End If
   GetCursorPos tPT
   #If Win64 Then
       hwndUnderCursor = WindowFromPoint(tPT.XY)
   #Else
       hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
   #End If
   If TypeOf ctl Is UserForm Then
       If Not frm Is ctl Then
              ctl.SetFocus
       End If
   Else
       If Not frm.ActiveControl Is ctl Then
            ctl.SetFocus
       End If
   End If
   If mListBoxHwnd <> hwndUnderCursor Then
       UnhookListBoxScroll
       Set mCtl = ctl
       mListBoxHwnd = hwndUnderCursor
       #If Win64 Then
           lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
       #Else
           lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
       #End If

       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
       Set mCtl = Nothing
       UnhookWindowsHookEx mLngMouseHook
       mLngMouseHook = 0
       mListBoxHwnd = 0
       mbHook = False
   End If
End Sub
#If VBA7 Then
   Private Function MouseProc( _
                           ByVal nCode As Long, ByVal wParam As Long, _
                           ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
       Dim idx As Long
       On Error GoTo errH
       If (nCode = HC_ACTION) Then
           #If Win64 Then
               If WindowFromPoint(lParam.Pt.XY) = mListBoxHwnd Then
                   If wParam = WM_MOUSEWHEEL Then
                       MouseProc = True
                       If TypeOf mCtl Is Frame Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       ElseIf TypeOf mCtl Is UserForm Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                       End If
                   Exit Function
                   End If
               Else
                   UnhookListBoxScroll
               End If
           #Else
               If WindowFromPoint(lParam.Pt.X, lParam.Pt.Y) = mListBoxHwnd Then
                   If wParam = WM_MOUSEWHEEL Then
                       MouseProc = True
                       If TypeOf mCtl Is Frame Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       ElseIf TypeOf mCtl Is UserForm Then
                           If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                           idx = idx + mCtl.ScrollTop
                           If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                               mCtl.ScrollTop = idx
                           End If
                       Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                       End If
                       Exit Function
                   End If
               Else
                   UnhookListBoxScroll
               End If
           #End If
       End If
       MouseProc = CallNextHookEx( _
                               mLngMouseHook, nCode, wParam, ByVal lParam)
       Exit Function
errH:
       UnhookListBoxScroll
   End Function
#Else
   Private Function MouseProc( _
                           ByVal nCode As Long, ByVal wParam As Long, _
                           ByRef lParam As MOUSEHOOKSTRUCT) As Long
       Dim idx As Long
       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

                   If TypeOf mCtl Is Frame Then
                       If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                       idx = idx + mCtl.ScrollTop
                       If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                           mCtl.ScrollTop = idx
                       End If
                   ElseIf TypeOf mCtl Is UserForm Then
                       If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                       idx = idx + mCtl.ScrollTop
                       If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                           mCtl.ScrollTop = idx
                       End If
                   Else
                        If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                        idx = idx + mCtl.ListIndex
                        If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                   End If
                   Exit Function
               End If
           Else
               UnhookListBoxScroll
           End If
       End If
       MouseProc = CallNextHookEx( _
       mLngMouseHook, nCode, wParam, ByVal lParam)
       Exit Function
errH:
       UnhookListBoxScroll
   End Function
#End If

aşağıdaki kodlar da forma eklenecek
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.ListBox1
End Sub

Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.ListBox2
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub

Vallahi süpersiniz...
Diyecek laf yok. Harika bir şekilde işe yaramakta
Alıntı:Her şey bir fikirle başlar.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da