VBレスキュー(花ちゃん) - VBレスキュー(花ちゃん)の投稿サンプル用掲示板

　　　　　サンプル投稿用掲示板　　 VB2005 ～用トップページ　　 VB6.0 用トップページ

マウスがボタン上にある時にボタンのバックカラーを変更する(VB6.0) ( No.1 ) 　[親スレッドへ]

日時： 2010/01/20 11:30
名前： 魔界の仮面弁士: ***********************************************************************************
* カテゴリー：[コントロール共通][マウス][]                                        *
* キーワード：MouseEnter,MouseLeave,ボタン上にカーソル,マウスポインター,MouseMove *
***********************************************************************************

「マウスが離れた時のイベント」を組み込む際には、SetCapture API による
実装が知られています(過去ログにも登場しています)。

ただし、「コントロール配列」や「ウィンドウレスコントロール」には
対応させ難いため、利用範囲が多少限定される事になります。

'===========================================================================
'クラスモジュール「IButtonLeave」
Option Explicit

Public Sub MouseLeaveCallback(ByVal Button As VB.CommandButton)
End Sub

Public Sub MouseEnterCallback(ByVal Button As VB.CommandButton)
End Sub

'===========================================================================
'フォームモジュール「Form1」…ボタンを数個貼っておく
Option Explicit

Implements IButtonLeave
Private Samples As VBA.Collection

Private Sub Form_Load()
    'Add したもののみが対象です。
    Set Samples = New VBA.Collection
    Samples.Add CreateSample(Command1)
    Samples.Add CreateSample(Command2)
    Samples.Add CreateSample(Command3)
End Sub

Private Function CreateSample(ByVal Button As CommandButton) As Sample
    Set CreateSample = New Sample
    CreateSample.Initialize Button
End Function

Private Sub IButtonLeave_MouseEnterCallback(ByVal Button As CommandButton)
    Button.Caption = "Enter"
End Sub

Private Sub IButtonLeave_MouseLeaveCallback(ByVal Button As CommandButton)
    Button.Caption = "Leave"
End Sub

'===========================================================================
'クラスモジュール「Sample」
Option Explicit

Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long

Private mOwner As IButtonLeave
Private WithEvents mButton As VB.CommandButton

Public Sub Initialize(ByVal Button As VB.CommandButton)
    Set mOwner = Button.Parent
    Set mButton = Button
End Sub

Private Sub mButton_MouseMove(MouseButton As Integer, Shift As Integer, X As Single, Y As Single)
    If X >= 0 And X < mButton.Width And Y >= 0 And Y < mButton.Height Then
        If GetCapture() <> mButton.hWnd Then
            mOwner.MouseEnterCallback mButton
            SetCapture mButton.hWnd
        End If
    Else
        mOwner.MouseLeaveCallback mButton
        ReleaseCapture
    End If
End Sub
'===========================================================================