用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