- Katılım
- 22 Ekim 2017
- Mesajlar
- 4,779
- Excel Vers. ve Dili
- Microsoft 365 Tr-64
Merhaba,
Aşağıdaki kodları excelforum.com sitesinden buldum.
Listbox nesnesini mouse ile kontrol edebiliyorum.
Sıkıntım, mouse Userformun neresinde olursa olsun listbox kaydırıyor.
Sadece listbox üzerindeyken çalışssın diyebilir miyiz?
Userform initialize olayında da şu kodu çalıştırıyorum.
Aşağıdaki kodları excelforum.com sitesinden buldum.
Listbox nesnesini mouse ile kontrol edebiliyorum.
Sıkıntım, mouse Userformun neresinde olursa olsun listbox kaydırıyor.
Sadece listbox üzerindeyken çalışssın diyebilir miyiz?
C++:
'Will compile in 32 & 64 bit.
Option Explicit
#If Win64 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
#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 GetForegroundWindow Lib "user32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length 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
#End If
Private Type POINTAPI
J As Long
Y As Long
End Type
#If Win64 Then
Private Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As LongPtr
End Type
#Else
Private Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
#End If
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private Const GWL_HINSTANCE = (-6)
Public Const nMyControlTypeNONE = 0
Public Const nMyControlTypeUSERFORM = 1
Public Const nMyControlTypeFRAME = 2
Public Const nMyControlTypeCOMBOBOX = 3
Public Const nMyControlTypeLISTBOX = 4
Private hhkLowLevelMouse As LongPtr
Private udtlParamStuct As MSLLHOOKSTRUCT
Public myGblUserForm As UserForm
Public myGblControlObject As Object
Public iGblControlType As Integer
Public myGblUserFormControl As Object
#If Win64 Then
Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
#Else
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
#End If
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
#If Win64 Then
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Dim iDirection As Long
On Error Resume Next
If GetForegroundWindow <> FindWindow("ThunderDFrame", myGblUserForm.Caption) Then
UnHook_Mouse
Exit Function
End If
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
iDirection = GetHookStruct(lParam).mouseData
Call ProcessMouseWheelMovement(iDirection)
LowLevelMouseProc = True
End If
Exit Function
End If
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
Sub Hook_Mouse()
If hhkLowLevelMouse < 1 Then
hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, _
GetWindowLong(FindWindow("ThunderDFrame", myGblUserForm.Caption), GWL_HINSTANCE), 0)
End If
End Sub
Sub UnHook_Mouse()
If hhkLowLevelMouse <> 0 Then
UnhookWindowsHookEx hhkLowLevelMouse
hhkLowLevelMouse = 0
End If
End Sub
#If Win64 Then
Public Sub ProcessMouseWheelMovement(ByVal iDirection As LongPtr)
#Else
Public Sub ProcessMouseWheelMovement(ByVal iDirection As Long)
#End If
Dim i As Long, X As Long
Dim iMultiplier As Long
Select Case iGblControlType
Case nMyControlTypeUSERFORM
iMultiplier = 3
If iDirection > 0 Then
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
Next i
Else
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
Next i
End If
Case nMyControlTypeFRAME
iMultiplier = 5
If iDirection > 0 Then
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
Next i
Else
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
Next i
End If
Case nMyControlTypeCOMBOBOX
With myGblControlObject
If iDirection > 0 Then
.TopIndex = .TopIndex - 1
Else
.TopIndex = .TopIndex + 1
End If
End With
Case nMyControlTypeLISTBOX
With myGblControlObject
If iDirection > 0 Then
X = .TopIndex - 5
.TopIndex = IIf(X < 0, 0, X) '2020-02-14 added as wasn't scrolling to top after filtering list (think cause the top index was negative)
Else
.TopIndex = .TopIndex + 10
End If
End With
End Select
End Sub
C++:
iGblControlType = nMyControlTypeLISTBOX
Set myGblUserForm = Me
Set myGblControlObject = Me.ListBox1
Hook_Mouse