用VB实现带图片的XP风格的按钮控件

    虽然在VB里实现XP风格很简单，但是要使用XP风格同时又让按钮显示图片，则实现起来要麻烦一些，为此，我写了一个控件来实现前述功能，同时让读者可以从中了解XP主题界面的绘制过程。

    使用办法很简单，在VB里新建一个工程，然后添加一个控件模块，粘贴以下代码，再将控件放置到窗口即可，当然，可别忘设置图片和文字属性，具体代码如下：

'* ************************************************** *
'*  模块名称：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