command button.ctl

仿xp的计算器功能和普通计算器的功能一样

VERSION 5.00
Begin VB.UserControl XPButton 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   ClientHeight    =   765
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1185
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000006&
   ScaleHeight     =   51
   ScaleMode       =   0  'User
   ScaleWidth      =   79
   Begin VB.Timer HoverTimer 
      Enabled         =   0   'False
      Interval        =   1
      Left            =   1200
      Top             =   -240
   End
End
Attribute VB_Name = "XPButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'mouse over effects
'draw and set rectangular area of the control
'draw by pixel or by line
Private Const PS_SOLID            As Long = 0
'select and delete created objects
'create regions of pixels and remove them to make the control transparent
Private Const RGN_DIFF            As Long = 4
'set text color and draw it to the control
Private Const DT_CALCRECT         As Long = &H400
Private Const DT_WORDBREAK        As Long = &H10
Private Const DT_CENTER           As Long = &H1
Private Type RECT
    Left                              As Long
    Top                               As Long
    Right                             As Long
    Bottom                            As Long
End Type
Private Type POINTAPI
    X                                 As Long
    Y                                 As Long
End Type
Public Event Click()
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 KeyPress(KeyAscii As Integer)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseOver()
Public Event MouseOut()
Private rc                        As RECT
Private w                         As Long
'<:-) :WARNING: Single letter Variables make code difficult to read, use a meaningful name.
'<:-) :SUGGESTION: Change the variable name to (lngW).
'<:-) If you are only using it as a For structures counter use a Dim instead
'<:-) (may cause local Dims to be marked as duplicates)
Private H                         As Long
'<:-) :WARNING: Single letter Variables make code difficult to read, use a meaningful name.
'<:-) :SUGGESTION: Change the variable name to (lngH).
'<:-) If you are only using it as a For structures counter use a Dim instead
'<:-) (may cause local Dims to be marked as duplicates)
Private rgMain                    As Long
Private rgn1                      As Long
Private isOver                    As Boolean
Private flgHover                  As Integer
Private flgFocus                  As Boolean
Private LastButton                As Integer
Private LastKey                   As Integer
Private R                         As Long
'<:-) :WARNING: Single letter Variables make code difficult to read, use a meaningful name.
'<:-) :SUGGESTION: Change the variable name to (lngR).
'<:-) If you are only using it as a For structures counter use a Dim instead
'<:-) (may cause local Dims to be marked as duplicates)
Private L                         As Long
'<:-) :WARNING: Single letter Variables make code difficult to read, use a meaningful name.
'<:-) :SUGGESTION: Change the variable name to (lngL).
'<:-) If you are only using it as a For structures counter use a Dim instead
'<:-) (may cause local Dims to be marked as duplicates)
Private t                         As Long
'<:-) :WARNING: Single letter Variables make code difficult to read, use a meaningful name.
'<:-) :SUGGESTION: Change the variable name to (lngT).
'<:-) If you are only using it as a For structures counter use a Dim instead
'<:-) (may cause local Dims to be marked as duplicates)
Private B                         As Long
'<:-) :WARNING: Single letter Variables make code difficult to read, use a meaningful name.
'<:-) :SUGGESTION: Change the variable name to (lngB).
'<:-) If you are only using it as a For structures counter use a Dim instead
'<:-) (may cause local Dims to be marked as duplicates)
Private mEnabled                  As Boolean
Private mCaption                  As String
Private mForeHover                As OLE_COLOR
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, _
                                                       ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, _
                                                     lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, _
                                               ByVal X1 As Long, _
                                               ByVal Y1 As Long, _
                                               ByVal X2 As Long, _
                                               ByVal Y2 As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal Hdc As Long, _
                                                lpRect As RECT, _
                                                ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal Hdc As Long, _
                                                 lpRect As RECT, _
                                                 ByVal hBrush As Long) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal Hdc As Long, _
                                               ByVal X As Long, _
                                               ByVal Y As Long, _
                                               ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal Hdc As Long, _
                                               ByVal X As Long, _
                                               ByVal Y As Long, _
                                               lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal Hdc As Long, _
                                             ByVal X As Long, _
                                             ByVal Y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, _
                                                ByVal nWidth As Long, _
                                                ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal Hdc As Long, _
                                                   ByVal hObject As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
                                                    ByVal Y1 As Long, _
                                                    ByVal X2 As Long, _
                                                    ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, _
                                                 ByVal hSrcRgn1 As Long, _
                                                 ByVal hSrcRgn2 As Long, _
                                                 ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, _
                                                    ByVal hRgn As Long, _
                                                    ByVal bRedraw As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal Hdc As Long) As Long
'<:-) :WARNING: This UserControl member is not used in the current project,
'<:-) and may be removed for purposes of this program.
Private Declare Function SetTextColor Lib "gdi32" (ByVal Hdc As Long, _
                                                   ByVal crColor As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal Hdc As Long, _
                                                                  ByVal lpStr As String, _
                                                                  ByVal nCount As Long, _
                                                                  lpRect As RECT, _
                                                                  ByVal wFormat As Long) As Long

Public Property Get Caption() As String

    Caption = mCaption

End Property

Public Property Let Caption(ByVal NewValue As String)

    mCaption = NewValue
    RedrawButton 0
    SetAccessKeys
    PropertyChanged "Caption"

End Property

Private Sub DrawButton()

'<:-) :WARNING: This UserControl member is not used in the current project,
'<:-) and may be removed for purposes of this program.
'<:-) :WARNING: Large Code procedure (89 lines of code)
'<:-) It is recommended that you try to break it into smaller procedures

