wwbutton.ctl

一个自写的VB按钮控件

VERSION 5.00
Begin VB.UserControl wwbutton 
   AutoRedraw      =   -1  'True
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   DefaultCancel   =   -1  'True
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   ToolboxBitmap   =   "WWBUTTON.ctx":0000
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   1815
      Top             =   1185
   End
End
Attribute VB_Name = "wwbutton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_BTNHIGHLIGHT = 20
Private Const COLOR_BTNDKSHADOW = 21
Private Const COLOR_BTNLIGHT = 22

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
Private Const DT_LEFT = &H0
Private Const DT_CENTERABS = &H65                    'CENTERABS= &H65
Const DT_WORDBREAK = &H10
Const DT_CENTER = &H1
Const DT_VCENTER = &H4
Const DT_EXPANDTABS = &H40
Const DT_EXTERNALLEADING = &H200
Const DT_CALCRECT = &H400

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 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 Const RGN_DIFF = 4

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 Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long


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 Enum ButtonTypes
    [Windows XP] = 1        'the new brand XP button totally owner-drawn
    [Mac] = 2               'i suppose it looks exactly as a Mac button... i took the style from a GetRight skin!!!
    [Mac OS] = 3
    [Longhorn] = 4
    [Office Xp] = 5
End Enum

Public Enum ColorTypes
    [Use Windows] = 1
    [Custom] = 2
    [Force Standard] = 3
End Enum
Public Enum XpTypes
    [银色风格] = 1
    [翠色风格] = 2
    [蓝色风格] = 3
End Enum
'variables
'属性变量:
'Dim m_ButtonType As ButtonTypes
'Dim m_ColorScheme As ColorTypes

Dim m_rectcolor As OLE_COLOR
Dim m_hWnd As Long
Dim showFocusR As Boolean
Private MyButtonType As ButtonTypes
Private MyColorType As ColorTypes
Private MyXpType As XpTypes

Private He As Long  'wwbutton的高度
Private Wi As Long  'wwbutton的宽度
Dim allcount As Integer                       'caption字节总数
Private BackC As Long 'back color
Private ForeC As Long 'fore color

Private m_Caption As String     'current caption  变量
Private TextFont As StdFont 'current font

Private Rc As RECT, rc2 As RECT, rc3 As RECT
Private rgnNorm As Long                           '正常区域句柄

Private LastButton As Byte, LastKeyDown As Byte         '上一次按钮状态和上一次键盘按下状态
Private isEnabled As Boolean
Private hasFocus As Boolean                         '焦点标志
Private disyellowrect As Boolean                         '鼠标移入时显示黄色圆角矩形标志
Private cFace As Long, cLight As Long, cHighLight As Long, cShadow As Long, cDarkShadow As Long, cText As Long

Dim m_Percent As Integer                '按钮上边沿到按钮上颜色最深的位置之距离占按钮高度的百分比
Private m_MidColor As Long                             '以下六个变量为Mac OS和Longhorn中间色MidColor和边色EndColor
Private m_EndColor As Long
Private m_MouseMoveMidColor As Long
Private m_MouseMoveEndColor As Long
Private m_MouseDownMidColor As Long
Private m_MouseDownEndColor As Long

Private m_OfficeXpFillColor As Long                  '正常状态内部填充色
Private m_OfficeXpMousemoveFillColor As Long         '鼠标移入时内部填充色
Private m_OfficeXpFrameColor As Long                 '正常状态外框色
Private m_OfficeXpMousemoveFrameColor As Long        '鼠标移入时外框色
Private lastStat As Byte, TE As String '        保存状态，消除不必要的重画
'缺省属性值:


Const m_def_rectcolor = &H58C3FA

Const m_def_Enabled = True
Const m_def_hWnd = 0
Const m_def_ButtonType = [Windows XP]
Const m_def_XpType = [银色风格]
Const m_def_Caption = "wwbutton"
Const m_def_ColorScheme = [Use Windows]
Const m_def_ShowFocusRect = True

Const m_def_Percent = 16
Const m_def_MidColor = &H73C874               'RGB(116, 200, 115)
Const m_def_EndColor = &HD7F6D7                 'RGB(215, 246, 215)
Const m_def_MouseMoveMidColor = &H33A335                   'RGB(53, 163, 51)
Const m_def_MouseMoveEndColor = &HF4FCF5         'RGB(245, 252, 244)
Const m_def_MouseDownMidColor = &H85D084         'RGB(132, 208, 133)
Const m_def_MouseDownEndColor = &H0
Const m_def_OfficeXpFillColor = &HA0DEDE
Const m_def_OfficeXpFrameColor = &H42BCBC
Const m_def_OfficeXpMousemoveFillColor = &HBADCDC
Const m_def_OfficeXpMousemoveFrameColor = &H1807F

