wheeltrack.frm

利用VB及API控制鼠标的滚轮行为

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3495
   ClientLeft      =   5640
   ClientTop       =   3420
   ClientWidth     =   4635
   LinkTopic       =   "Form1"
   ScaleHeight     =   3495
   ScaleWidth      =   4635
   Begin VB.PictureBox Picture3 
      AutoRedraw      =   -1  'True
      Height          =   375
      Left            =   960
      ScaleHeight     =   315
      ScaleWidth      =   315
      TabIndex        =   3
      Top             =   2520
      Width           =   375
   End
   Begin VB.PictureBox Picture2 
      AutoRedraw      =   -1  'True
      Height          =   225
      Left            =   360
      ScaleHeight     =   165
      ScaleWidth      =   165
      TabIndex        =   2
      Top             =   2520
      Width           =   225
   End
   Begin VB.TextBox Text1 
      Alignment       =   1  'Right Justify
      Height          =   285
      Left            =   3120
      TabIndex        =   1
      Top             =   2400
      Width           =   735
   End
   Begin VB.PictureBox Picture1 
      Height          =   1515
      Left            =   1560
      ScaleHeight     =   1455
      ScaleWidth      =   1980
      TabIndex        =   0
      ToolTipText     =   "Use Shif to scroll Horizntal"
      Top             =   360
      Width           =   2040
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'=================================
' Constante de GetSystemMetrics
'=================================
Const SM_MOUSEWHEELPRESENT As Long = 75 '   Vrai si molette

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

'=================================
' Constantes de messages
'=================================
Const WM_MOUSEWHEEL As Integer = &H20A  '   action sur la molette
Const WM_MOUSEHOVER As Integer = &H2A1
Const WM_MOUSELEAVE As Integer = &H2A3

Const WM_KEYDOWN As Integer = &H100
Const WM_KEYUP As Integer = &H101
Const WM_CHAR As Integer = &H102

'=================================
' Constants Mask for MouseWheelKey
'=================================
Const MK_LBUTTON As Integer = &H1
Const MK_RBUTTON As Integer = &H2
Const MK_MBUTTON As Integer = &H10
Const MK_SHIFT As Integer = &H4
Const MK_CONTROL As Integer = &H8


Private Type POINTAPI
        X As Long
        Y As Long
End Type

Private Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" ( _
    lpMsg As MSG, _
    ByVal hwnd As Long, _
    ByVal wMsgFilterMin As Long, _
    ByVal wMsgFilterMax As Long _
) As Long

Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" ( _
    lpMsg As MSG _
) As Long

Private Declare Function TranslateMessage Lib "user32" ( _
    lpMsg As MSG _
) As Long

'==================================================
'   Fonction used for mouse tracking (Win 98)
'==================================================

Private Declare Function TRACKMOUSEEVENT Lib "user32" Alias "TrackMouseEvent" ( _
    lpEventTrack As TRACKMOUSEEVENT _
) As Boolean

Private Type TRACKMOUSEEVENT
    cbSize As Long
    dwFlags As Long
    hwndTrack As Long
    dwHoverTime As Long
End Type

    '======================================
    ' Constants for TrackMouseEvent type
    '======================================
    Const TME_HOVER As Long = &H1
    Const TME_LEAVE As Long = &H2
    Const TME_QUERY As Long = &H40000000
    Const TME_CANCEL As Long = &H80000000
    
    Const HOVER_DEFAULT As Long = &HFFFFFFFF


'==================================================
'   Fonction used for mouse tracking (old school)
'==================================================
Private Declare Function GetCursorPos Lib "user32" ( _
    lpPoint As POINTAPI _
) As Long
    
Private Declare Function WindowFromPoint Lib "user32" ( _
    ByVal X As Long, _
    ByVal Y As Long _
) As Long
     
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
    ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long _
) As Long

