AccessTr.neT
Listbox da mouse tekerleği ile ilgili - Baskı Önizleme

+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Listbox da mouse tekerleği ile ilgili (/konu-listbox-da-mouse-tekerlegi-ile-ilgili.html)



Listbox da mouse tekerleği ile ilgili - drummers - 14/01/2011

Ekli dosyamda Listbox1 de mouse tekerleği kullanmak istemekteyim. Konu başlıklarında arama yaptım fakat çeşitli uyarılar ile karşılaştım.

İlgileneceklere şimdiden teşekürler.

Kullanıcı adı: Admin
Şifre : 1


Cvp: Listbox da mouse tekerleği ile ilgili - life_exciting - 14/01/2011

Linkteki Örneği İnceleyebilirsiniz.İşinize Yarayacağını Düşünüyorum.

https://accesstr.net/konu-mouse-fare-islevinin-butonla-aktif-ve-pasif-uygulamasi.html?highlight=mouse


Cvp: Listbox da mouse tekerleği ile ilgili - drummers - 14/01/2011

(14/01/2011, 22:25)lifeexciting yazdı: Linkteki Örneği İnceleyebilirsiniz.İşinize Yarayacağını Düşünüyorum.

https://accesstr.net/konu-mouse-fare-islevinin-butonla-aktif-ve-pasif-uygulamasi.html?highlight=mouse

Kendi çalışmama uyarlıyamadım.Img-cray


Cvp: Listbox da mouse tekerleği ile ilgili - drummers - 17/01/2011

Konu hakkında mümkünse fikir verebilirmisiniz ? Beceremedim de.Img-grin


Cvp: Listbox da mouse tekerleği ile ilgili - ogulcan92 - 24/05/2011

Kodlarınızı aşağıdaki şekilde düzenleyiniz.
Module Yazılacak Kod
Private Declare Function CallWindowProc Lib "user32.dll" Alias _
"CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long


Private Declare Function SetWindowLong Lib "user32.dll" Alias _
"SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function FindWindowA Lib "user32" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function GetWindowRect Lib "user32" ( _
ByVal hWnd As Long, lpRect As typeRect) As Long
Private Type typeRect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private dXFactor As Double
Private dYFactor As Double
Private lCaptionHeight As Long

Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private Const SM_MOUSEWHEELPRESENT = 75

Private lLines As Long
Private hForm As Long
Public lPrevWndProc As Long
Private lX As Long
Private lY As Long
Private bUp As Boolean
Private frmContainer As msForms.UserForm


Private Function WindowProc( _
ByVal lWnd As Long, _
ByVal lMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long


If lMsg = WM_MOUSEWHEEL Then
lX = lParam And 65535
lY = lParam \ 65535
bUp = (wParam > 0)
WheelHandler bUp
End If

If lMsg <> WM_MOUSEWHEEL Then
WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam, lParam)
End If
End Function

Public Sub HookWheel(ByVal frmName As msForms.UserForm, dWidth As Double, _
dHeight As Double, ByVal lLinesToScroll As Long)
If WheelPresent Then
Set frmContainer = frmName
hForm = GetFormHandle(frmName)
GetScreenFactors hForm, dWidth, dHeight
lLines = lLinesToScroll
lPrevWndProc = SetWindowLong(hForm, GWL_WNDPROC, AddressOf WindowProc)

End If

End Sub

Public Sub UnHookWheel()
Call SetWindowLong(hForm, GWL_WNDPROC, lPrevWndProc)
End Sub

Private Function GetFormHandle(ByVal frmName As msForms.UserForm, _
Optional bByClass As Boolean = True) As Long
Dim strClassName As String
Dim strCaption As String

strClassName = IIf(Val(Application.Version) > 8, "ThunderDFrame", _
"ThunderXFrame") & vbNullChar
strCaption = vbNullString
GetFormHandle = FindWindowA(strClassName, strCaption)

End Function

Public Sub GetScreenFactors(lHwnd As Long, _
dWidth As Double, _
dHeight As Double)
Dim uRect As typeRect
GetWindowRect lHwnd, uRect
dXFactor = dWidth / (uRect.Right - uRect.Left)
dYFactor = dHeight / (uRect.Bottom - uRect.Top)
lCaptionHeight = dHeight - frmContainer.InsideHeight
End Sub

Private Function WheelPresent() As Boolean
If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then
WheelPresent = True
ElseIf FindWindowA("MouseZ", "Magellan MSWHEEL") <> 0 Then
WheelPresent = True
End If
End Function

Public Sub WheelHandler(bUp As Boolean)

Dim ctlFocus As msForms.Control
Dim ctlName As msForms.Control
Dim lTopIndex As Long
Dim bMultiPage As Boolean
Dim lPage As Long
Dim lMove As Long

If Not IsOverForm Then Exit Sub
Set ctlFocus = frmContainer.ActiveControl

If TypeOf ctlFocus Is msForms.MultiPage Then
bMultiPage = True

lPage = ctlFocus.Value

Set ctlFocus = ctlFocus.SelectedItem.ActiveControl

End If

lX = lX * dXFactor
lY = lY * dYFactor
lY = lY - lCaptionHeight

If Not (TypeOf ctlFocus Is msForms.CommandButton Or _
TypeOf ctlFocus Is msForms.TextBox) Then

End If

For Each ctlName In frmContainer.Controls
With ctlName

If TypeOf ctlName Is msForms.ListBox Then

If bMultiPage = True Then

If lPage <> .Parent.Index Then GoTo SkipControl
End If
If lX > .Left Then
If lX < .Left + .Width Then
If lY > .Top Then
If lY < .Top + .Height Then

If .ListCount = 0 Then Exit Sub

lMove = IIf(bUp, -lLines, lLines)
lTopIndex = .TopIndex + lMove

If lTopIndex < 0 Then
lTopIndex = 0
ElseIf lTopIndex > .ListCount - (.Height / 10) + 2 Then
lTopIndex = .TopIndex
End If

.TopIndex = lTopIndex

Exit Sub

End If
End If
End If
End If
End If
End With

SkipControl:
Next ctlName

End Sub

Public Function IsOverForm() As Boolean
Dim uRect As typeRect
GetWindowRect hForm, uRect
With uRect
If lX >= .Left Then
If lX <= .Right Then
If lY >= .Top Then
If lY <= .Bottom Then
IsOverForm = True
lX = lX - .Left
lY = lY - .Top
End If
End If
End If
End If
End With
End Function
Userformun İnitalizesine Yazılacak Kod
HookWheel Me, Me.Width, Me.Height, 1
Userformun Terminatesine Yazılacak Kod
UnHookWheel