編寫一個浮動按鈕控件(如何給控件添加MouseOut事件)

o_showimg.jpg

r_showimg1.jpg
'lblCtlFloatButton.ctl 文件內容如下
VERSION 5.00
Begin VB.UserControl lblCtlFloatButton
   ClientHeight    =   405
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1965
   ScaleHeight     =   405
   ScaleWidth      =   1965
   Begin VB.Label lblCaption
      AutoSize        =   -1  'True
      Height          =   195
      Index           =   0
      Left            =   480
      TabIndex        =   1
      Top             =   120
      Width           =   45
   End
   Begin VB.Line Line1
      BorderColor     =   &H80000005&
      Index           =   0
      X1              =   0
      X2              =   1920
      Y1              =   0
      Y2              =   0
   End
   Begin VB.Line Line1
      BorderColor     =   &H80000005&
      Index           =   1
      X1              =   0
      X2              =   0
      Y1              =   0
      Y2              =   360
   End
   Begin VB.Line Line1
      BorderColor     =   &H80000003&
      Index           =   2
      X1              =   0
      X2              =   1920
      Y1              =   360
      Y2              =   360
   End
   Begin VB.Line Line1
      BorderColor     =   &H80000003&
      Index           =   3
      X1              =   1920
      X2              =   1920
      Y1              =   0
      Y2              =   360
   End
   Begin VB.Label lblCaption
      BackStyle       =   0  'Transparent
      Height          =   345
      Index           =   1
      Left            =   15
      TabIndex        =   0
      Top             =   15
      Width           =   1905
   End
End
Attribute VB_Name = "lblCtlFloatButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Type POINTAPI
    x As Long
    y As Long
End Type

Private m_Float As Boolean

Public Event Click()
Public Event MouseOut()

Private Sub lblCaption_Click(Index As Integer)
    RaiseEvent Click
End Sub

Private Sub lblCaption_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
'模擬按鈕被按下的效果
    Line1(0).BorderColor = vbButtonShadow
    Line1(1).BorderColor = vbButtonShadow
    Line1(2).BorderColor = vbWhite
    Line1(3).BorderColor = vbWhite
    lblCaption(0).Move lblCaption(0).Left + 15, lblCaption(0).Top + 15
End Sub

Private Sub lblCaption_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim Pos1 As POINTAPI
Dim pos2 As POINTAPI
Dim i As Integer
Static Out As Boolean
    
    '鼠標旋於按鈕上,若Float屬性爲True,則顯示浮動效果
    If Float = True Then
    For i = 0 To 3
        Line1(i).Visible = True
    Next
    End If
    
    Out = False
    '當鼠標懸停於按鈕上時,通過API函數GetCursorPos和ScreenToClient判斷鼠標何時移出
    Do While Out = False
    GetCursorPos Pos1
    pos2.x = Pos1.x: pos2.y = Pos1.y
    ScreenToClient UserControl.hwnd, pos2
    If pos2.x< 0 Or pos2.y< 0 Or pos2.x>UserControl.Width/15 Or pos2.y>UserControl.Height/15 Then      '判斷鼠標是否仍在按鈕的範圍內
        Out = True
        '鼠標移出按鈕,若Float屬性爲True,則消去浮動效果
        If Float = True Then
            For i = 0 To 3
                Line1(i).Visible = False
            Next
        End If
        RaiseEvent MouseOut                        '觸發MouseOut事件
        Exit Do
    End If
    DoEvents
    Loop
End Sub

Private Sub lblCaption_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
'模擬按鈕被擡起的效果
    Line1(2).BorderColor = vbButtonShadow
    Line1(3).BorderColor = vbButtonShadow
    Line1(0).BorderColor = vbWhite
    Line1(1).BorderColor = vbWhite
    lblCaption(0).Move (UserControl.Width - lblCaption(0).Width) / 2, (UserControl.Height - lblCaption(0).Height) / 2
End Sub

Private Sub UserControl_InitProperties()
    Caption = Extender.Name
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Caption = PropBag.ReadProperty("Caption", Extender.Name)
    Float = PropBag.ReadProperty("Float", False)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Caption", Caption, Extender.Name
    PropBag.WriteProperty "Float", Float, False
End Sub

Private Sub UserControl_Resize()
    Line1(0).X2 = UserControl.Width
    Line1(2).X2 = UserControl.Width
    Line1(1).Y2 = UserControl.Height
    Line1(3).Y2 = UserControl.Height
    Line1(3).X1 = UserControl.Width - 15
    Line1(3).X2 = UserControl.Width - 15
    Line1(2).Y1 = UserControl.Height - 15
    Line1(2).Y2 = UserControl.Height - 15
    lblCaption(1).Move 15, 15, UserControl.Width - 30, UserControl.Height - 30
    lblCaption(0).Move (UserControl.Width - lblCaption(0).Width) / 2, (UserControl.Height - lblCaption(0).Height) / 2
End Sub

Public Property Get Caption() As String
    Caption = lblCaption(0).Caption
End Property

Public Property Let Caption(ByVal vNewValue As String)
    lblCaption(0).Caption = vNewValue
    PropertyChanged "Caption"
    Call UserControl_Resize
End Property

Public Property Get Float() As Boolean
    Float = m_Float
End Property

Public Property Let Float(ByVal vNewValue As Boolean)
Dim i As Integer
    m_Float = vNewValue
    For i = 0 To 3
        Line1(i).Visible = Not vNewValue
    Next
    PropertyChanged "Float"
End Property

發佈了46 篇原創文章 · 獲贊 3 · 訪問量 29萬+
發表評論
所有評論
還沒有人評論,想成為第一個評論的人麼? 請在上方評論欄輸入並且點擊發布.
相關文章