'* ************************************************** *
'* 模块名称：CommandButtonEx.ctl
'* 模块功能：带图片的XP风格的按钮控件
'* 编码：lyserver
'* 联系方式：http://blog.csdn.net/lyserver
'* ************************************************** *

Option Explicit

'----------------------------------------------------
'API声明
'----------------------------------------------------
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
Private Type SIZE
    cx As Long
    cy As Long
End Type
Private Enum THEMESIZE
    TS_MIN '// minimum size
    TS_TRUE '// size without stretching
    TS_DRAW '// size that theme mgr will use to draw part
End Enum
Private Declare Function OpenThemeData Lib "uxtheme.dll" (ByVal hwnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme.dll" (ByVal hTheme As Long) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal lHDC As Long, ByVal iPartId As Long, ByVal nStateId As Long, pRect As RECT, pClipRect As RECT) As Long
Private Declare Function DrawThemeParentBackground Lib "uxtheme.dll" (ByVal hwnd As Long, ByVal hdc As Long, prc As RECT) As Long
Private Declare Function GetThemePartSize Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal nStateId As Long, prc As RECT, ByVal eSize As Long, psz As SIZE) As Long
Private Declare Function GetThemeBackgroundContentRect Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal nStateId As Long, pBoundingRect As RECT, pContentRect As RECT) 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 PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () 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_CENTER = &H1
Private Const DT_RIGHT = &H2
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_BOTTOM = &H8
Private Const DT_SINGLELINE = &H20
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
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

'----------------------------------------------------
'控件事件声明
'----------------------------------------------------
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 Click()

'----------------------------------------------------
'模块用户变量声明
'----------------------------------------------------
Dim m_nState As Long '按钮控件状态
Dim m_blnMouseEnter As Boolean '鼠标移入控件
Dim m_rcUserControl As RECT '控件矩形
Dim m_blnFocus As Boolean '是否处于焦点

'----------------------------------------------------
'属性变量声明
'----------------------------------------------------
Dim m_mvarValue As String
Dim m_mvarPicture As StdPicture
Dim m_mvarHotPicture As StdPicture
Dim m_mvarTextAlign As AlignConstants
Dim m_mvarHasFocus As Boolean

'----------------------------------------------------
'过程说明：控件初始化
'----------------------------------------------------
Private Sub UserControl_Initialize()
    UserControl.ScaleMode = vbPixels
    m_nState = 1 '设置控件默认状态为PBS_NORMAL
End Sub

'----------------------------------------------------
'过程说明：控件被销毁
'----------------------------------------------------
Private Sub UserControl_Terminate()
    Set m_mvarPicture = Nothing
    Set m_mvarHotPicture = Nothing
End Sub

'----------------------------------------------------
'过程说明：控件按键按下处理
'----------------------------------------------------
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Or KeyCode = 32 Then
        m_nState = 3
        UserControl.Refresh
    End If
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

'----------------------------------------------------
'过程说明：控件按键处理
'----------------------------------------------------
Private Sub UserControl_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

'----------------------------------------------------
'过程说明：控件按键抬起处理
'----------------------------------------------------
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim ptCursor As POINTAPI

If KeyCode = 13 Or KeyCode = 32 Then
        GetCursorPos ptCursor
        ScreenToClient UserControl.hwnd, ptCursor
        If PtInRect(m_rcUserControl, ptCursor.x, ptCursor.y) Then
            m_nState = 2 '控件状态为PBS_HOT
        Else
            m_nState = IIf(m_blnFocus, 5, 1) '控件状态为PBS_NORMAL
        End If
        UserControl.Refresh
        DoEvents
    End If
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

'----------------------------------------------------
'过程说明：控件缩放处理
'----------------------------------------------------
Private Sub UserControl_Resize()
    GetClientRect UserControl.hwnd, m_rcUserControl
End Sub

'----------------------------------------------------
'过程说明：控件鼠标按下处理
'----------------------------------------------------
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then '只处理鼠标左键
        m_nState = 3 '控件状态为PBS_PRESSED
        UserControl.Refresh
    End If
    RaiseEvent MouseDown(Button, Shift, x, y)
End Sub

'----------------------------------------------------
'过程说明：控件鼠标移动处理
'----------------------------------------------------
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    '鼠标移到控件上
    If x > 0 And y > 0 And x < UserControl.ScaleWidth And y < UserControl.ScaleHeight Then
        If Not m_blnMouseEnter Then
            m_nState = 2 '控件状态为PBS_HOT
            m_blnMouseEnter = True
            UserControl.Refresh
        End If
        SetCapture UserControl.hwnd
        '鼠标移出控件外
    Else
        ReleaseCapture
        m_blnMouseEnter = False
        m_nState = IIf(m_blnFocus, 5, 1) '控件状态为PBS_NORMAL
        UserControl.Refresh
    End If
    RaiseEvent MouseMove(Button, Shift, x, y)
End Sub

'----------------------------------------------------
'过程说明：控件鼠标抬起处理
'----------------------------------------------------
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim ptCursor As POINTAPI
    Dim blnTemp As Boolean

