浏览器

开发平台：
Visual Basic

cButtonBar.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 = "cButtonBar"
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"
Attribute VB_Ext_KEY = "Member0" ,"cButtons"
Option Explicit
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
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 Const SWP_NOZORDER As Long = &H4
'Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor 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 TTM_SETTOOLINFOA As Long = (WM_USER + 9)
Private Const TTM_NEWTOOLRECTA As Long = (WM_USER + 6)
Private Const TTM_DELTOOLA As Long = (WM_USER + 5)
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 WithEvents mPctBox As PictureBox
Attribute mPctBox.VB_VarHelpID = -1
'tool tip hwnd
Private mHTip As Long
Private m_TipTitle As String
Private m_TipText As String
'按钮集合
Private mvarButtons As Collection
Private mvarAutoRaidoCheck As Boolean
'容器的长宽
Private mMeWidth&, mMeHeight&
'左键点击时的按钮
Private mActiveBtn As cButton
'按钮宽度
Private m_ButtonWidth As Long
'按钮高度
Private m_ButtonHeight  As Long
'按钮数量
Private mButtonCount As Long
'上一个按钮
Private mPreButton As cButton
'是否已经创建
Private mCreated As Boolean
Public Event MouseDown(Button As Integer, Shift As Integer, X As Long, Y As Long, btn As cButton)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Long, Y As Long, btn As cButton)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Long, Y As Long, btn As cButton)
Public Event DblClick(X&, Y&)
Public Event DragDrop(X&, Y&)
Public Function Buttons() As Collection
Set Buttons = mvarButtons
End Function
'index,1 base
Public Function Add(Optional nCaption$, Optional nStyle As cbeButtonStyle = cbtsNormal, Optional nTagL&, _
        Optional sKey As String, Optional sIndex As Long = -1) As cButton
If mCreated Then
    Dim objNewMember As cButton
    
    Dim tLeft&, tLeft2&, tBtn As cButton
    Dim tRc As RECT
    
    Set objNewMember = New cButton
    If sIndex < 1 Or sIndex > mButtonCount + 1 Then
        sIndex = mButtonCount + 1
    Else
        For Each tBtn In mvarButtons
            If tBtn.index >= sIndex Then
                tBtn.Left = tBtn.Left + m_ButtonWidth
                tBtn.index = tBtn.index + 1
            End If
        Next tBtn
    End If
               
    mPctBox.Visible = True
    If Len(sKey) = 0 Then
        mvarButtons.Add objNewMember
    Else
        mvarButtons.Add objNewMember, sKey
    End If
    mButtonCount = mButtonCount + 1
    Call SizeBar
    
    With objNewMember
        .Caption = nCaption
        .Style = nStyle
        .TagL = nTagL
        .index = sIndex
        .CreateFace mPctBox.hdc, (sIndex - 1) * m_ButtonWidth, 0, m_ButtonWidth, m_ButtonHeight, Me
        .RightBorder = True
        .ButtonState = cbtnNormal
        
        .GetButtonLprect VarPtr(tRc)
        AddTip mButtonCount, "", tRc
    End With
    Call UpdateAllTipRect
    Call UpdateAllTipText
    
    'return the object created
    Set Add = objNewMember
    Set objNewMember = Nothing
    
End If
End Function
'集合上的remove
Public Sub Remove(vntIndexKey As Variant)
On Error Resume Next
Dim tBtn As cButton
Dim tIndex&, tWidth&
Set tBtn = mvarButtons(vntIndexKey)
If Not tBtn Is Nothing Then
    tIndex = tBtn.index
    Call RemoveByIndex(tIndex)
