xpbutton.ctl

在Visual Basic 6.0的环境下

VERSION 5.00
Begin VB.UserControl XPButton 
   ClientHeight    =   4905
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5685
   BeginProperty Font 
      Name            =   "Verdana"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   KeyPreview      =   -1  'True
   ScaleHeight     =   327
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   379
   ToolboxBitmap   =   "XPButton.ctx":0000
   Begin VB.PictureBox imgDis 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      CausesValidation=   0   'False
      ClipControls    =   0   'False
      Enabled         =   0   'False
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   135
      Left            =   960
      ScaleHeight     =   9
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   9
      TabIndex        =   2
      TabStop         =   0   'False
      Top             =   0
      Visible         =   0   'False
      Width           =   135
   End
   Begin VB.PictureBox imgMask 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      CausesValidation=   0   'False
      ClipControls    =   0   'False
      Enabled         =   0   'False
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   135
      Left            =   120
      ScaleHeight     =   9
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   9
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   360
      Visible         =   0   'False
      Width           =   135
   End
   Begin VB.PictureBox imgIcon 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      CausesValidation=   0   'False
      ClipControls    =   0   'False
      Enabled         =   0   'False
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   135
      Left            =   120
      ScaleHeight     =   9
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   9
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   120
      Visible         =   0   'False
      Width           =   135
   End
   Begin VB.Timer tmrCheck 
      Enabled         =   0   'False
      Interval        =   50
      Left            =   480
      Top             =   120
   End
End
Attribute VB_Name = "XPButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
        x As Long
        Y As Long
End Type
Public Event Click()
Public Event DoubleClick()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
Public Event MouseEnters(ByVal x As Long, ByVal Y As Long)
Public Event MouseLeaves(ByVal x As Long, ByVal Y As Long)

Private strCaption As String 'Caption text.

Private oleForeColor As OLE_COLOR 'Caption text color.

Private udtColorStyle As COLOR_STYLE 'Color style of button.
Private udtCaptionAlign As AlignmentConstants 'Alignment for caption.
Private udtIconAlign As PICTURE_ALIGN 'Alignment for icon.
Private udtPoint As POINTAPI 'Current mouse position (for checking if mouse is over button).

Private bolMouseDown As Boolean 'Mouse currently down?
Private bolMouseOver As Boolean 'Mouse currently over button?
Private bolHasFocus As Boolean 'Currently has focus?
Private bolFocusDottedRect As Boolean 'Draw focus dotted rect?
Private bolEnabled As Boolean 'Enabled?

Private lonRoundValue As Long 'Rounded corners value.

Private fntFont As Font 'Caption font.


Private picIcon As Picture 'Small icon picture.
Private picIconMask As Picture 'Small icon mask picture (for transparency).

'Draw the icon on to the button.
Private Sub DrawIcon()
On Error Resume Next

Dim lonHeight As Long, lonLeft As Long

If bolEnabled = True Then
    
    If imgMask.Picture.Handle <> 0 And imgIcon.Picture.Handle <> 0 Then
        lonHeight = (UserControl.ScaleHeight * 0.5) - (imgIcon.ScaleHeight * 0.5)
        
        If udtIconAlign = [Left Justify] Then
            'Draw the icon on the left side.
            'Draw the mask.
            BitBlt UserControl.hdc, 5, lonHeight, imgMask.ScaleWidth, imgMask.ScaleHeight, imgMask.hdc, 0, 0, SRCAND
            'Overlay the mask with the icon.
            BitBlt UserControl.hdc, 5, lonHeight, imgIcon.ScaleWidth, imgIcon.ScaleHeight, imgIcon.hdc, 0, 0, SRCPAINT
        ElseIf udtIconAlign = [Right Justify] Then
            'Draw the icon on the right side.
            'Draw the mask.
            lonLeft = (UserControl.ScaleWidth - imgIcon.ScaleWidth)
            BitBlt UserControl.hdc, lonLeft - 5, lonHeight, imgMask.ScaleWidth, imgMask.ScaleHeight, imgMask.hdc, 0, 0, SRCAND
            BitBlt UserControl.hdc, lonLeft - 5, lonHeight, imgIcon.ScaleWidth, imgIcon.ScaleHeight, imgIcon.hdc, 0, 0, SRCPAINT
        End If
    
    End If

