usercontrol1.ctl

一款非常适用的按钮控件

VERSION 5.00
Begin VB.UserControl XnButton 
   Alignable       =   -1  'True
   BackColor       =   &H8000000A&
   CanGetFocus     =   0   'False
   ClientHeight    =   1155
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2235
   DefaultCancel   =   -1  'True
   ScaleHeight     =   77
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   149
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   510
      Top             =   360
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Label1"
      Height          =   225
      Left            =   210
      TabIndex        =   0
      Top             =   510
      Width           =   1800
   End
End
Attribute VB_Name = "XnButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'缺省属性值:
Const m_def_PressValue = 0
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINT_API) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINT_API) As Long
Private Mousein As Boolean
Private Clicked As Boolean
Private DblClicked As Boolean
Private MouseDown As Boolean
Private PressDown As Boolean
Private StaticColor As OLE_COLOR
Private Type POINT_API
    X As Long
    Y As Long
End Type
Public Enum style_State
    Normal = 0
    Pressed = 1
End Enum
Public Enum style_Fore
    flat = 0
    Solid = 1
End Enum
'属性变量:
Dim m_PressValue As Boolean

Dim m_ForeLineColor As OLE_COLOR
Dim m_ForePressedColor As OLE_COLOR
'Dim m_BackColor As OLE_COLOR
Dim m_ForeColor As OLE_COLOR
Dim m_ForeGroundColor As OLE_COLOR

Dim m_Enabled As Boolean
'Dim m_Font As Font
Dim m_BackStyle As Integer
Dim m_BorderStyle As Integer
Dim m_Style As style_State
Dim m_ForeStyle As style_Fore
Dim m_Style_MouseDown As Boolean
Const m_def_Enabled = 0
Const m_def_BackStyle = 0
Const m_def_BorderStyle = 0
Const m_def_Style = 0
Const m_def_ForeStyle = 0
'Const m_def_BackColor = 0
Const m_def_ForeColor = 0
Const m_def_ForeGroundColor = &H5FACFA ' RGB(250, 172, 95)
Const m_def_ForePressedColor = &HB5CACA 'RGB(202, 202, 181)
Const m_def_ForeLineColor = &HF88E4B 'RGB(75, 142, 248)
'事件声明:
Event Click()
Attribute Click.VB_Description = "当用户在一个对象上按下并释放鼠标按钮时发生。"
'Event DblClick()
'Event KeyDown(KeyCode As Integer, Shift As Integer)
'Event KeyPress(KeyAscii As Integer)
Event MouseOut()
Event KeyUp(KeyCode As Integer, Shift As Integer)
Attribute KeyUp.VB_Description = "当用户在拥有焦点的对象上释放键时发生。"
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseDown.VB_Description = "当用户在拥有焦点的对象上按下鼠标按钮时发生。"
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseMove.VB_Description = "当用户移动鼠标时发生。"
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseUp.VB_Description = "当用户在拥有焦点的对象上释放鼠标发生。"

'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,0
Public Property Get Style() As style_State
    Style = m_Style
End Property
Public Property Let Style(ByVal New_Style As style_State)
    m_Style = New_Style
    m_Style_MouseDown = False
    makebutton 4
    PressDown = False
    PressValue = False
    PropertyChanged "Style"
End Property


'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "返回/设置一个值，决定一个对象是否响应用户生成事件。"
    Enabled = m_Enabled
    
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    m_Enabled = New_Enabled
    If Not m_Enabled Then
     Label1.ForeColor = RGB(201, 201, 188)
     Label1.Enabled = False
     UserControl.Enabled = False
    Else
     Label1.ForeColor = m_ForeColor
     Label1.Enabled = True
     UserControl.Enabled = True
     
    End If
    PropertyChanged "Enabled"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get BackStyle() As Integer
Attribute BackStyle.VB_Description = "指出 Label 或 Shape 的背景样式是透明的还是不透明的。"
    BackStyle = m_BackStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As Integer)
    m_BackStyle = New_BackStyle
    PropertyChanged "BackStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "返回/设置对象的边框样式。"
    BorderStyle = m_BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    m_BorderStyle = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=5
Public Sub Refresh()
Attribute Refresh.VB_Description = "强制完全重画一个对象。"
     
End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Label1,Label1,-1,Caption
Public Property Get Caption() As String
Attribute Caption.VB_Description = "返回/设置对象的标题栏中或图标下面的文本。"
    Caption = Label1.Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
    Label1.Caption() = New_Caption
    PropertyChanged "Caption"
End Property
'
''注意！不要删除或修改下列被注释的行！
''MemberInfo=14
'Public Function MouseOut() As Variant
'
'End Function

Private Sub Label1_Change()
UserControl_Resize
End Sub

Private Sub Label1_Click()
    Call UserControl_Click
    
End Sub

Private Sub Label1_DblClick()
'Call UserControl_MouseDown(0, 0, 1, 1)
'Call UserControl_Click
End Sub

'Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
' makebutton 3
' m_Style_MouseDown = True
'End Sub

Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Call UserControl_MouseDown(Button, Shift, X, Y)

End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 'Debug.Print X / Screen.TwipsPerPixelX & "    " & Y / Screen.TwipsPerPixelY
 Call UserControl_MouseMove(Button, Shift, X / Screen.TwipsPerPixelX, Y / Screen.TwipsPerPixelY)
End Sub

Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call UserControl_MouseUp(Button, Shift, 1, 1)
End Sub

Private Sub Timer1_Timer()
    Dim pnt As POINT_API
    GetCursorPos pnt
    ScreenToClient UserControl.hWnd, pnt
    
    If pnt.X < UserControl.ScaleLeft Or _
       pnt.Y < UserControl.ScaleTop Or _
       pnt.X > (UserControl.ScaleLeft + UserControl.ScaleWidth) Or _
       pnt.Y > (UserControl.ScaleTop + UserControl.ScaleHeight) Then
        Mousein = False
       If Not PressDown Then
         If m_ForeStyle = flat Then makebutton 4 Else makebutton 2
       End If
       
        RaiseEvent MouseOut
        Timer1.Enabled = False
        Exit Sub
    End If
'      If Not (Style = Pressed And m_Style_MouseDown) Then
'          makebutton 1
'      End If
End Sub

Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
RaiseEvent Click
End Sub

Private Sub UserControl_Click()
  If PressDown Then Exit Sub
  RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
  
'   RaiseEvent Click
'dblclicked = True
'UserControl_Click
  
' If m_ForeStyle = flat Then makebutton 4 Else makebutton 1
 'Call UserControl_MouseMove(1, 0, Label1.Left, Label1.Top)
End Sub



'为用户控件初始化属性
Private Sub UserControl_InitProperties()
'    m_BackColor = m_def_BackColor
'    m_ForeColor = m_def_ForeColor
    m_Enabled = m_def_Enabled
'    Set m_Font = Ambient.Font
    m_BackStyle = m_def_BackStyle
    m_BorderStyle = m_def_BorderStyle
    Label1.Caption = "XnButton"
'     m_BackColor = m_def_BackColor
  m_ForeColor = m_def_ForeColor
  m_ForeGroundColor = m_def_ForeGroundColor