'事件声明:

Event Click()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseOut()


'********************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=10,0,0,0
Public Property Get BackColor() As OLE_COLOR
    BackColor = BackC
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    BackC = New_BackColor
    Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "BackColor"
End Property

'***********************************************************************************
'********************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=10,0,0,0
Public Property Get ForeColor() As OLE_COLOR
    ForeColor = ForeC
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    ForeC = New_ForeColor
    Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "ForeColor"
End Property
End Property
'Mac OS Property
Public Property Get Percent() As Integer              'Percent设置按钮从上到下中间色的位置，以百分比计
    Percent = m_Percent
End Property

Public Property Let Percent(ByVal New_Percent As Integer)
    m_Percent = New_Percent
    If m_Percent < 0 Or m_Percent > 100 Then
       Err.Raise 380          ' MsgBox "无效属性"
    Else
       Call Redraw(lastStat, True)
       PropertyChanged "Percent"
    End If
    'Call SetColors
End Property
'***************************************************************************
'以下为Mac OS和Longhorn风格属性
Public Property Get MidColor() As OLE_COLOR
    MidColor = m_MidColor
End Property

Public Property Let MidColor(ByVal New_MidColor As OLE_COLOR)            'MidColor
    m_MidColor = New_MidColor
    'Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "MidColor"
End Property
'*************************************************************************
Public Property Get EndColor() As OLE_COLOR
    EndColor = m_EndColor
End Property

Public Property Let EndColor(ByVal New_EndColor As OLE_COLOR)            'EndColor
    m_EndColor = New_EndColor
    'Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "EndColor"
End Property
'***********************************************************************
Public Property Get MouseMoveMidColor() As OLE_COLOR
    MouseMoveMidColor = m_MouseMoveMidColor
End Property

Public Property Let MouseMoveMidColor(ByVal New_MouseMoveMidColor As OLE_COLOR)            'MouseMoveMidColor
    m_MouseMoveMidColor = New_MouseMoveMidColor
    'Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "MouseMoveMidColor"
End Property
'*************************************************************************
Public Property Get MouseMoveEndColor() As OLE_COLOR
    MouseMoveEndColor = m_MouseMoveEndColor
End Property

Public Property Let MouseMoveEndColor(ByVal New_MouseMoveEndColor As OLE_COLOR)            'MouseMoveEndColor
    m_MouseMoveEndColor = New_MouseMoveEndColor
    'Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "MouseMoveEndColor"
End Property
'****************************************************************************
Public Property Get MouseDownMidColor() As OLE_COLOR
    MouseDownMidColor = m_MouseDownMidColor
End Property

Public Property Let MouseDownMidColor(ByVal New_MouseDownMidColor As OLE_COLOR)            'MouseDownMidColor
    m_MouseDownMidColor = New_MouseDownMidColor
    'Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "MouseDownMidColor"
End Property
'*****************************************************************************
Public Property Get MouseDownEndColor() As OLE_COLOR
    MouseDownEndColor = m_MouseDownEndColor
End Property

Public Property Let MouseDownEndColor(ByVal New_MouseDownEndColor As OLE_COLOR)            'MouseDownEndColor
    m_MouseDownEndColor = New_MouseDownEndColor
    'Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "MouseDownEndColor"
End Property
Public Property Get OfficeXpFillColor() As OLE_COLOR
    OfficeXpFillColor = m_OfficeXpFillColor
End Property

Public Property Let OfficeXpFillColor(ByVal New_OfficeXpFillColor As OLE_COLOR)            '
    m_OfficeXpFillColor = New_OfficeXpFillColor
    'Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "OfficeXpFillColor"
End Property

Public Property Get OfficeXpFrameColor() As OLE_COLOR
    OfficeXpFrameColor = m_OfficeXpFrameColor
End Property

Public Property Let OfficeXpFrameColor(ByVal New_OfficeXpFrameColor As OLE_COLOR)
    m_OfficeXpFrameColor = New_OfficeXpFrameColor
    'Call SetColors
    Call Redraw(lastStat, True)