End If
End Sub
'按"按钮排列顺序(index) 来 remove
Public Sub RemoveByIndex(vntIndex As Long)
Dim i&, tcnt&
Dim tBtn As cButton
If vntIndex > 0 And vntIndex <= mButtonCount Then
    tcnt = mButtonCount
    mPctBox.Cls
    For i = tcnt To 1 Step -1
        Set tBtn = mvarButtons(i)
        If tBtn.index > vntIndex Then
            tBtn.index = tBtn.index - 1
            tBtn.Left = tBtn.Left - m_ButtonWidth
        ElseIf tBtn.index = vntIndex Then
            mvarButtons.Remove i
            If mActiveBtn Is tBtn Then
                Set mActiveBtn = Nothing
            End If
            If mPreButton Is tBtn Then
                Set mPreButton = Nothing
            End If
            mButtonCount = mButtonCount - 1
            tBtn.Destory
            Set tBtn = Nothing
        Else
            tBtn.RePaint
        End If
        
        Set tBtn = Nothing
    Next i
    Call SizeBar
    Call DelTip(mButtonCount + 1)
    Call UpdateAllTipRect
    Call UpdateAllTipText
End If
End Sub
''删除指定的"按钮",参数是就是按钮本身
'Public Sub RemoveByButtonObj(btnObj As cButton)
'Dim tBtn As cButton
'If Not btnObj Is Nothing Then
'    For Each tBtn In mvarButtons
'        If btnObj Is tBtn Then
'            RemoveByIndex tBtn.index
'            Exit Sub
'        End If
'    Next tBtn
'End If
'End Sub
'
Public Sub Clear()
'Dim i&
Set mPreButton = Nothing
Set mActiveBtn = Nothing
Set mvarButtons = New Collection
'For i = mButtonCount To 1 Step -1
'    mvarButtons.Remove i
'Next i
mButtonCount = 0
End Sub
'交换按钮,其他按钮不作调整
Public Sub SwitchButton(index1&, index2&)
Dim tBtn As cButton
Dim sB1 As cButton, sB2 As cButton
Dim tExit&, tLeft&
If index1 > 0 And index1 <= mButtonCount And _
        index2 > 0 And index2 <= mButtonCount Then
    tExit = 0
    For Each tBtn In mvarButtons
        If tBtn.index = index1 Then
            Set sB1 = tBtn
            tExit = tExit + 1
        ElseIf tBtn.index = index2 Then
            Set sB2 = tBtn
            tExit = tExit + 1
        End If
        If tExit >= 2 Then Exit For
    Next tBtn
    If (Not sB1 Is Nothing) And (Not sB2 Is Nothing) Then
        tLeft = sB1.Left
        sB1.index = index2
        sB2.index = index1
        sB1.Left = sB2.Left
        sB2.Left = tLeft
        sB1.RePaint
        sB2.RePaint
    End If
    Call UpdateAllTipText
End If
End Sub
'移动按钮,附件的按钮做相应调整
Public Sub MoveButton(nFromIndex&, nToIndex&)
Dim tBtn As cButton
If nFromIndex > 0 And nFromIndex <= mButtonCount And _
        nToIndex > 0 And nToIndex <= mButtonCount Then
    If nFromIndex > nToIndex Then
        For Each tBtn In mvarButtons
            If tBtn.index >= nToIndex And tBtn.index < nFromIndex Then
                tBtn.index = tBtn.index + 1
                tBtn.Left = tBtn.Left + m_ButtonWidth
            ElseIf tBtn.index = nFromIndex Then
                tBtn.index = nToIndex
                tBtn.Left = (nToIndex - 1) * m_ButtonWidth
            End If
        Next tBtn
    ElseIf nFromIndex < nToIndex Then
        For Each tBtn In mvarButtons
            If tBtn.index <= nToIndex And tBtn.index > nFromIndex Then
                tBtn.index = tBtn.index - 1
                tBtn.Left = tBtn.Left - m_ButtonWidth
            ElseIf tBtn.index = nFromIndex Then
                tBtn.index = nToIndex
                tBtn.Left = (nToIndex - 1) * m_ButtonWidth
            End If
        Next tBtn
    End If
    Call UpdateAllTipText
