浏览器

开发平台：
Visual Basic

cButton.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'---------------------------------------------------------------------------------------
' Module    : cButton
' DateTime  :
' Author    : Lingll
' Purpose   : 在picturebox上画按钮
'               draw a button on picturebox
'---------------------------------------------------------------------------------------
'8/5/2005 : 修正了api中 byval * as string 的问题
Option Explicit
'确保strconv能正确转换
Private Const LocaleID_SC As Long = 2052&    '简中
Private Const LocaleID_CurUse As Long = LocaleID_SC
'===================================================
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID As Long = 0
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Const BLACK_PEN As Long = 7
Private Const DEFAULT_GUI_FONT As Long = 17
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap 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 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 SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Const TRANSPARENT As Long = 1
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Const LF_FACESIZE As Long = 32
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(1 To LF_FACESIZE) As Byte
End Type
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Private Type TEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet As Byte
End Type
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Const DI_NORMAL As Long = &H3
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type
Private Declare Function GetObjectApi Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
'Private Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, lpDrawTextParams As DRAWTEXTPARAMS) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_LEFT As Long = &H0
Private Const DT_CENTER As Long = &H1
Private Const DT_VCENTER As Long = &H4
Private Const DT_SINGLELINE As Long = &H20
Private Const DT_BOTTOM As Long = &H8
'Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
'Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
    x As Long
    y As Long
End Type
'Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal HMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
'Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
'Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
'Private Declare Function GetCapture Lib "user32" () 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 SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Const COLOR_BTNSHADOW As Long = 16
Private Const COLOR_BTNHIGHLIGHT As Long = 20
Private Const COLOR_BTNFACE = 15
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 Const SRCCOPY = &HCC0020
Private Const WM_USER = &H400
Private Const CW_USEDEFAULT = &H80000000
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOMOVE = &H2
Private Const HWND_TOPMOST = -1
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Const TTS_NOPREFIX = &H2
'Private Const TTF_TRANSPARENT = &H100
'Private Const TTF_CENTERTIP = &H2
Private Const TTM_ADDTOOLA = (WM_USER + 4)
'Private Const TTM_ACTIVATE = WM_USER + 1
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
'Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
'Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Private Const TTM_SETTITLE = (WM_USER + 32)
Private Const TTS_BALLOON = &H40
Private Const TTS_ALWAYSTIP = &H1
Private Const TTF_SUBCLASS = &H10
Private Const TTF_CENTERTIP = &H2
Private Const TOOLTIPS_CLASSA = "tooltips_class32"
Private Type TOOLINFO
    lSize As Long
    lFlags As Long
    lHwnd As Long
    lId As Long
    lpRect As RECT
    hInstance As Long
    lpStr As String
    lParam As Long
End Type
'#########################################################
Private hTip As Long
Private preButton As Integer, preOut As Boolean
Private mButton As Integer
Private mParent As Object
'Private WithEvents BtnFace As PictureBox
Private mHdc As Long
Private mBffImg As cImgEx
'####################################################
'缺省属性值:
Const m_def_Selected = False
Const m_def_Caption = ""
Const m_def_TipText = ""
'属性变量:
Dim m_Left As Long
Dim m_Top As Long
Dim m_Width As Long
Dim m_Height As Long
Dim m_RightBorder As Boolean
Dim m_Selected As Boolean
Dim m_Caption As String
Public m_TipText As String
Private m_TipTitle As String
Dim m_Center As Boolean
Private mImageNormal As StdPicture
Private mImageOver As StdPicture
'水平方向间隔
Private mHPading As Long
'垂直方向间隔
Private mVPading As Long
'Tip Title 最大长度
Private Const MaxTipTitle As Long = 96
'按钮状态
Public Enum cbeButtonState
    cbtnNull = -1
    cbtnNormal = 0
    cbtnPress = 1
    cbtnOver = 2
    cbtnChecked = 3
End Enum
'按钮类型
Public Enum cbeButtonStyle
    cbtsNormal = 0
    cbtsCheck = 1
