Startseite / Tipps / VB 5/6-Tipp 0560: Mausrad Subclassen

VB 5/6-Tipp 0560: Mausrad Subclassen

 von Christof Rueß

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
' Die Komponente 'Microsoft Windows Common Controls 6.0 (SP6) (MsComCtl.ocx)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Fortschrittsanzeige "ProgressBar1"
' Steuerelement: Beschriftungsfeld "Label1"
Private Sub Form_Load()
Init Me
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Ende
End Sub

Private Sub Form_Unload(Cancel As Integer)
Ende
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Public 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

Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long

Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
    ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long

Public Declare Function UnhookWindowsHookEx Lib "user32" _
    (ByVal hHook As Long) As Long

Public 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

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) _
    As Long


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 Const WM_MOUSEWHEEL = &H20A
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONDBLCLK = &H209
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202

Private Const MK_LBUTTON = &H1
Private Const MK_MBUTTON = &H10
Private Const MK_RBUTTON = &H2

Public Const WH_MOUSE = 7
Private Const WHEEL_DELTA = 120

Public Const GWL_WNDPROC = -4

Dim hook As Long
Dim nKeys As Long, Delta As Long, XPos As Long, YPos As Long
Dim OriginalWindowProc As Long

Public Enum mButtons
  LBUTTON = &H1
  MBUTTON = &H10
  RBUTTON = &H2
End Enum

Public Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, _
                          lParam As MOUSEHOOKSTRUCT) As Long
    Select Case nCode
      Case Is < 0
        MouseProc = CallNextHookEx(hook, nCode, wParam, lParam)
      Case 0
        If lParam.hWnd = Form1.hWnd Then
          Select Case wParam
            Case WM_MBUTTONDOWN
              MouseWheelDown lParam.pt.X, lParam.pt.Y
              Debug.Print "Button down:" & lParam.pt.X & "," & lParam.pt.Y
            Case WM_MBUTTONUP
              MouseWheelUp lParam.pt.X, lParam.pt.Y
              Debug.Print "Button up:" & lParam.pt.X & "," & lParam.pt.Y
          End Select
        End If
    End Select
End Function

Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, _
                           ByVal wParam As Long, ByVal lParam As Long) _
                           As Long
    Select Case uMsg
      Case WM_MOUSEWHEEL
        nKeys = wParam And 65535
        Delta = wParam / 65536 / WHEEL_DELTA
        XPos = lParam And 65535
        YPos = lParam / 65536

        MouseWheelRotation Delta, nKeys, XPos, YPos, hWnd
        Debug.Print "Mousewheel at (" & XPos & "," & YPos & ") Delta:" & _
                    Delta & "  Keys:" & nKeys
    End Select

    WindowProc = CallWindowProc(OriginalWindowProc, hWnd, uMsg, wParam, _
                                lParam)
End Function

'Nicht vergessen: Ende() ausführen!!!
Public Function Init(Form As Form)
    hook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, 0, _
                            GetCurrentThreadId)
    OriginalWindowProc = SetWindowLong(Form.hWnd, GWL_WNDPROC, _
                                       AddressOf WindowProc)
End Function

Public Function Ende()
    UnhookWindowsHookEx hook
    SetWindowLong Form1.hWnd, GWL_WNDPROC, OriginalWindowProc
End Function

Public Function MouseWheelRotation(Richtung As Long, Buttons As mButtons, _
                                   X As Long, Y As Long, hWnd As Long)
    'Hier die eigene Auswertung rein
    If Form1.ProgressBar1.Value < Form1.ProgressBar1.Max And _
                                              Richtung = 1 Then
      Form1.ProgressBar1.Value = Form1.ProgressBar1.Value + Richtung
    ElseIf Form1.ProgressBar1.Value > Form1.ProgressBar1.Min And _
                                                Richtung = -1 Then
      Form1.ProgressBar1.Value = Form1.ProgressBar1.Value + Richtung
    End If
End Function

Public Function MouseWheelUp(X As Long, Y As Long)
Form1.Label1.Caption = "WheelButtonUp"
End Function

Public Function MouseWheelDown(X As Long, Y As Long)
Form1.Label1.Caption = "WheelButtonDown"
End Function



'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 7 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.