Else
    
    If imgMask.Picture.Handle <> 0 And imgIcon.Picture.Handle <> 0 Then
        lonHeight = (UserControl.ScaleHeight * 0.5) - (imgIcon.ScaleHeight * 0.5)
        Set imgDis.Picture = imgMask.Picture
        ReplaceColor imgDis, 0, 10070188
        
        If udtIconAlign = [Left Justify] Then
            BitBlt UserControl.hdc, 5, lonHeight, imgDis.ScaleWidth, imgDis.ScaleHeight, imgDis.hdc, 0, 0, SRCAND
            BitBlt UserControl.hdc, 5, lonHeight, imgDis.ScaleWidth, imgDis.ScaleHeight, imgDis.hdc, 0, 0, SRCPAINT
        ElseIf udtIconAlign = [Right Justify] Then
            lonLeft = (UserControl.ScaleWidth - imgDis.ScaleWidth)
            BitBlt UserControl.hdc, lonLeft - 5, lonHeight, imgDis.ScaleWidth, imgDis.ScaleHeight, imgDis.hdc, 0, 0, SRCAND
            BitBlt UserControl.hdc, lonLeft - 5, lonHeight - 5, imgDis.ScaleWidth, imgDis.ScaleHeight, imgDis.hdc, 0, 0, SRCPAINT
        End If
    
    End If

End If
End Sub

'Print aligned text to the button (caption).
Private Sub PrintText(ByVal TextString As String, ByVal Alignment As AlignmentConstants)
Dim lonSW As Long, lonSH As Long
Dim lonStartWidth As Long, lonStartHeight As Long

UserControl.ScaleMode = vbTwips
lonSW = UserControl.Width
lonSH = UserControl.Height

If Alignment = vbCenter Then
    lonStartWidth = (UserControl.Width * 0.5) - (UserControl.TextWidth(TextString) * 0.5)
    lonStartHeight = (UserControl.Height * 0.5) - ((UserControl.TextHeight(TextString) * 0.5) + 20)
    UserControl.CurrentX = lonStartWidth
    UserControl.CurrentY = lonStartHeight
    UserControl.Print TextString
ElseIf Alignment = vbLeftJustify Then
    lonStartWidth = 100
    lonStartHeight = (UserControl.Height * 0.5) - ((UserControl.TextHeight(TextString) * 0.5) + 20)
    UserControl.CurrentX = lonStartWidth
    UserControl.CurrentY = lonStartHeight
    UserControl.Print TextString
ElseIf Alignment = vbRightJustify Then
    lonStartWidth = (UserControl.Width - UserControl.TextWidth(TextString)) - 100
    lonStartHeight = (UserControl.Height * 0.5) - ((UserControl.TextHeight(TextString) * 0.5) + 20)
    UserControl.CurrentX = lonStartWidth
    UserControl.CurrentY = lonStartHeight
    UserControl.Print TextString
End If

UserControl.ScaleMode = vbPixels
End Sub

'Draw the dotted focus rect on the button.
Private Sub DrawDottedFocusRect()
Dim lonLoop As Long

'Draw the top focus dotted line.
For lonLoop = 3 To (UserControl.ScaleWidth - 5) Step 2
    UserControl.PSet (lonLoop, 2), 0
Next lonLoop

'Draw the left focus dotted line.
For lonLoop = 4 To (UserControl.ScaleHeight - 4) Step 2
    UserControl.PSet (2, lonLoop), 0
Next lonLoop

'Draw the bottom focus dotted line.
For lonLoop = 3 To (UserControl.ScaleWidth - 5) Step 2
    UserControl.PSet (lonLoop, ScaleHeight - 4), 0
Next lonLoop

'Draw the right focus dotted line.
For lonLoop = 4 To (UserControl.ScaleHeight - 4) Step 2
    UserControl.PSet (ScaleWidth - 4, lonLoop), 0
Next lonLoop
End Sub

'Draw the control.
Private Sub PaintControl()
On Error Resume Next

Dim lonRect As Long, objGrad As clsGradient
Dim strName As String

'Shape control.
lonRect = CreateRoundRectRgn(0, 0, ScaleWidth, ScaleHeight, lonRoundValue, lonRoundValue)
SetWindowRgn UserControl.hWnd, lonRect, True
Set objGrad = New clsGradient

strName = fntFont.Name

If Err = 0 Then
    Set UserControl.Font = fntFont
End If

'Check what style we should be using.
If udtColorStyle = [XP Blue] Then
    'Draw XP blue button.
    
    If bolEnabled = False Then
DrawDisabled:
        'Button is disabled.
        'Draw gradient background.
        objGrad.DefineRect 0, 0, ScaleWidth, ScaleHeight
        objGrad.DrawGradient UserControl.hdc, [Top To Bottom], 15398133, 15398133
        
        'Draw main border.
        UserControl.ForeColor = 12240841
        RoundRect UserControl.hdc, 0, 0, ScaleWidth - 1, ScaleHeight - 1, lonRoundValue, lonRoundValue
        'Draw icon.
        DrawIcon
        
        'Draw caption.
        UserControl.ForeColor = 12240841
        PrintText strCaption, udtCaptionAlign
        
        Exit Sub 'Done.
    End If
    
    'Draw gradient background.
    objGrad.DefineRect 0, 0, ScaleWidth, ScaleHeight
    objGrad.DrawGradient UserControl.hdc, [Top To Bottom], 16514300, 15397104
        
    'Draw main border.