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

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

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

'* ************************************************** * '* 模块名称：CommandButtonEx.ctl '* 模块功能：带图片的XP风格的按钮控件 '* 编码：lyserver '* 联系方式：http://blog.youkuaiyun.com/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