modmakexpbutton.bas

打印预览程序

Attribute VB_Name = "modMakeXPButton"
Option Explicit

' If you use XP visual styles in your application,
' you have noticed that graphical buttons don't get the XP style.
' This code subclasses the graphical buttons and draws them using the current visual style.
' Just call MakeXPButton with the button you want to apply the visual style to.

' THIS CODE DOES NOT MAKE ANY BUTTON IN ANY OPERATING SYSTEM LOOK LIKE XP BUTTONS.
' IT DOES NOTHING IF IT RUNS IN A SYSTEM THAT DOESN'T HAVE XP.

'By: Eduardo A. Morcillo http://www.mvps.org/emorcillo/

' ********** API **********

Private Const GWL_WNDPROC = (-4)

Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) As Long

Private Declare Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private Declare Function CallWindowProc Lib "user32" _
    Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long

Private Declare Function GetProp Lib "user32" _
    Alias "GetPropA" ( _
    ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" _
    Alias "SetPropA" ( _
    ByVal hwnd As Long, ByVal lpString As String, _
    ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" _
    Alias "RemovePropA" ( _
    ByVal hwnd As Long, ByVal lpString As String) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" ( _
    Destination As Any, Source As Any, ByVal Length As Long)

Private Const WM_PAINT = &HF
Private Const WM_DESTROY = &H2
Private Const WM_NCPAINT = &H85
Private Const WM_MOUSEHOVER = &H2A1
Private Const WM_MOUSELEAVE = &H2A3
Private Const WM_MOUSEMOVE = &H200
Private Const WM_SETFOCUS = &H7
Private Const WM_KILLFOCUS = &H8
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_ENABLE = &HA
Private Const WM_MOUSEACTIVATE = &H21
Private Const BM_GETSTATE = &HF2

Private Const BST_PUSHED = &H4
Private Const BST_FOCUS = &H8

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Type PAINTSTRUCT
   hdc As Long
   fErase As Long
   rcPaint As RECT
   fRestore As Long
   fIncUpdate As Long
   rgbReserved(32) As Byte
End Type

Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function InvalidateRect Lib "user32" ( _
    ByVal hwnd As Long, _
    lpRect As Any, _
    ByVal bErase As Long) As Long

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 CreateBitmap Lib "gdi32" ( _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal nPlanes As Long, _
    ByVal nBitCount As Long, _
    lpBits As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function InflateRect 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 SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" ( _
    ByVal hDestDC As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hSrcDC As Long, _
    ByVal xSrc As Long, _
    ByVal ySrc As Long, _
    ByVal dwRop As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Const COLOR_BTNTEXT = 18
Private Const COLOR_GRAYTEXT = 17

Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_WORDBREAK = &H10

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

Type TrackMouseEvent
   cbSize As Long
   dwFlags As Long
   hwndTrack As Long
   dwHoverTime As Long
End Type

Private Const TME_HOVER = 1
Private Const TME_LEAVE = 2

Private Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TrackMouseEvent) As Long

Const TRANSPARENT = 1

Private Declare Function TransparentBlt Lib "msimg32" ( _
  ByVal hDCDest As Long, _
  ByVal nXOriginDest As Long, _
  ByVal nYOriginDest As Long, _
  ByVal nWidthDest As Long, _
  ByVal hHeightDest As Long, _
  ByVal hDCSrc As Long, _
  ByVal nXOriginSrc As Long, _
  ByVal nYOriginSrc As Long, _
  ByVal nWidthSrc As Long, _
  ByVal nHeightSrc As Long, _
  ByVal crTransparent As Long) As Long

Const SM_CXFOCUSBORDER = 83
Const SM_CYFOCUSBORDER = 84

' ********** Theme API **********

Const STAP_ALLOW_CONTROLS = 2

Private Declare Function GetThemeAppProperties Lib "uxtheme" () As Long
Private Declare Function IsThemeActive Lib "uxtheme" () As Long

Private Declare Function DrawThemeBackground Lib "uxtheme" ( _
   ByVal hTheme As Long, _
   ByVal hdc As Long, _
   ByVal iPartID As Long, _
   ByVal iStateID As Long, _
   pRect As RECT, _
   pClipRect As RECT) As Long

Private Declare Function DrawThemeText Lib "uxtheme" ( _
   ByVal hTheme As Long, _
   ByVal hdc As Long, _
   ByVal iPartID As Long, _
   ByVal iStateID As Long, _
   ByVal pszText As Long, _
   ByVal iCharCount As Long, _
   ByVal dwTextFlags As Long, _
   ByVal dwTextFlags2 As Long, _
   pRect As RECT) As Long

Private Declare Function DrawThemeEdge Lib "uxtheme" ( _
   ByVal hTheme As Long, _
   ByVal hdc As Long, _
   ByVal iPartID As Long, _
   ByVal iStateID As Long, _
   pDestRect As RECT, _
   ByVal uEdge As Long, _
   ByVal uFlags As Long, _
   pContentRect As Any) As Long

Declare Function GetThemeTextExtent Lib "uxtheme" ( _
   ByVal hTheme As Long, _
   ByVal hdc As Long, _
   ByVal iPartID As Long, _
   ByVal iStateID As Long, _
   ByVal pszText As Long, _
   ByVal iCharCount As Long, _
   ByVal dwTextFlags As Long, _
   pBoundingRect As Any, _
   pExtentRect As RECT) As Long

Private Declare Function IsAppThemed Lib "uxtheme" () As Long

Private Declare Function OpenThemeData Lib "uxtheme" ( _
   ByVal hwnd As Long, _
   ByVal pszClassList As Long) As Long

Private Declare Function CloseThemeData Lib "uxtheme" ( _
   ByVal hTheme As Long) As Long

Private Declare Function GetThemeSysColor Lib "uxtheme" ( _
   ByVal hTheme As Long, _
   ByVal iColorId As Long) As Long

Private Declare Function GetThemeSysSize Lib "uxtheme" ( _
   ByVal hTheme As Long, _
   ByVal iSizeId As Long) As Long
'
' MakeXPButton
'
' Converts a "Graphical" button to XP style
'
Sub MakeXPButton(ByVal Button As Object)
Dim hwnd As Long

   On Error GoTo NoXP

   If IsThemeActive() = 0 Then Exit Sub
   If IsAppThemed() = 0 Then Exit Sub

   ' Check the object class
   If TypeOf Button Is CommandButton Or _
      TypeOf Button Is OptionButton Or _
      TypeOf Button Is CheckBox Then

      ' Only subclass if the style is Graphical
      If Button.Style = vbButtonGraphical Then

         ' Store the button object in the
         ' window and subclass it
         hwnd = Button.hwnd
         SetProp hwnd, "Button", ObjPtr(Button)
         SetProp hwnd, "WinProc", SetWindowLong(Button.hwnd, GWL_WNDPROC, AddressOf WinProc_Button)

      End If

   End If

NoXP:

End Sub

'
' DrawButton
'
' Draws a graphical button using the current
' XP visual style
'
Sub DrawButton(ByVal hwnd As Long)
Dim hdc As Long
Dim tPS As PAINTSTRUCT
Dim hTheme As Long, hBR As Long
Dim lState As Long
Dim bChecked As Boolean, bHot As Boolean, bFocused As Boolean
Dim bPushed As Boolean, bNoPicture As Boolean
Dim Button As Object, lFontOld As Long
Dim oPict As IPicture, oFont As IFont
Dim tCR As RECT, tCRText As RECT

   On Error Resume Next

   ' Get the button object
   CopyMemory Button, GetProp(hwnd, "Button"), 4&

   ' Get the button state
   lState = SendMessage(hwnd, BM_GETSTATE, 0&, ByVal 0&)
   bChecked = Button.Value
   bHot = GetProp(hwnd, "Hot")
   bPushed = lState And BST_PUSHED
   bFocused = lState And BST_FOCUS

   ' Get the client rectangle
   GetClientRect hwnd, tCR

   ' Open the theme
   hTheme = OpenThemeData(hwnd, StrPtr("Button"))

   ' Get the button DC
   hdc = BeginPaint(hwnd, tPS)

   ' Fill the background using the
   ' parent window background because
   ' the button can have transparent parts
   hBR = CreateSolidBrush(TranslateColor(Button.Container.BackColor))
   FillRect hdc, tCR, hBR
   DeleteObject hBR

   ' Set the state and picture
   If Button.Enabled = False Then

      lState = 4
      Set oPict = Button.DisabledPicture

      If oPict Is Nothing Then
         Set oPict = Button.Picture
      ElseIf oPict.Handle = 0 Then
         Set oPict = Button.Picture
      End If

   ElseIf bHot And Not bPushed Then

      lState = 2

      If bChecked Then
         Set oPict = Button.DownPicture

         If oPict Is Nothing Then