End Enum
Dim Color_Shadow As Long
Dim Color_Light As Long
Dim Color_ButtonFace As Long
'按钮全区域
Private mBtnFullRc As RECT
'文字区域
Private mTextRc As RECT
'图标区域
Private mPctRc As RECT
'灰区域
Private mGrayRc As RECT
'按钮区域
Private mBtnRc As RECT
'按钮区域2,相对于外部
Private mBtnRcOut As RECT
'右边间隔条宽度
Private Const mRightBorderWidth& = 6
Private mPctWidth As Long
Private mPctHeight As Long
'按钮状态
Private mButtonState As cbeButtonState
Private m_Checked As Boolean
Private m_Style As cbeButtonStyle
Private mCreated As Boolean
'装载自己的容器
Private mParentBar As cButtonBar
Public TagS As String
Public TagL As Long
Public index As Long
'按钮状态
Public Property Let ButtonState(ByVal vData As cbeButtonState)
'used when assigning an Object to the property, on the left side of a Set statement.
'Syntax: Set x.ButtonState = Form1
    If mButtonState <> vData Then
        mButtonState = vData
        Call DrawButton(mButtonState)
    End If
End Property
Public Property Get ButtonState() As cbeButtonState
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.ButtonState
    ButtonState = mButtonState
End Property
'计算各种区域
Private Sub GetRectZZ()
With mBtnFullRc
    .Left = m_Left
    .Top = m_Top
    .Right = m_Left + m_Width - 1
    .Bottom = m_Top + m_Height - 1
End With
With mBtnRcOut
    .Left = m_Left
    .Top = m_Top
    If m_RightBorder Then
        .Right = mBtnFullRc.Right - mRightBorderWidth
    Else
        .Right = mBtnFullRc.Right
    End If
    .Bottom = mBtnFullRc.Bottom
End With
With mBtnRc
    .Left = 0
    .Top = 0
    If m_RightBorder Then
        .Right = m_Width - 1 - mRightBorderWidth
    Else
        .Right = m_Width - 1
    End If
    .Bottom = m_Height - 1
End With
With mGrayRc
    .Left = 1
    .Top = 1
    .Right = mBtnRc.Right - 1
    .Bottom = mBtnRc.Bottom - 1
End With
If mPctWidth > 0 And mPctHeight > 0 Then
    With mPctRc
        .Top = mGrayRc.Top + 2 + mVPading
        .Left = mGrayRc.Left + 2 + mHPading
        
        .Right = .Left + mPctWidth
        If .Right > mGrayRc.Right - 2 - mHPading Then
            .Right = mGrayRc.Right - 2 - mHPading
        End If
        
        .Bottom = .Top + mPctHeight
        If .Bottom > mGrayRc.Bottom - 2 - mVPading Then
            .Bottom = mGrayRc.Bottom - 2 - mVPading
        End If
    End With
Else
    With mPctRc
        .Top = mGrayRc.Top
        .Left = mGrayRc.Left
        .Right = .Left
        .Bottom = .Top
    End With
End If
With mTextRc
    .Left = mPctRc.Right + 2 + mHPading
    .Top = mGrayRc.Top + 2 + mVPading
    .Bottom = mGrayRc.Bottom - 2 - mVPading
    .Right = mGrayRc.Right - 2 - mHPading
End With
End Sub
'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,
Public Property Get Caption() As String
    Caption = m_Caption
End Property
Public Property Let Caption(ByVal New_Caption As String)
If m_Caption <> New_Caption Then
    m_Caption = New_Caption
    Call DrawButton(mButtonState)
End If
End Property
Public Sub DrawButton(ByVal State As cbeButtonState)
If Not mCreated Then Exit Sub
mBffImg.SetColor Color_ButtonFace
If State <> cbtnNull Then
    If m_Checked Then
        If m_Style = cbtsCheck Then
            State = cbtnChecked
        Else
            State = cbtnPress
        End If
    End If
    
    If State = cbtnChecked Then
        GrayButton mBffImg.hdc
    End If
    
    DrawPicture mBffImg.hdc, State
    PrintText mBffImg.hdc, m_Caption, State
    
    DrawOutLine mBffImg.hdc, State
    
    If m_RightBorder Then DrawRightBorder mBffImg.hdc
    
    If m_Selected Then DrawSelect mBffImg.hdc