End If
End Sub
Public Function SelectButton(nFromIndex&, nToIndex&) As Long
Dim tBtn As cButton
If nFromIndex > 0 And nFromIndex <= mButtonCount And _
        nToIndex > 0 And nToIndex <= mButtonCount Then
    If nFromIndex >= nToIndex Then
        For Each tBtn In mvarButtons
            If tBtn.index >= nToIndex And tBtn.index <= nFromIndex Then
                tBtn.Selected = True
            Else
                tBtn.Selected = False
            End If
        Next tBtn
    ElseIf nFromIndex < nToIndex Then
        For Each tBtn In mvarButtons
            If tBtn.index <= nToIndex And tBtn.index >= nFromIndex Then
                tBtn.Selected = True
            Else
                tBtn.Selected = False
            End If
        Next tBtn
    End If
    SelectButton = Abs(nFromIndex - nToIndex) + 1
Else
    For Each tBtn In mvarButtons
        tBtn.Selected = False
    Next tBtn
End If
End Function
Public Sub IniMe(npct As PictureBox)
Set mPctBox = npct
With mPctBox
    .ScaleMode = vbPixels
    .BorderStyle = 0
End With
m_TipText = ""
m_TipTitle = ""
Call CreateTip
mCreated = True
End Sub
'================= ToolTip 相关 ===========================
Private Function CreateTip() As Boolean
Dim lWinStyle As Long
If mHTip <> 0 Then
    DestroyWindow mHTip
End If
lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX Or TTS_BALLOON
mHTip = CreateWindowEX(0&, _
            TOOLTIPS_CLASSA, _
            vbNullString, _
            lWinStyle, _
            CW_USEDEFAULT, _
            CW_USEDEFAULT, _
            CW_USEDEFAULT, _
            CW_USEDEFAULT, _
            mPctBox.hwnd, _
            0&, _
            App.hInstance, _
            0&)
SetWindowPos mHTip, _
    HWND_TOPMOST, _
    0&, _
    0&, _
    0&, _
    0&, _
    SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
SendMessageAny mHTip, TTM_SETMAXTIPWIDTH, 0, 0
End Function
'添加tip
Private Sub AddTip(id&, nTxt$, nRc As RECT)
Dim lpRect As RECT
Dim ti As TOOLINFO
GetClientRect mPctBox.hwnd, lpRect
With ti
    .lSize = Len(ti)
    .lFlags = TTF_SUBCLASS 'Or TTF_CENTERTIP
    .lpStr = nTxt
    .lHwnd = mPctBox.hwnd
    .lId = id
    '.hInstance = App.hInstance
    .lpRect = nRc
End With
SendMessageAny mHTip, TTM_ADDTOOLA, 0&, ti
End Sub
'删除
Private Sub DelTip(id&)
Dim ti As TOOLINFO
With ti
    .lSize = Len(ti)
    .lHwnd = mPctBox.hwnd
    .lId = id
End With
SendMessageAny mHTip, TTM_DELTOOLA, 0&, ti
End Sub
'更新tip text
Friend Sub UpdateTipText(id&, nText$)
Dim ti As TOOLINFO
With ti
    .lSize = Len(ti)
    .lpStr = nText
    .lHwnd = mPctBox.hwnd
    .lId = id
End With
SendMessageAny mHTip, TTM_UPDATETIPTEXTA, 0&, ti
End Sub
Private Sub UpdateAllTipText()
Dim tBtn As cButton
For Each tBtn In mvarButtons
    UpdateTipText tBtn.index, tBtn.GetCombinTipText
Next tBtn
End Sub
'更新tip 区域
Private Sub UpdateTipRect(id&, nRc As RECT)
Dim ti As TOOLINFO
With ti
    .lSize = Len(ti)
    .lHwnd = mPctBox.hwnd
    .lId = id
    .lpRect = nRc
End With
SendMessageAny mHTip, TTM_NEWTOOLRECTA, 0&, ti
End Sub
Private Sub UpdateAllTipRect()
Dim tRc As RECT
Dim tBtn As cButton
If mHTip <> 0 Then
    For Each tBtn In mvarButtons
        tBtn.GetButtonLprect VarPtr(tRc)
        UpdateTipRect tBtn.index, tRc
    Next tBtn
