candybutton.ctl

糖果水晶按钮,这个代码支持XP按钮,XP工具栏按钮。

VERSION 5.00
Begin VB.UserControl CandyButton 
   Appearance      =   0  'Flat
   BackColor       =   &H00FFFFFF&
   ClientHeight    =   1335
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1830
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   9
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   89
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   122
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'None
      Height          =   1215
      Left            =   120
      ScaleHeight     =   81
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   105
      TabIndex        =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   1575
   End
End
Attribute VB_Name = "CandyButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'-Selfsub declarations----------------------------------------------------------------------------
Private Enum eMsgWhen                                                       'When to callback
  MSG_BEFORE = 1                                                            'Callback before the original WndProc
  MSG_AFTER = 2                                                             'Callback after the original WndProc
  MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER                                'Callback before and after the original WndProc
End Enum

Private Const ALL_MESSAGES  As Long = -1                                    'All messages callback
Private Const MSG_ENTRIES   As Long = 32                                    'Number of msg table entries
Private Const WNDPROC_OFF   As Long = &H38                                  'Thunk offset to the WndProc execution address
Private Const GWL_WNDPROC   As Long = -4                                    'SetWindowsLong WndProc index
Private Const IDX_SHUTDOWN  As Long = 1                                     'Thunk data index of the shutdown flag
Private Const IDX_HWND      As Long = 2                                     'Thunk data index of the subclassed hWnd
Private Const IDX_WNDPROC   As Long = 9                                     'Thunk data index of the original WndProc
Private Const IDX_BTABLE    As Long = 11                                    'Thunk data index of the Before table
Private Const IDX_ATABLE    As Long = 12                                    'Thunk data index of the After table
Private Const IDX_PARM_USER As Long = 13                                    'Thunk data index of the User-defined callback parameter data index

Private z_ScMem             As Long                                         'Thunk base address
Private z_Sc(64)            As Long                                         'Thunk machine-code initialised here
Private z_Funk              As Collection                                   'hWnd/thunk-address collection

Private Declare Function CallWindowProcA Lib "user32" (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 GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Public Event Status(ByVal sStatus As String)

Private Const WM_MOUSEMOVE    As Long = &H200
Private Const WM_MOUSELEAVE   As Long = &H2A3
Private Const WM_MOVING       As Long = &H216
Private Const WM_SIZING       As Long = &H214
Private Const WM_EXITSIZEMOVE As Long = &H232

Private Enum TRACKMOUSEEVENT_FLAGS
  TME_HOVER = &H1&
  TME_LEAVE = &H2&
  TME_QUERY = &H40000000
  TME_CANCEL = &H80000000
End Enum

Private Type TRACKMOUSEEVENT_STRUCT
  cbSize                      As Long
  dwFlags                     As TRACKMOUSEEVENT_FLAGS
  hwndTrack                   As Long
  dwHoverTime                 As Long
End Type

Private bTrack                As Boolean
Private bTrackUser32          As Boolean
Private IsHover               As Boolean
Private bMoving               As Boolean

Public Event Click()
Attribute Click.VB_MemberFlags = "200"
Public Event DblClick()
Public Event MouseEnter()
Public Event MouseLeave()
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 MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENT_STRUCT) As Long
Private Declare Function TrackMouseEventComCtl Lib "Comctl32" Alias "_TrackMouseEvent" (lpEventTrack As TRACKMOUSEEVENT_STRUCT) As Long

'-Candy Button declarations----------------------------------------------------------------------------
Public Enum eAlignment
    PIC_TOP
    PIC_BOTTOM
    PIC_LEFT
    PIC_RIGHT
End Enum

Public Enum eStyle
    XP_Button
    XP_ToolBarButton
    Crystal
    Mac
    Mac_Variation
    WMP
    Plastic
End Enum

Public Enum eColorScheme
    Custom
    Aqua
    WMP10
    DeepBlue
    DeepRed
    DeepGreen
    DeepYellow
End Enum

Public Enum eState
    eNormal
    ePressed
    eFocus
    eHover
    eChecked
End Enum

Private Type tCrystalParam
    Ref_MixColorFrom As Long
    Ref_Intensity As Long
    Ref_Left As Long
    Ref_Top As Long
    Ref_Radius As Long
    Ref_Height As Long
    Ref_Width As Long
    RadialGXPercent As Long
    RadialGYPercent As Long
End Type

Private m_PictureAlignment As eAlignment
Private m_Style As eStyle
Private m_Checked As Boolean
Private m_hasFocus As Boolean
Private m_Caption As String
Private m_StdPicture As StdPicture
Private m_Font As StdFont
Private m_ColorButtonHover As OLE_COLOR
Private m_ColorButtonUp As OLE_COLOR
Private m_ColorButtonDown As OLE_COLOR
Private m_ColorBright As OLE_COLOR
Private m_ForeColor As OLE_COLOR
Private m_DisplayHand As Boolean
Private CornerRadius As Long
Private m_BorderBrightness As Long
Private m_ColorScheme As eColorScheme

Private Const m_def_ForeColor = vbBlack
Private Const m_def_PictureAlignment = 0

Private Const RGN_XOR = 3

Private Const MK_LBUTTON = &H1

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPointXY Lib "user32" Alias "WindowFromPoint" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Property Let DisplayHand(newValue As Boolean)
    m_DisplayHand = newValue
End Property

Public Property Get DisplayHand() As Boolean
    DisplayHand = m_DisplayHand
End Property

Public Property Let ColorScheme(newValue As eColorScheme)
    Select Case newValue
        Case Aqua
            ColorButtonUp = &HD06720
            ColorButtonHover = &HE99950
            ColorButtonDown = &HA06710
            ColorBright = &HFFEDB0
        Case WMP10
            ColorButtonUp = &HD09060
            ColorButtonHover = &HE06000
            ColorButtonDown = &HA98050
            ColorBright = &HFFFAFA
        Case DeepBlue
            ColorButtonUp = &H800000
            ColorButtonHover = &HA00000
            ColorButtonDown = &HF00000
            ColorBright = &HFF0000
        Case DeepRed
            ColorButtonUp = &H80&
            ColorButtonHover = &HA0&
            ColorButtonDown = &HF0&
            ColorBright = &HFF&
        Case DeepGreen
            ColorButtonUp = &H8000&
            ColorButtonHover = &HA000&
            ColorButtonDown = &HC000&
            ColorBright = &HFF00&
        Case DeepYellow
            ColorButtonUp = &H8080&
            ColorButtonHover = &HA0A0&
            ColorButtonDown = &HC0C0&
            ColorBright = &HFFFF&
    End Select
    m_ColorScheme = newValue
    PropertyChanged "m_ColorScheme"
    DrawButton (eNormal)
End Property

Public Property Get ColorScheme() As eColorScheme
    ColorScheme = m_ColorScheme
End Property

Public Property Let BorderBrightness(newValue As Long)
    m_BorderBrightness = SetBound(newValue, -100, 100)
    PropertyChanged "m_BorderBrightness"
    DrawButton (eNormal)
End Property

Public Property Get BorderBrightness() As Long
    BorderBrightness = m_BorderBrightness
End Property

Public Property Let ColorBright(newValue As OLE_COLOR)
    m_ColorBright = newValue
    If m_ColorScheme <> Custom Then m_ColorScheme = Custom:  PropertyChanged "m_ColorScheme"
    PropertyChanged "m_ColorBright"
    DrawButton (eNormal)
End Property

Public Property Get ColorBright() As OLE_COLOR
    ColorBright = m_ColorBright