End If
Call RePaint
End Sub
'api方式的draw line
Private Sub LineHdc(nHdc&, X1&, Y1&, X2&, Y2&, color&)
Dim tHdc&, tBsh&, tPreObj&
tBsh = CreatePen(PS_SOLID, 1, color)
tPreObj = SelectObject(nHdc, tBsh)
Call MoveToEx(nHdc, X1, Y1, ByVal 0&)
Call LineTo(nHdc, X2, Y2)
DeleteObject SelectObject(nHdc, GetStockObject(BLACK_PEN))
'If tBsh <> 0 Then Debug.Print "delete "; DeleteObject(tBsh)
End Sub
Private Sub DrawLine(nHdc&, nw&, nh&, C1 As Long, C2 As Long)
Dim tHdc&
tHdc = nHdc
With mBtnRc
    LineHdc tHdc, .Left, .Top, .Right + 1, .Top, C1
    LineHdc tHdc, .Left, .Top, .Left, .Bottom + 1, C1
    
    LineHdc tHdc, .Right, .Bottom, .Right, .Top, C2
    LineHdc tHdc, .Right, .Bottom, .Left, .Bottom, C2
End With
End Sub
'画按钮显现的3d部分
Private Sub DrawOutLine(nHdc&, State As cbeButtonState)
If State = cbtnChecked Or State = cbtnPress Then
    Call DrawLine(nHdc, m_Width, m_Height, _
        Color_Shadow, Color_Light)
ElseIf State = cbtnOver Then
    Call DrawLine(nHdc, m_Width, m_Height, _
        Color_Light, Color_Shadow)
End If
End Sub
'被选择了
Private Sub DrawSelect(nHdc&)
Dim tBsh&
Const tClr As Long = 15168858
tBsh = CreatePen(PS_SOLID, 1, tClr)
SelectObject nHdc, tBsh
MoveToEx nHdc, mGrayRc.Left, mGrayRc.Top, ByVal 0&
LineTo nHdc, mGrayRc.Right, mGrayRc.Top
LineTo nHdc, mGrayRc.Right, mGrayRc.Bottom
LineTo nHdc, mGrayRc.Left, mGrayRc.Bottom
LineTo nHdc, mGrayRc.Left, mGrayRc.Top
DeleteObject SelectObject(nHdc, GetStockObject(BLACK_PEN))
End Sub
Private Sub GrayButton(nHdc&)
'Dim trc As RECT
'Call SetRect(trc, 1, 1, m_Width - 1, m_Height - 1)
GrayRect nHdc, mGrayRc
End Sub
Private Sub GrayRect(nHdc&, nRc As RECT)
Dim tGray As cImgEx
Dim tbr&, x&, y&
Dim tRc As RECT
Set tGray = New cImgEx
tGray.Create 4, 4, nHdc, Color_ButtonFace
For y = 0 To 3
    For x = 0 To 3 Step 2
        If y Mod 2 = 0 Then
            Call SetPixelV(tGray.hdc, x, y, Color_Light)
        Else
            Call SetPixelV(tGray.hdc, x + 1, y, Color_Light)
        End If
    Next x
Next y
tRc = nRc
tRc.Bottom = tRc.Bottom + 1
tRc.Right = tRc.Right + 1
tbr = CreatePatternBrush(tGray.hBmp)
Call FillRect(nHdc, tRc, tbr)
Call DeleteObject(tbr)
End Sub
Private Sub PrintText(nHdc&, nStr$, State As cbeButtonState)
Dim tRc As RECT
Dim offset As Long
If nStr = "" Then Exit Sub
Select Case State
    Case cbtnNormal
        offset = 0
    Case cbtnOver
        offset = 0 '-1
    Case cbtnPress, cbtnChecked
        offset = 1
