title image


Smiley Re: Auf Mausrad reagieren
Hi!



Die Frage habe ich auch schon einmal gestellt, leider kann man dir den Code nicht per Mail schicken. Ich versuche mal den Code zu posten:

1. Datei: MWheel.ctl

VERSION 5.00

Begin VB.UserControl MWheel

ClientHeight = 495

ClientLeft = 0

ClientTop = 0

ClientWidth = 495

InvisibleAtRuntime= -1 'True

ScaleHeight = 495

ScaleWidth = 495

ToolboxBitmap = "MWheel.ctx":0000

Begin VB.PictureBox Picture1

Appearance = 0 '2D

BackColor = &H80000005&

ForeColor = &H80000008&

Height = 495

Left = 0

Picture = "MWheel.ctx":0312

ScaleHeight = 465

ScaleWidth = 465

TabIndex = 0

Top = 0

Width = 495

End

End

Attribute VB_Name = "MWheel"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = True

Attribute VB_PredeclaredId = False

Attribute VB_Exposed = False

Option Explicit



Dim m_CapWnd As Long

Dim m_Subclassed As Boolean



Event WheelScroll(Shift As Integer, zDelta As Integer, _

X As Single, Y As Single)





Private Sub UserControl_Resize()

Size 32 * Screen.TwipsPerPixelX, 32 * Screen.TwipsPerPixelY

End Sub



Public Sub DisableWheel()

If m_CapWnd = 0 Then Exit Sub

If m_Subclassed = False Then Exit Sub



UnSubclass Me, m_CapWnd

m_Subclassed = False

End Sub



Public Sub EnableWheel()

If m_CapWnd = 0 Then Exit Sub

m_Subclassed = True

Subclass Me, m_CapWnd

End Sub



Friend Property Get hWnd() As Long

hWnd = UserControl.hWnd

End Property



Public Property Get hWndCapture() As Long

hWndCapture = m_CapWnd

End Property

Public Property Let hWndCapture(ByVal vNewValue As Long)

m_CapWnd = vNewValue

End Property



Friend Sub WndProc(ByVal hWnd As Long, _

ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)

Dim wShift As Integer

Dim wzDelta As Integer

Dim wX As Single, wY As Single



wShift = LOWORD(wParam)

wzDelta = HIWORD(wParam)

wX = LOWORD(lParam)

wY = HIWORD(lParam)



RaiseEvent WheelScroll(wShift, wzDelta, wX, wY)

End Sub



2. Datei: modWheel.bas

Attribute VB_Name = "modWheel"

Option Explicit



Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _

(pDest As Any, pSource As Any, ByVal ByteLen As Long)



Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _

(ByVal hWnd As Long, ByVal nIndex As Long) As Long

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _

(ByVal hWnd As Long, ByVal nIndex As Long, _

ByVal dwNewLong As Long) As Long

Public Const GWL_WNDPROC = (-4)

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _

(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, _

ByVal Msg As Long, ByVal wParam As Long, _

ByVal lParam As Long) As Long

Declare Function SetProp Lib "user32" Alias "SetPropA" _

(ByVal hWnd As Long, ByVal lpString As String, _

ByVal hData As Long) As Long

Declare Function GetProp Lib "user32" Alias "GetPropA" _

(ByVal hWnd As Long, ByVal lpString As String) As Long

Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _

(ByVal hWnd As Long, ByVal lpString As String) As Long

Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long



Public Const WM_MOUSEWHEEL = &H20A

Public Const WM_MOUSELAST = &H20A

Public Const WHEEL_DELTA = 120 '/* Value for rolling one detent */





Public Function HIWORD(LongIn As Long) As Integer

'

' Mask off low word then do integer divide to

' shift right by 16.

'

HIWORD = (LongIn And &HFFFF0000) \ &H10000

End Function



Public Function LOWORD(LongIn As Long) As Integer

'

' Low word retrieved by masking off high word.

' If low word is too large, twiddle sign bit.

'

If (LongIn And &HFFFF&) > &H7FFF Then

LOWORD = (LongIn And &HFFFF&) - &H10000

Else

LOWORD = LongIn And &HFFFF&

End If

End Function



Public Function MWheelProc(ByVal hWnd As Long, _

ByVal wMsg As Long, ByVal wParam As Long, _

ByVal lParam As Long) As Long



Dim OldProc As Long

Dim CtlWnd As Long

Dim CtlPtr As Long

Dim IntObj As Object 'Intermediate object in between

Dim MWObject As MWheel 'pointer and mousewheel control



CtlWnd = GetProp(hWnd, "WheelWnd")

CtlPtr = GetProp(CtlWnd, "WheelPtr")

OldProc = GetProp(CtlWnd, "OldWheelProc")



If wMsg = WM_MOUSEWHEEL Then

CopyMemory IntObj, CtlPtr, 4

Set MWObject = IntObj

MWObject.WndProc hWnd, wMsg, wParam, lParam

Set MWObject = Nothing

CopyMemory IntObj, 0&, 4

Exit Function

End If



MWheelProc = CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)

End Function



Public Sub Subclass(MWCtl As MWheel, ParentWnd As Long)

If GetProp(MWCtl.hWnd, "OldWheelProc") 0 Then

Exit Sub

End If



'Save the old window proc of the control's parent

SetProp MWCtl.hWnd, "OldWheelProc", _

GetWindowLong(ParentWnd, GWL_WNDPROC)

'Object pointer to the control

SetProp MWCtl.hWnd, "WheelPtr", ObjPtr(MWCtl)

'Save control's hWnd in its parent data

SetProp ParentWnd, "WheelWnd", MWCtl.hWnd



'Subclass the control's parent

SetWindowLong ParentWnd, GWL_WNDPROC, AddressOf MWheelProc

End Sub



Public Sub UnSubclass(MWCtl As MWheel, ParentWnd As Long)

Dim OldProc As Long



OldProc = GetProp(MWCtl.hWnd, "OldWheelProc")

If OldProc = 0 Then Exit Sub

'Unsubclass control's parent

SetWindowLong ParentWnd, GWL_WNDPROC, OldProc

'Clean up properties

RemoveProp ParentWnd, "WheelWnd"

RemoveProp MWCtl.hWnd, "WheelPtr"

RemoveProp MWCtl.hWnd, "OldWheelProc"

End Sub



Diese beiden Dateien legst du mit Notepad oder einem anderen Texteditor an. Dannach fügst du sie in dein Projekt ein und erstellst ein MWheel-Object (MWheel1). Beim Start deines Proggies kommt dann der volgende Code zum Einsatz:Private Sub Form_Load()

MWheel1.hWndCapture = Me.hWnd

MWheel1.EnableWheel

End Sub

Zum Schluss kommt noch das Mausrad-Ereignis zum Einsatz:Private Sub MWheel1_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)

If zDelta > 0 Then

MsgBox "Mausrad hoch!"

ElseIf zDelta < 0 Then

MsgBox "Mausrad runter!"

End If

End Sub





So, falls jemand einen anderen Code kennt bitte einfach mal posten.



MfG

Mr. S ICQ #67858520http://www.developersmanual.com/



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: