vbAccelerator - Contents of code file: mCommandBars.bas

Attribute VB_Name = "mCommandBars"
Option Explicit
Public Type POINTAPI
x As Long
y As Long
End Type
Public Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Public Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect
As RECT) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect
As RECT) As Long
Public Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal
lpDriverName As String, _
lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal
hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC
As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As
Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long,
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public 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
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As
Long
Public Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As
Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As
Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
nWidth As Long, ByVal crColor As Long) As Long
Public Const PS_SOLID = 0
Public Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal
hRgn As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal
crColor As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal
crColor As Long) As Long
Public Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode
As Long) As Long
Public Const OPAQUE = 2
Public Const TRANSPARENT = 1
Public Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Public Declare Function DrawTextA Lib "user32" (ByVal hDC As Long, ByVal lpStr
As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Declare Function DrawTextW Lib "user32" (ByVal hDC As Long, ByVal lpStr
As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Const DT_LEFT = &H0&
Public Const DT_TOP = &H0&
Public Const DT_CENTER = &H1&
Public Const DT_RIGHT = &H2&
Public Const DT_VCENTER = &H4&
Public Const DT_BOTTOM = &H8&
Public Const DT_WORDBREAK = &H10&
Public Const DT_SINGLELINE = &H20&
Public Const DT_EXPANDTABS = &H40&
Public Const DT_TABSTOP = &H80&
Public Const DT_NOCLIP = &H100&
Public Const DT_EXTERNALLEADING = &H200&
Public Const DT_CALCRECT = &H400&
Public Const DT_NOPREFIX = &H800
Public Const DT_INTERNAL = &H1000&
Public Const DT_WORD_ELLIPSIS = &H40000
' Rectangle functions:
Public Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As
Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As
RECT) As Long
Public Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
Long, ByVal y As Long) As Long
Public Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
Long, ByVal y As Long) As Long
Public Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptX As
Long, ByVal ptY As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
RECT, ByVal hBrush As Long) As Long
' All controls which are connected to the command bar data
Private m_colhWnd As Collection
' The command bars & the respective buttons
Private m_colCommandBars As Collection
Private m_colButtons As Collection
' A collection of controls which we created ourselves
Private m_colPopups As Collection
Private m_showingInfrequentlyUsed As Boolean
Private m_hideInfrequentlyUsed As Boolean
Private m_inMenuLoop As Boolean
Public Property Get NewInstance() As vbalCommandBar
' Using one of the controls which is connected to me,
' request a new control instance:
If (m_colhWnd.Count > 0) Then
Dim ctl As vbalCommandBar
Dim lhWnd As Long
lhWnd = m_colhWnd(1)
If (ControlFromhWnd(lhWnd, ctl)) Then
Set NewInstance = ctl.NewInstance()
End If
End If
End Property
Public Property Get HideInfrequentlyUsed() As Boolean
HideInfrequentlyUsed = m_hideInfrequentlyUsed
End Property
Public Property Let HideInfrequentlyUsed(ByVal bState As Boolean)
m_hideInfrequentlyUsed = bState
End Property
Public Property Get ShowingInfrequentlyUsed() As Boolean
If (m_hideInfrequentlyUsed) Then
ShowingInfrequentlyUsed = m_showingInfrequentlyUsed
Else
ShowingInfrequentlyUsed = True
End If
End Property
Public Sub ShowInfrequentlyUsed()
m_showingInfrequentlyUsed = True
End Sub
Public Property Get InMenuLoop() As Boolean
InMenuLoop = m_inMenuLoop
End Property
Public Property Let InMenuLoop(ByVal bState As Boolean)
If Not (m_inMenuLoop = bState) Then
m_inMenuLoop = bState
m_showingInfrequentlyUsed = False
End If
End Property
Public Sub AddRef(ByVal hWnd As Long, ctlCmdBar As vbalCommandBar)
If (m_colhWnd Is Nothing) Then
Debug.Print "PREPARE FOR INVASION"
VerInitialise
Set m_colhWnd = New Collection
Set m_colCommandBars = New Collection
Set m_colButtons = New Collection
End If
m_colhWnd.Add hWnd, "H" & hWnd
' tag control with object pointer:
TagControl hWnd, ctlCmdBar, True
End Sub
Public Sub ReleaseRef(ByVal hWnd As Long)
m_colhWnd.Remove "H" & hWnd
' untag control
TagControl hWnd, Nothing, False
If (m_colhWnd.Count = 0) Then
Set m_colhWnd = Nothing
Dim barInt As cCommandBarInt
For Each barInt In m_colCommandBars
barInt.Dispose
Next
Set m_colCommandBars = Nothing
Dim btnInt As cButtonInt
For Each btnInt In m_colButtons
btnInt.Dispose
Next
Set m_colButtons = Nothing
Debug.Print "GAME OVER"
End If
End Sub
Public Function BarCount() As Long
BarCount = m_colCommandBars.Count
End Function
Public Sub BarRemove(ByVal sKey As String)
If CollectionContains(m_colCommandBars, sKey) Then
Dim barInt As cCommandBarInt
Set barInt = m_colCommandBars(sKey)
barInt.Clear
m_colCommandBars.Remove sKey
Else
gErr 3
End If
End Sub
Public Property Get BarItem(index As Variant) As cCommandBarInt
Set BarItem = m_colCommandBars.Item(index)
End Property
Public Function BarAdd(ByVal sKey As String) As cCommandBarInt
If CollectionContains(m_colCommandBars, sKey) Then
gErr 5
ElseIf (IsNumeric(sKey)) Then
gErr 4
Else
Dim barInt As New cCommandBarInt
barInt.fInit sKey
m_colCommandBars.Add barInt, sKey
Set BarAdd = barInt
End If
End Function
Public Function ButtonCount() As Long
ButtonCount = m_colButtons.Count
End Function
Public Sub ButtonRemove(ByVal sKey As String)
If CollectionContains(m_colButtons, sKey) Then
Dim btn As cButtonInt
Set btn = m_colButtons(sKey)
btn.Deleted
m_colButtons.Remove sKey
Else
gErr 3
End If
End Sub
Public Property Get ButtonItem(index As Variant) As cButtonInt
Set ButtonItem = m_colButtons.Item(index)
End Property
Public Function ButtonAdd(ByVal sKey As String) As cButtonInt
If CollectionContains(m_colButtons, sKey) Then
gErr 5
ElseIf (IsNumeric(sKey)) Then
gErr 4
Else
Dim btnInt As New cButtonInt
btnInt.fInit sKey
m_colButtons.Add btnInt, sKey
Set ButtonAdd = btnInt
End If
End Function