End Select
SetRect tRc, mTextRc.Left + offset, mTextRc.Top + offset, _
        mTextRc.Right + offset, mTextRc.Bottom + offset
DrawText nHdc, StrPtr(StrConv(nStr, vbFromUnicode, LocaleID_CurUse)), _
        -1, tRc, DT_LEFT Or DT_BOTTOM Or DT_SINGLELINE
End Sub
'初始化
Public Sub CreateFace(nHdc&, x&, y&, cx&, cy&, _
    Optional nParentBar As cButtonBar)
Call Destory
mHdc = nHdc
    
m_Left = x
m_Top = y
m_Width = cx
m_Height = cy
'mPctHeight = imgH
'mPctWidth = imgW
Call RefreshColor
Call GetRectZZ
Call IniBffImg
Set mParentBar = nParentBar
mCreated = True
End Sub
'初始化缓冲img
Private Sub IniBffImg()
If mCreated Then
    DeleteObject SelectObject(mBffImg.hdc, GetStockObject(BLACK_PEN))
End If
Set mBffImg = New cImgEx
mBffImg.Create m_Width, m_Height, mHdc, COLOR_BTNFACE
SetBkMode mBffImg.hdc, TRANSPARENT
SelectObject mBffImg.hdc, CreateFont("宋体")
End Sub
'是否在内
Public Function InMe(ByVal x&, ByVal y&) As Boolean
'InMe = x >= m_Left And x <= m_Left + m_Width And _
    y >= m_Top And y <= m_Top + m_Height
InMe = x >= mBtnRcOut.Left And x <= mBtnRcOut.Right And _
    y >= mBtnRcOut.Top And y <= mBtnRcOut.Bottom
End Function
Private Sub Class_Initialize()
Call RefreshColor
mButtonState = cbtnNull
m_RightBorder = False
mCreated = False
m_Checked = False
m_Style = cbtsNormal
End Sub
'创建字体
Private Function CreateFont(fName As String) As Long
Dim lf As LOGFONT, tm As TEXTMETRIC
Dim tstr$
GetTextMetrics mHdc, tm
With lf
    tstr = StrConv(fName, vbFromUnicode)
    CopyMemory ByVal VarPtr(.lfFaceName(1)), ByVal StrPtr(tstr), LenB(tstr)
    .lfCharSet = 134
    .lfHeight = 12 ' tm.tmHeight
End With
CreateFont = CreateFontIndirect(lf)
End Function
Private Sub DrawPicture(nHdc&, State As cbeButtonState)
Dim tImg As cImgEx
Dim offset&, tPct As StdPicture
If mPctHeight > 0 And mPctWidth > 0 Then
    Select Case State
        Case cbtnNormal
            offset = 0
            Set tPct = mImageNormal
        Case cbtnOver
            offset = 0 ' -1
            Set tPct = mImageOver
        Case cbtnPress, cbtnChecked
            offset = 1
            Set tPct = mImageNormal
    End Select
    If tPct Is Nothing Then Set tPct = mImageNormal
    If Not tPct Is Nothing Then
        Set tImg = New cImgEx
        tImg.Create mPctWidth, mPctHeight, nHdc
        BitBlt tImg.hdc, 0, 0, mPctWidth, mPctHeight, _
                nHdc, mPctRc.Left + offset, mPctRc.Top + offset, SRCCOPY
        Call DrawPicture2(tImg, tPct)
        BitBlt nHdc, mPctRc.Left + offset, mPctRc.Top + offset, mPctWidth, mPctHeight, _
             tImg.hdc, 0, 0, SRCCOPY
    End If
End If
End Sub
Private Sub DrawPicture2(nImg As cImgEx, npct As StdPicture)
Dim tIfo As ICONINFO
Dim tBmp As BITMAP
If npct.Type = vbPicTypeIcon Then
    GetIconInfo npct.handle, tIfo
    GetObjectApi tIfo.hbmColor, Len(tBmp), tBmp
    DrawIconEx nImg.hdc, 0, 0, npct.handle, tBmp.bmWidth, tBmp.bmHeight, 0, 0, DI_NORMAL
    DeleteObject tIfo.hbmColor
    DeleteObject tIfo.hbmMask
