button.ctl

非常漂亮的VB控件

VERSION 5.00
Begin VB.UserControl NiceButton 
   Alignable       =   -1  'True
   Appearance      =   0  'Flat
   AutoRedraw      =   -1  'True
   BackColor       =   &H00E0E0E0&
   BackStyle       =   0  '透明
   ClientHeight    =   2865
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5040
   ClipBehavior    =   0  '无
   ControlContainer=   -1  'True
   DefaultCancel   =   -1  'True
   HitBehavior     =   2  '使用画图
   PropertyPages   =   "Button.ctx":0000
   ScaleHeight     =   2865
   ScaleWidth      =   5040
   ToolboxBitmap   =   "Button.ctx":0011
   Begin VB.PictureBox PicTmp 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   255
      Left            =   840
      ScaleHeight     =   255
      ScaleWidth      =   255
      TabIndex        =   2
      Top             =   2400
      Width           =   255
   End
   Begin VB.Timer Timer1 
      Interval        =   3
      Left            =   2880
      Top             =   960
   End
   Begin VB.Image Ico 
      Appearance      =   0  'Flat
      Height          =   240
      Left            =   120
      Stretch         =   -1  'True
      Top             =   600
      Width           =   240
   End
   Begin VB.Label L1 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Label1"
      Height          =   180
      Left            =   2040
      TabIndex        =   1
      Top             =   1800
      Visible         =   0   'False
      Width           =   1380
   End
   Begin VB.Shape Sh 
      BorderStyle     =   3  'Dot
      DrawMode        =   6  'Mask Pen Not
      Height          =   495
      Left            =   360
      Shape           =   4  'Rounded Rectangle
      Top             =   1080
      Width           =   2055
   End
   Begin VB.Label L 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Button1"
      Height          =   180
      Left            =   0
      TabIndex        =   0
      Top             =   120
      Width           =   1380
   End
   Begin VB.Image BT 
      Height          =   420
      Left            =   0
      Picture         =   "Button.ctx":0323
      Stretch         =   -1  'True
      Top             =   0
      Width           =   1335
   End
End
Attribute VB_Name = "NiceButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
'缺省属性值:
Const m_def_UsePicture = 0
Const m_def_ButtonStyle = 0