Dim pt   As POINTAPI
Dim Pen  As Long
Dim hPen As Long

    With UserControl
        'left top corner
        hPen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, L, t + 1, pt
        LineTo .Hdc, L + 2, t
        SelectObject .Hdc, Pen
        DeleteObject hPen
        hPen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, L + 2, t, pt
        LineTo .Hdc, L, t + 2
        SelectObject .Hdc, Pen
        DeleteObject hPen
        SetPixel .Hdc, L, t + 2, RGB(37, 87, 131)
        SetPixel .Hdc, L + 1, t + 2, RGB(191, 206, 220)
        SetPixel .Hdc, L + 2, t + 1, RGB(192, 207, 221)
        'top line
        hPen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, L + 3, t, pt
        LineTo .Hdc, R - 2, t
        SelectObject .Hdc, Pen
        DeleteObject hPen
        'right top corner
        hPen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, R - 2, t, pt
        LineTo .Hdc, R + 1, t + 3
        SelectObject .Hdc, Pen
        DeleteObject hPen
        hPen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, R - 1, t, pt
        LineTo .Hdc, R, t + 2
        SetPixel .Hdc, R, t + 1, RGB(122, 149, 168)
        SetPixel .Hdc, R - 2, t + 1, RGB(213, 223, 232)
        SetPixel .Hdc, R - 1, t + 2, RGB(191, 206, 219)
        SelectObject .Hdc, Pen
        DeleteObject hPen
        'right line
        hPen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, R, t + 3, pt
        LineTo .Hdc, R, B - 3
        SelectObject .Hdc, Pen
        DeleteObject hPen
        'right bottom corner
        hPen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, R, B - 3, pt
        LineTo .Hdc, R - 3, B
        SelectObject .Hdc, Pen
        DeleteObject hPen
        hPen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, R, B - 2, pt
        LineTo .Hdc, R - 2, B
        SetPixel .Hdc, R - 2, B - 2, RGB(177, 183, 182)
        SetPixel .Hdc, R - 1, B - 3, RGB(182, 189, 189)
        SelectObject .Hdc, Pen
        DeleteObject hPen
        'bottom line
        hPen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, L + 3, B - 1, pt
        LineTo .Hdc, R - 2, B - 1
        SelectObject .Hdc, Pen
        DeleteObject hPen
        'left bottom corner
        hPen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, L, B - 3, pt
        LineTo .Hdc, L + 3, B
        SelectObject .Hdc, Pen
        DeleteObject hPen
        hPen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, L, B - 2, pt
        LineTo .Hdc, L + 2, B
        SetPixel .Hdc, L + 1, B - 3, RGB(191, 199, 202)
        SetPixel .Hdc, L + 2, B - 2, RGB(163, 174, 180)
        SelectObject .Hdc, Pen
        DeleteObject hPen
        'left line
        hPen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
        Pen = SelectObject(.Hdc, hPen)
        MoveToEx .Hdc, L, t + 3, pt
        LineTo .Hdc, L, B - 3
        SelectObject .Hdc, Pen
        DeleteObject hPen
    End With 'USERCONTROL

End Sub

Private Sub DrawButton2()

'Dim pt As POINTAPI
'Dim Pen As Long
'Dim hPen As Long
'Dim I As Long
'Dim ColorR As Long
'Dim ColorG As Long
'Dim ColorB As Long

Dim hBrush As Long

    With UserControl
        hBrush = CreateSolidBrush(RGB(0, 60, 116))
        FrameRect .Hdc, rc, hBrush
        DeleteObject hBrush
        'Left top corner
        SetPixel .Hdc, L, t + 1, RGB(122, 149, 168)
        SetPixel .Hdc, L + 1, t + 1, RGB(37, 87, 131)
        SetPixel .Hdc, L + 1, t, RGB(122, 149, 168)
        'SetPixel .hdc, l + 1, t + 2, RGB(191, 206, 220)
        'SetPixel .hdc, l + 2, t + 1, RGB(192, 207, 221)
        'right top corner
        SetPixel .Hdc, R - 1, t, RGB(122, 149, 168)
        SetPixel .Hdc, R - 1, t + 1, RGB(37, 87, 131)
        SetPixel .Hdc, R, t + 1, RGB(122, 149, 168)
        'SetPixel .hdc, r - 2, t + 1, RGB(234, 233, 222)
        'SetPixel .hdc, r - 1, t + 2, RGB(234, 233, 222)
        'left bottom corner
        SetPixel .Hdc, L, B - 2, RGB(122, 149, 168)
        SetPixel .Hdc, L + 1, B - 2, RGB(37, 87, 131)
        SetPixel .Hdc, L + 1, B - 1, RGB(122, 149, 168)
        'SetPixel .hdc, l + 1, b - 3, RGB(234, 233, 222)
        'SetPixel .hdc, l + 2, b - 2, RGB(234, 233, 222)
        'right bottom corner
        SetPixel .Hdc, R, B - 2, RGB(122, 149, 168)
        SetPixel .Hdc, R - 1, B - 2, RGB(37, 87, 131)
        SetPixel .Hdc, R - 1, B - 1, RGB(122, 149, 168)
        'SetPixel .hdc, r - 1, b - 3, RGB(234, 233, 222)
        'SetPixel .hdc, r - 2, b - 2, RGB(234, 233, 222)
    End With 'USERCONTROL

End Sub

Private Sub DrawButtonDisabled()

'Dim pt As POINTAPI
'Dim Pen As Long
'Dim hPen As Long
'Dim I As Long
'Dim ColorR As Long
'Dim ColorG As Long
'Dim ColorB As Long

Dim hBrush As Long