ElseIf npct.Type = vbPicTypeBitmap Then
    'nImg.CopyByBmp npct.handle
    DrawMaskImage npct.handle, nImg.hdc, RGB(255, 0, 255)
End If
End Sub
'获得图像大小
Private Sub GetImageSize(npct As StdPicture, nw&, nh&)
Dim tIfo As ICONINFO
Dim tBmp As BITMAP
If npct Is Nothing Then
    nw = 0: nh = 0
Else
    If npct.Type = vbPicTypeIcon Then
        GetIconInfo npct.handle, tIfo
        GetObjectApi tIfo.hbmColor, Len(tBmp), tBmp
        nw = tBmp.bmWidth: nh = tBmp.bmHeight
        DeleteObject tIfo.hbmColor
        DeleteObject tIfo.hbmMask
    ElseIf npct.Type = vbPicTypeBitmap Then
        GetObjectApi npct.handle, Len(tBmp), tBmp
        nw = tBmp.bmWidth: nh = tBmp.bmHeight
    End If
End If
End Sub
Public Property Get ImageNormal() As StdPicture
Set ImageNormal = mImageNormal
End Property
Public Property Set ImageNormal(vNewValue As StdPicture)
Set mImageNormal = vNewValue
Call GetImageSize(mImageNormal, mPctWidth, mPctHeight)
Call Refresh
End Property
Public Property Get ImageOver() As StdPicture
Set ImageOver = mImageOver
End Property
Public Property Set ImageOver(vNewValue As StdPicture)
Set mImageOver = vNewValue
Call Refresh
End Property
'重新获得系统颜色
Private Sub RefreshColor()
Color_Shadow = GetSysColor(COLOR_BTNSHADOW)
Color_Light = GetSysColor(COLOR_BTNHIGHLIGHT)
Color_ButtonFace = GetSysColor(COLOR_BTNFACE)
End Sub
Private Sub DrawRightBorder(nHdc&)
LineHdc nHdc, mBtnRc.Right + 3, mBtnRc.Top, mBtnRc.Right + 3, mBtnRc.Bottom, Color_Shadow
LineHdc nHdc, mBtnRc.Right + 4, mBtnRc.Top, mBtnRc.Right + 4, mBtnRc.Bottom, Color_Light
End Sub
'Tool Tip 标题
Public Property Get TipTitle() As String
TipTitle = m_TipTitle
End Property
Public Property Let TipTitle(ByVal vNewValue As String)
If m_TipTitle <> vNewValue Then
    m_TipTitle = vNewValue
    Call ChangeTip
End If
'Dim tStr$
'tStr = StrConv(vNewValue, vbFromUnicode)
'If LenB(tStr) > MaxTipTitle Then
'    m_TipTitle = Replace(StrConv(LeftB$(tStr, MaxTipTitle), vbUnicode), Chr(0), "") & "..."
'Else
'    m_TipTitle = vNewValue
'End If
End Property
Public Property Get tiptext() As String
tiptext = m_TipText
End Property
Public Property Let tiptext(ByVal vNewValue As String)
If m_TipText <> vNewValue Then
    m_TipText = vNewValue
    Call ChangeTip
End If
End Property
'调用parent bar ,改变Tip
Private Sub ChangeTip()
Dim tstr$
If Not mParentBar Is Nothing Then
    mParentBar.UpdateTipText index, GetCombinTipText
End If
End Sub
'将TipTitle 与TipText合并
Public Function GetCombinTipText() As String
If m_TipTitle = "" Then
    GetCombinTipText = m_TipText
End If
If m_TipText = "" Then
    GetCombinTipText = m_TipTitle
End If
If m_TipText <> "" And m_TipTitle <> "" Then
    GetCombinTipText = m_TipTitle & vbNewLine & m_TipText