'属性变量:
Dim m_UsePicture As Boolean
Dim m_ButtonIcon As Picture
Dim m_NoPicture As Picture
Dim m_OnPicture As Picture
Dim m_DownPicture As Picture
'Dim m_ButtonIcon As Picture
'Dim m_PicNoFocus As Picture
'Dim m_PicGetFocus As Picture
Dim m_ToolTipText As String
Dim m_ButtonStyle As Integer
'事件声明:
  Private Const DSS_DISABLED As Long = &H20&
  Private Const DSS_MONO As Long = &H80&
  Private Const DSS_NORMAL As Long = &H0&
  Private Const DSS_UNION As Long = &H10&
  Private Const DST_BITMAP As Long = &H4&
  Private Const DST_COMPLEX As Long = &H0&
  Private Const DST_ICON As Long = &H3&
  Private Const DST_PREFIXTEXT As Long = &H2&
  Private Const DST_TEXT As Long = &H1&
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyDown
Attribute KeyDown.VB_Description = "当用户在拥有焦点的对象上按下任意键时发生。"
Event KeyPress(KeyAscii As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyPress
Attribute KeyPress.VB_Description = "当用户按下和释放 ANSI 键时发生。"
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyUp
Attribute KeyUp.VB_Description = "当用户在拥有焦点的对象上释放键时发生。"
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Attribute MouseDown.VB_Description = "当用户在拥有焦点的对象上按下鼠标按钮时发生。"
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Attribute MouseMove.VB_Description = "当用户移动鼠标时发生。"
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Attribute MouseUp.VB_Description = "当用户在拥有焦点的对象上释放鼠标发生。"
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
Private OnFocus As Boolean
Private Md As Boolean
Private isover As Boolean
Private LastButton As Integer
Private LastKeyDown As Integer
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function DrawState Lib "user32" Alias "DrawStateA" (ByVal hdc As Long, ByVal hBrush As Long, ByVal lpDrawStateProc As Long, ByVal lParam As Long, ByVal wParam As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
Private Declare Function DrawStateText Lib "user32" Alias "DrawStateA" (ByVal hdc&, ByVal hBrush&, ByVal lpDrawStateProc&, ByVal lData$, ByVal wData&, ByVal X&, ByVal Y&, ByVal cx&, ByVal cy&, ByVal fFlags&)

Private Sub UserControl_Resize()
If Ico.Picture <> 0 Then
Ico.Width = 240: Ico.Height = 240
Ico.Left = 100
Ico.Top = UserControl.Height / 2 - Ico.Height / 2
Else
Ico.Width = 0: Ico.Height = 0
Ico.Left = 0
Ico.Top = 0
End If
BT.Width = UserControl.Width
BT.Height = UserControl.Height
L.Width = UserControl.Width - (Ico.Left + Ico.Width)
L.Top = UserControl.Height / 2 - L.Height / 2
L.Left = Ico.Left + Ico.Width
End Sub

Private Sub BT_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseMove Button, Shift, X, Y
End Sub

Private Sub Image1_Click()

End Sub

Private Sub Ico_Click()
UserControl_Click
End Sub

Private Sub Ico_DblClick()
UserControl_DblClick

End Sub

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

End Sub

Private Sub Ico_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseMove Button, Shift, X, Y

End Sub

Private Sub Ico_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseUp Button, Shift, X, Y

End Sub

Private Sub L_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseDown Button, Shift, X, Y
End Sub

Private Sub L_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseMove Button, Shift, X, Y
End Sub

Private Sub L_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseUp Button, Shift, X, Y
End Sub

Private Sub Timer1_Timer()
If Not isMouseOver Then
    Timer1.Enabled = False
    isover = False
    If Not OnFocus Then
        If Not m_UsePicture Then
            BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
        Else
            BT.Picture = m_NoPicture
        End If
    Else
        If Not m_UsePicture Then
            BT.Picture = LoadResPicture(2100 + m_ButtonStyle, 0)
        Else
            BT.Picture = m_OnPicture
        End If
    End If
End If
End Sub

Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
    LastButton = 1
    UserControl_Click
End Sub

Private Sub UserControl_EnterFocus()
OnFocus = True
If Md = False Then
If Not m_UsePicture Then
    BT.Picture = LoadResPicture(2100 + m_ButtonStyle, 0)
Else
    BT.Picture = m_OnPicture
End If
End If
End Sub

Private Sub UserControl_ExitFocus()
If Not m_UsePicture Then
    BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
Else
    BT.Picture = m_NoPicture
End If
OnFocus = False
End Sub

Private Sub UserControl_Initialize()
If Not m_UsePicture Then
    BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
Else
    BT.Picture = m_NoPicture
End If
End Sub
'
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
If Not m_UsePicture Then
    BT.Picture = LoadResPicture(2200 + m_ButtonStyle, 0)
Else
    BT.Picture = m_DownPicture
End If
L.Top = (UserControl.Height / 2 - L.Height / 2) + 20
Ico.Top = (UserControl.Height / 2 - Ico.Height / 2) + 20
Md = True
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
If Not isMouseOver Then
If Not m_UsePicture Then
    BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
Else
    BT.Picture = m_NoPicture
End If
Else
   If Button = 0 And Not isover Then
            Timer1.Enabled = True
            isover = True
            If Not m_UsePicture Then
                BT.Picture = LoadResPicture(2100 + m_ButtonStyle, 0)
            Else
                BT.Picture = m_OnPicture
            End If
   ElseIf Button = 1 Then
            isover = True
            If Not m_UsePicture Then
                BT.Picture = LoadResPicture(2200 + m_ButtonStyle, 0)
            Else
                BT.Picture = m_DownPicture
            End If
            isover = False
   End If
End If
End Sub
Private Sub SetAccessKeys()
Dim ampersandPos As Long, elTex As String

'we first clear the AccessKeys property, and will be filled if one is found
UserControl.AccessKeys = ""
elTex = L.Caption
If LenBB(elTex) > 1 Then
    ampersandPos = InStr(1, elTex, "&", vbTextCompare)
    If (ampersandPos < LenBB(elTex)) And (ampersandPos > 0) Then
        If Mid$(elTex, ampersandPos + 1, 1) <> "&" Then 'if text is sonething like && then no access key should be assigned, so continue searching
            UserControl.AccessKeys = LCase$(Mid$(elTex, ampersandPos + 1, 1))
        Else 'do only a second pass to find another ampersand character
            ampersandPos = InStr(ampersandPos + 2, elTex, "&", vbTextCompare)
            If Mid$(elTex, ampersandPos + 1, 1) <> "&" Then
                UserControl.AccessKeys = LCase$(Mid$(elTex, ampersandPos + 1, 1))
            End If
        End If
    End If
End If
End Sub
Private Function LenBB(ss As String) As Long
LenBB = LenB(StrConv(ss, vbFromUnicode))
End Function

'
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseUp(Button, Shift, X, Y)
If Not OnFocus Then
    If Not m_UsePicture Then
        BT.Picture = LoadResPicture(2000 + m_ButtonStyle, 0)
    Else
        BT.Picture = m_NoPicture
    End If
Else
    If Not m_UsePicture Then
        BT.Picture = LoadResPicture(2100 + m_ButtonStyle, 0)
    Else
        BT.Picture = m_OnPicture
    End If
End If
Md = False
L.Top = (UserControl.Height / 2 - L.Height / 2)
Ico.Top = (UserControl.Height / 2 - Ico.Height / 2)
End Sub
Private Sub BT_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseDown Button, Shift, X, Y
End Sub

Private Sub BT_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseUp Button, Shift, X, Y
End Sub