RaiseEvent MouseUp(Button, Shift, x, y)
    If Button = 1 Then '只处理鼠标左键
        blnTemp = m_blnFocus
        m_blnFocus = False
        m_nState = 5
        UserControl.Refresh
        If m_blnMouseEnter Then RaiseEvent Click '激发Click事件
        m_blnFocus = blnTemp
        GetCursorPos ptCursor
        ScreenToClient UserControl.hwnd, ptCursor
        If PtInRect(m_rcUserControl, ptCursor.x, ptCursor.y) Then
            m_nState = 2
        Else
            m_nState = IIf(m_blnFocus, 5, 1)
        End If
        UserControl.Refresh
    End If
End Sub

'----------------------------------------------------
'过程说明：绘制控件
'----------------------------------------------------
Private Sub UserControl_Paint()
    Dim hTheme As Long
    Dim rcDraw As RECT
    Dim objCurrentPic As StdPicture
    Dim bmWidth As Long
    Dim bmHeight As Long
    Dim xpControlSize As SIZE

'绘制XP风格的按钮控件外观
    hTheme = OpenThemeData(0, StrPtr("Button"))
    If hTheme <> 0 Then
        GetThemePartSize hTheme, hdc, 1, m_nState, rcDraw, TS_TRUE, xpControlSize
        SetRect rcDraw, m_rcUserControl.Left, m_rcUserControl.Top, m_rcUserControl.Right, m_rcUserControl.Bottom
        DrawThemeBackground hTheme, hdc, 1, m_nState, rcDraw, rcDraw
        CloseThemeData hTheme
    End If

SetRect rcDraw, m_rcUserControl.Left + 3, m_rcUserControl.Top + 3, m_rcUserControl.Right - 3, m_rcUserControl.Bottom - 3
    '绘制控件焦点框
    If m_mvarHasFocus And m_blnFocus Then
        DrawFocusRect UserControl.hdc, rcDraw
    End If
    InflateRect rcDraw, -3, -3
    '绘制控件图片和文字
    If m_mvarPicture Is Nothing Then
        DrawText UserControl.hdc, m_mvarValue, lstrlen(m_mvarValue), rcDraw, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
    Else
        If (m_nState = 2 Or m_nState = 3) And (Not m_mvarHotPicture Is Nothing) Then '如果控件状态为PBS_HOT或PBS_PRESSED且HOT图片不为空，则绘制HOT图片
            Set objCurrentPic = m_mvarHotPicture
        Else '否则，绘制普通状态图片
            Set objCurrentPic = m_mvarPicture
        End If
        bmWidth = UserControl.ScaleX(objCurrentPic.Width, vbHimetric, vbPixels)
        bmHeight = UserControl.ScaleY(objCurrentPic.Height, vbHimetric, vbPixels)
        Select Case m_mvarTextAlign
            Case vbAlignNone, vbAlignRight
            objCurrentPic.Render CLng(UserControl.hdc), CLng(rcDraw.Left), CLng(rcDraw.Top + (rcDraw.Bottom - rcDraw.Top - bmHeight) / 2), CLng(bmWidth), CLng(bmHeight), _
                                 0, objCurrentPic.Height, objCurrentPic.Width, -objCurrentPic.Height, ByVal 0&
            DrawText UserControl.hdc, m_mvarValue, lstrlen(m_mvarValue), rcDraw, DT_RIGHT Or DT_VCENTER Or DT_SINGLELINE
            Case vbAlignLeft
            objCurrentPic.Render CLng(UserControl.hdc), CLng(rcDraw.Right - bmWidth), CLng(rcDraw.Top + (rcDraw.Bottom - rcDraw.Top - bmHeight) / 2), CLng(bmWidth), CLng(bmHeight), _
                                 0, objCurrentPic.Height, objCurrentPic.Width, -objCurrentPic.Height, ByVal 0&
            DrawText UserControl.hdc, m_mvarValue, lstrlen(m_mvarValue), rcDraw, DT_LEFT Or DT_VCENTER Or DT_SINGLELINE
            Case vbAlignTop
            objCurrentPic.Render CLng(UserControl.hdc), CLng(rcDraw.Left + (rcDraw.Right - rcDraw.Left - bmWidth) / 2), CLng(rcDraw.Bottom - bmHeight), CLng(bmWidth), CLng(bmHeight), _
                                 0, objCurrentPic.Height, objCurrentPic.Width, -objCurrentPic.Height, ByVal 0&
            DrawText UserControl.hdc, m_mvarValue, lstrlen(m_mvarValue), rcDraw, DT_CENTER Or DT_TOP Or DT_SINGLELINE
            Case vbAlignBottom
            objCurrentPic.Render CLng(UserControl.hdc), CLng(rcDraw.Left + (rcDraw.Right - rcDraw.Left - bmWidth) / 2), CLng(rcDraw.Top), CLng(bmWidth), CLng(bmHeight), _
                                 0, objCurrentPic.Height, objCurrentPic.Width, -objCurrentPic.Height, ByVal 0&
            DrawText UserControl.hdc, m_mvarValue, lstrlen(m_mvarValue), rcDraw, DT_CENTER Or DT_BOTTOM Or DT_SINGLELINE
        End Select
    End If