End If
End Function
Public Property Get HPading() As Long
HPading = mHPading
End Property
Public Property Let HPading(ByVal vNewValue As Long)
mHPading = vNewValue
End Property
Public Property Get VPading() As Long
VPading = mVPading
End Property
Public Property Let VPading(ByVal vNewValue As Long)
mVPading = vNewValue
End Property
Private Sub Class_Terminate()
Call Destory
End Sub
Public Sub Destory()
mCreated = False
mHdc = 0
    
m_Left = 0
m_Top = 0
m_Width = 0
m_Height = 0
mPctHeight = 0
mPctWidth = 0
mButtonState = cbtnNull
Set mParentBar = Nothing
If Not mBffImg Is Nothing Then
    DeleteObject SelectObject(mBffImg.hdc, GetStockObject(DEFAULT_GUI_FONT))
End If
End Sub
Public Sub RePaint()
If mCreated Then
    BitBlt mHdc, m_Left, m_Top, m_Width, m_Height, mBffImg.hdc, 0, 0, SRCCOPY
End If
End Sub
Public Property Get Left() As Long
Left = m_Left
End Property
Friend Property Let Left(ByVal vNewValue As Long)
If m_Left <> vNewValue Then
    m_Left = vNewValue
    Call Refresh
End If
End Property
Public Property Get Top() As Long
Top = m_Top
End Property
Friend Property Let Top(ByVal vNewValue As Long)
If m_Top <> vNewValue Then
    m_Top = vNewValue
    Call Refresh
End If
End Property
Public Property Get width() As Long
width = m_Width
End Property
Friend Property Let width(ByVal vNewValue As Long)
If vNewValue > 0 And m_Width <> vNewValue Then
    m_Width = vNewValue
    Call IniBffImg
    Call Refresh
End If
End Property
Public Property Get height() As Long
height = m_Height
End Property
Friend Property Let height(ByVal vNewValue As Long)
If vNewValue > 0 And m_Height <> vNewValue Then
    m_Height = vNewValue
    Call IniBffImg
    Call Refresh
End If
End Property
Public Property Get RightBorder() As Boolean
RightBorder = m_RightBorder
End Property
Public Property Let RightBorder(ByVal vNewValue As Boolean)
m_RightBorder = vNewValue
Call Refresh
End Property
Friend Sub Move(nLeft&, nTop&, _
        Optional nWidth&, Optional nHeight&)
Dim tSized As Boolean
tSized = False
If m_Left <> nLeft Then m_Left = nLeft
If m_Top <> nTop Then m_Top = nTop
    
If nWidth > 0 Then
    If m_Width <> nWidth Then
        m_Width = nWidth
        tSized = True
    End If
End If
If nHeight > 0 Then
    If m_Height <> nHeight Then
        m_Height = nHeight
        tSized = True
    End If
End If
        
Call IniBffImg
Call Refresh
End Sub
    
Public Sub Refresh()
Call RefreshColor
Call GetRectZZ
Call DrawButton(mButtonState)
End Sub
Public Property Get Selected() As Boolean
Selected = m_Selected
End Property
Public Property Let Selected(ByVal vNewValue As Boolean)
If m_Selected <> vNewValue Then
    m_Selected = vNewValue
    Call Refresh
End If
End Property
Public Property Get Checked() As Boolean
Checked = m_Checked
End Property
Public Property Let Checked(ByVal vNewValue As Boolean)
If m_Checked <> vNewValue Then
    m_Checked = vNewValue
    Call Refresh
End If
End Property
Public Property Get Style() As cbeButtonStyle
Style = m_Style
End Property
Public Property Let Style(ByVal vNewValue As cbeButtonStyle)
If m_Style <> vNewValue Then
    m_Style = vNewValue
    If m_Checked Then
        Call Refresh
    End If
End If
End Property
'获得按钮可用区域
Public Sub GetButtonLprect(lpRect As Long)
CopyMemory ByVal lpRect, ByVal VarPtr(mBtnRcOut), Len(mBtnRcOut)
End Sub

						