'=================================
' Variables for wheel tracking
'=================================
Dim m_blnWheelPresent As Boolean    ' true if mouse Wheel present
Dim m_blnWheelTracking As Boolean   ' true while pumping messages
Dim m_blnKeepSpinnig As Boolean       ' true = mouse still active away from source

Dim m_tMSG As MSG                   ' messages structure



'==================================
' Constants for sample application
'==================================
Const m_sCurOffset As Single = 112      ' middle of cursor picture is 7 pixels away from side
Const m_WheelForward As Long = -1       ' Wheeling 'Down' like to walk down a window = increase value
Const m_WheelBackward As Long = 1       ' Wheeling 'Down'                            = decrease value


'==================================
' Variables for sample application
'==================================
    'picture section
    Dim m_sScaleMultiplier_H As Single
    Dim m_sScaleMax_H As Single
    Dim m_sScaleMin_H As Single
    Dim m_sScaleValue_H As Single
    
    Dim m_sScaleMultiplier_V As Single
    Dim m_sScaleMax_V As Single
    Dim m_sScaleMin_V As Single
    Dim m_sScaleValue_V As Single
    
    'text section
    Dim m_lWalkWay As Long          ' Will be set to your choice m_WheelForward or m_WheelForward in initialise proc
    Dim m_lMutiplier_Small As Long
    Dim m_lMutiplier_Large As Long
    Dim m_lSampleValue As Long

Sub WatchForWheel(hClient As Long, Optional blnWheelAround As Boolean)

Dim i As Integer
Dim lResult As Long
Dim bResult As Boolean
Dim tTrackMouse As TRACKMOUSEEVENT

Dim tMouseCords As POINTAPI
Dim lX As Long, lY As Long  '   mouse coordinates
Dim lCurrentHwnd As Long    '

Dim iDirection As Integer
Dim iKeys As Integer

If IsMissing(blnWheelAround) Then
    m_blnKeepSpinnig = False
Else
    m_blnKeepSpinnig = blnWheelAround
End If


m_blnWheelTracking = True

'With tTrackMouse
'    .cbSize =                  ' sizeof tTrackMouse : how to calculate that ?
'    .dwFlags = TME_LEAVE
'    .dwHoverTime = HOVER_DEFAULT
'    .hwndTrack = hClient
'End With

'bResult = TRACKMOUSEEVENT(tTrackMouse)

    '********************************************************
    ' Message pump:
    ' gets all messages and checks for MouseWheel event
    '********************************************************
    Do While m_blnWheelTracking
    
        lResult = GetCursorPos(tMouseCords) ' Get current mouse location
            lX = tMouseCords.X
            lY = tMouseCords.Y
        
        lCurrentHwnd = WindowFromPoint(lX, lY) ' get the window under the mouse from mouse coordinates
        
        If lCurrentHwnd <> hClient Then
            If m_blnKeepSpinnig = False Then      ' Don't stop if true
                m_blnWheelTracking = False      ' We are off the client window
                Exit Do                         ' so we stop tracking
            End If
        End If
        
        lResult = GetMessage(m_tMSG, Me.hwnd, 0, 0)
        
        lResult = TranslateMessage(m_tMSG)

        '=======================================
        ' on renvoie le message dans le circuit
        ' pour la gestion des 関閚ements
        '=======================================
        lResult = DispatchMessage(m_tMSG)
        DoEvents
           
        Select Case m_tMSG.message
            Case WM_MOUSEWHEEL
                '===============================================================
                ' Message is 'Wheel Rolling'
                '===============================================================
                
                Call WheelAction(hClient, m_tMSG.wParam)
                
            
            Case WM_MOUSELEAVE
                '======================================================
                ' Mouse Leave generated by TRACKMOUSEEVENT
                ' when mouse leaves client if TRACKMOUSEEVENT structure
                ' well filled (not here...)
                '======================================================
                m_blnWheelTracking = False
                
        End Select
        
        DoEvents
    Loop