End Sub

'----------------------------------------------------
'过程说明：读取控件定义的用户属性
'----------------------------------------------------
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Me.Enabled = PropBag.ReadProperty("Enabled", True)
    UserControl.ForeColor = PropBag.ReadProperty("ForeColor", Ambient.ForeColor)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", Ambient.BackColor)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    Set m_mvarPicture = PropBag.ReadProperty("Picture", Nothing)
    Set m_mvarHotPicture = PropBag.ReadProperty("HotPicture", Nothing)
    m_mvarValue = PropBag.ReadProperty("Value", "")
    m_mvarTextAlign = PropBag.ReadProperty("TextAlign", 0)
    m_mvarHasFocus = PropBag.ReadProperty("HasFocus", False)
End Sub

'----------------------------------------------------
'过程说明：保存控件定义的用户属性
'----------------------------------------------------
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, Ambient.ForeColor)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, Ambient.BackColor)
    Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
    Call PropBag.WriteProperty("Picture", m_mvarPicture, Nothing)
    Call PropBag.WriteProperty("HotPicture", m_mvarHotPicture, Nothing)
    Call PropBag.WriteProperty("Value", m_mvarValue, "")
    Call PropBag.WriteProperty("TextAlign", m_mvarTextAlign, 0)
    Call PropBag.WriteProperty("HasFocus", m_mvarHasFocus, False)
End Sub

'----------------------------------------------------
'过程说明：控件焦点处理
Private Sub UserControl_GotFocus()
    m_blnFocus = True
    m_nState = 5
    UserControl.Refresh
End Sub
Private Sub UserControl_LostFocus()
    m_blnFocus = False
    m_nState = 1
    UserControl.Refresh
End Sub

'----------------------------------------------------
'属性说明：获得或设置控件的Enabled属性
'----------------------------------------------------
Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal New_Value As Boolean)
    UserControl.Enabled = New_Value
    UserControl.PropertyChanged "Enabeld"
    m_nState = IIf(New_Value, 1, 4) '如果Enabled，控件状态则为PBS_NORMAL，否则为PBS_DISABLED
    UserControl.Refresh
End Property

'----------------------------------------------------
'属性说明：获得或设置控件的文字颜色
'----------------------------------------------------
Public Property Get ForeColor() As OLE_COLOR
    ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal New_Value As OLE_COLOR)
    UserControl.ForeColor = New_Value
    UserControl.PropertyChanged "ForeColor"
    UserControl.Refresh
End Property

'----------------------------------------------------
'属性说明：获得或设置控件的背景颜色（作用于控件的边缘区域）
'----------------------------------------------------
Public Property Get BackColor() As OLE_COLOR
    BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal New_Value As OLE_COLOR)
    UserControl.BackColor = New_Value
    UserControl.PropertyChanged "BackColor"
    UserControl.Refresh
End Property

'----------------------------------------------------
'属性说明：获得或设置控件的字体
'----------------------------------------------------
Public Property Get Font() As StdFont
    Set Font = UserControl.Font
End Property
Public Property Set Font(ByRef New_Value As StdFont)
    Set UserControl.Font = New_Value
    UserControl.PropertyChanged "Font"
    UserControl.Refresh
End Property

'----------------------------------------------------
'属性说明：获得或设置控件背景图片
'----------------------------------------------------
Public Property Get Picture() As StdPicture
    Set Picture = m_mvarPicture
End Property
Public Property Set Picture(ByRef New_Value As StdPicture)
    Set m_mvarPicture = New_Value
    UserControl.PropertyChanged "Picture"
    UserControl.Refresh
End Property

'----------------------------------------------------
'属性说明：获得或设置控件的热点图片
'----------------------------------------------------
Public Property Get HotPicture() As StdPicture
    Set HotPicture = m_mvarHotPicture
End Property
Public Property Set HotPicture(ByRef New_Value As StdPicture)
    Set m_mvarHotPicture = New_Value
End Property

'----------------------------------------------------
'属性说明：获得或设置控件的值，此属性为控件默认属性
'----------------------------------------------------
Public Property Get Value() As String
    Value = m_mvarValue
End Property
Public Property Let Value(ByVal New_Value As String)
    m_mvarValue = New_Value
    UserControl.PropertyChanged "Value"
    UserControl.Refresh
End Property

'----------------------------------------------------
'属性说明：获得或设置控件文本对齐方式
'----------------------------------------------------
Public Property Get TextAlign() As AlignConstants
    TextAlign = m_mvarTextAlign
End Property
Public Property Let TextAlign(ByVal New_Value As AlignConstants)
    m_mvarTextAlign = New_Value
    UserControl.PropertyChanged "TextAlign"
    UserControl.Refresh
End Property

'----------------------------------------------------
'属性说明：获得或设置控件焦点属性
'----------------------------------------------------
Public Property Get HasFocus() As Boolean
    HasFocus = m_mvarHasFocus
End Property
Public Property Let HasFocus(ByVal New_Value As Boolean)
    m_mvarHasFocus = New_Value
    UserControl.PropertyChanged "HasFocus"
End Property