End If
End Sub
'更新tip title,暂时无用
Private Sub ChangeTipTitle(nStr$)
If mHTip <> 0 Then
    Debug.Print "tiptitle", SendMessageAny(mHTip, TTM_SETTITLE, 0&, ByVal nStr)
End If
End Sub
'激活|停用tip
Public Sub ActiveTip(nActive As Long)
SendMessageAny mHTip, TTM_ACTIVATE, nActive, 0
End Sub
'=============================================================
Private Sub Class_Initialize()
mCreated = False
Set mvarButtons = New Collection
mButtonCount = 0
Set mPreButton = Nothing
m_ButtonHeight = 22
m_ButtonWidth = 80
End Sub
Private Sub Class_Terminate()
If mHTip <> 0 Then
    DestroyWindow mHTip
    mHTip = 0
End If
Call Clear
End Sub
Private Sub mPctBox_DblClick()
Dim tpt As POINTAPI
GetCursorPos tpt
ScreenToClient mPctBox.hwnd, tpt
RaiseEvent DblClick(tpt.X, tpt.Y)
End Sub
Private Sub mPctBox_DragDrop(Source As Control, X As Single, Y As Single)
If Source Is mPctBox Then
    RaiseEvent DragDrop(CLng(X), CLng(Y))
End If
End Sub
Private Sub mPctBox_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Dim tBtn As cButton, tbtn2 As cButton
Dim tCurBtn As cButton
Set tCurBtn = Hittest(X, Y)
If Button = vbLeftButton Then
    If Not tCurBtn Is Nothing Then
        If mvarAutoRaidoCheck Then
            CheckRadioButton tCurBtn.index
        Else
            tCurBtn.ButtonState = cbtnPress
        End If
        Set mActiveBtn = tCurBtn
    End If
End If
RaiseEvent MouseDown(Button, Shift, CLng(X), CLng(Y), tCurBtn)
End Sub
Private Sub mPctBox_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim tCurBtn As cButton
Dim tRInMe As Boolean
tRInMe = InMe(X, Y) And ItsMe(X, Y)
If tRInMe Then
    SetCapture mPctBox.hwnd
Else
    If Button = 0 Then
        ReleaseCapture
    End If
    
End If
Set tCurBtn = Hittest(X, Y)
If Button = vbLeftButton Then
    If Not mActiveBtn Is Nothing Then
        If mActiveBtn.InMe(X, Y) Then
            mActiveBtn.ButtonState = cbtnPress
        Else
            mActiveBtn.ButtonState = cbtnOver
        End If
    End If
Else
    
    If Not mPreButton Is tCurBtn Then
        If Not mPreButton Is Nothing Then
            mPreButton.ButtonState = cbtnNormal
        End If
    End If
    If Not tCurBtn Is Nothing Then
        If tRInMe Then
            tCurBtn.ButtonState = cbtnOver
        Else
            tCurBtn.ButtonState = cbtnNormal
        End If
    End If
    
'    If tCurBtn Is Nothing Then
'        m_TipText = ""
'        m_TipTitle = ""
'        UpdateTip
'        ActiveTip 0
'    Else
'        If m_TipText <> tCurBtn.TipText Or m_TipTitle <> tCurBtn.TipTitle Then
'            m_TipText = tCurBtn.TipText
'            m_TipTitle = tCurBtn.TipTitle
'            Debug.Print m_TipText, m_TipTitle
'            ChangeTipTitle m_TipTitle
'            UpdateTip
'            ActiveTip 1
'        Else
'            If Not mPreButton Is tCurBtn Then
'                ActiveTip 0
'                ActiveTip 1
'            End If
'        End If
'    End If
    
    Set mPreButton = tCurBtn
End If
RaiseEvent MouseMove(Button, Shift, CLng(X), CLng(Y), tCurBtn)
End Sub
Private Sub mPctBox_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ReleaseCapture
If Not mActiveBtn Is Nothing Then
    mActiveBtn.ButtonState = cbtnNormal
    Set mActiveBtn = Nothing
