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