End If
RaiseEvent MouseUp(Button, Shift, CLng(X), CLng(Y), Hittest(X, Y))
End Sub
Private Sub mPctBox_Paint()
Dim tBtn As cButton
For Each tBtn In mvarButtons
    tBtn.RePaint
Next tBtn
End Sub
Public Function InMe(ByVal X&, ByVal Y&) As Boolean
InMe = X >= 0 And X < mMeWidth And _
    Y >= 0 And Y < mMeHeight
End Function
'对应的点是否自己
Private Function ItsMe(ByVal X&, ByVal Y&) As Boolean
Dim tpt As POINTAPI
tpt.X = X: tpt.Y = Y
ClientToScreen mPctBox.hwnd, tpt
ItsMe = (WindowFromPoint(tpt.X, tpt.Y) = mPctBox.hwnd)
End Function
Public Function Hittest(ByVal X&, ByVal Y&) As cButton
Dim tBtn As cButton
For Each tBtn In mvarButtons
    If tBtn.InMe(X, Y) Then
        Set Hittest = tBtn
        Set tBtn = Nothing
        Exit For
    End If
Next tBtn
End Function
Public Sub Refresh()
Dim tBtn As cButton
For Each tBtn In mvarButtons
    tBtn.Refresh
Next tBtn
End Sub
Private Sub mPctBox_Resize()
mMeWidth = mPctBox.ScaleWidth
mMeHeight = mPctBox.ScaleHeight
End Sub
Public Sub CheckRadioButton(nIndex&)
Dim tBtn As cButton
For Each tBtn In mvarButtons
    If tBtn.index = nIndex Then
        tBtn.Checked = True
    Else
        tBtn.Checked = False
    End If
Next tBtn
End Sub
Public Property Get AutoRaidoCheck() As Boolean
AutoRaidoCheck = mvarAutoRaidoCheck
End Property
Public Property Let AutoRaidoCheck(ByVal vNewValue As Boolean)
mvarAutoRaidoCheck = vNewValue
End Property
Public Sub DragBegin()
mPctBox.Drag
End Sub
'按钮宽度
Public Property Get ButtonWidth() As Long
ButtonWidth = m_ButtonWidth
End Property
Public Property Let ButtonWidth(ByVal vNewValue As Long)
If m_ButtonWidth <> vNewValue And vNewValue > 0 Then
    m_ButtonWidth = vNewValue
    Call SizeButtons
End If
End Property
'按钮高度
Public Property Get ButtonHeight() As Long
ButtonHeight = m_ButtonHeight
End Property
Public Property Let ButtonHeight(ByVal vNewValue As Long)
If m_ButtonHeight <> vNewValue And vNewValue > 0 Then
    m_ButtonHeight = vNewValue
    Call SizeButtons
End If
End Property
'改变按钮大小
Private Sub SizeButtons()
Dim tBtn As cButton
Dim tRc As RECT
mPctBox.Cls
Call SizeBar
For Each tBtn In mvarButtons
    tBtn.Move (tBtn.index - 1) * m_ButtonWidth, tBtn.Top, m_ButtonWidth, m_ButtonHeight
    
    tBtn.GetButtonLprect VarPtr(tRc)
    UpdateTipRect tBtn.index, tRc
Next tBtn
End Sub
Private Sub SizeBar()
On Error Resume Next
If mButtonCount > 0 Then
    mPctBox.Visible = True
    SetWindowPos mPctBox.hwnd, 0, 0, 0, m_ButtonWidth * mButtonCount, _
        m_ButtonHeight, SWP_NOMOVE Or SWP_NOZORDER
    'Call UpdateTipRect
Else
    mPctBox.Visible = False
    SetWindowPos mPctBox.hwnd, 0, 0, 0, m_ButtonWidth, _
        m_ButtonHeight, SWP_NOMOVE Or SWP_NOZORDER
End If
End Sub

						