vbAccelerator - Contents of code file: mfrmTest.frm

VERSION 5.00
Object = "{E142732F-A852-11D4-B06C-00500427A693}#1.10#0"; "vbalTbar6.ocx"
Begin VB.MDIForm mfrmTest 
   BackColor       =   &H8000000C&
   Caption         =   "vbAccelerator Toolbar/Rebar MDI Demonstration"
   ClientHeight    =   5655
   ClientLeft      =   1110
   ClientTop       =   1425
   ClientWidth     =   8235
   LinkTopic       =   "MDIForm1"
   Begin VB.PictureBox picStatus 
      Align           =   2  'Align Bottom
      BorderStyle     =   0  'None
      Height          =   315
      Left            =   0
      ScaleHeight     =   315
      ScaleWidth      =   8235
      TabIndex        =   3
      Top             =   5340
      Width           =   8235
   End
   Begin vbalTBar6.cReBar cReBar1 
      Left            =   480
      Top             =   1800
      _ExtentX        =   7223
      _ExtentY        =   979
   End
   Begin VB.PictureBox picHolder 
      Align           =   1  'Align Top
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   735
      Left            =   0
      ScaleHeight     =   735
      ScaleWidth      =   8235
      TabIndex        =   0
      Top             =   0
      Width           =   8235
      Begin vbalTBar6.cToolbarHost tbhMenu 
         Height          =   255
         Left            =   180
         TabIndex        =   2
         Top             =   0
         Width           =   5775
         _extentx        =   10186
         _extenty        =   450
         borderstyle     =   0
      End
      Begin vbalTBar6.cToolbar tbrMenu 
         Left            =   4020
         Top             =   300
         _ExtentX        =   1508
         _ExtentY        =   661
      End
      Begin vbalTBar6.cToolbar cToolbar1 
         Left            =   180
         Top             =   300
         _ExtentX        =   6694
         _ExtentY        =   661
      End
      Begin VB.ComboBox cboTest 
         Height          =   315
         Left            =   6060
         TabIndex        =   1
         Text            =   "Combo1"
         Top             =   300
         Width           =   1995
      End
   End
End
Attribute VB_Name = "mfrmTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' =========================================================================
' vbAccelerator Toolbar/Rebar control tester
' Copyright  1998 Steve McMahon (steve@vbaccelerator.com)
'
' Demonstrates the vbAccelerator Toolbar and Rebar control.
' Note that some of the features of this demonstration will
' not work correctly unless you have the correct version of
' COMCTRL32.DLL installed (4.71 or higher required).
'
' Visit vbAccelerator at http://vbaccelerator.com/
' =========================================================================

' =========================================================================
' vbAccelerator Toolbar/Rebar control tester
' Copyright  1998-2001 Steve McMahon (steve@vbaccelerator.com)
'
' Demonstrates the vbAccelerator Toolbar and Rebar control.
' Note that some of the features of this demonstration will
' not work correctly unless you have the correct version of
' COMCTRL32.DLL installed (4.71 or higher required).
'
' Visit vbAccelerator at www.vbaccelerator.com
' =========================================================================

Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long)
 As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal
 hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
 As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_CLOSE = &HF060&
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal
 hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, lpsz2 As Any) As
 Long
Private Const WM_MDINEXT = &H224
Private Declare Function SetWindowTheme Lib "uxtheme.dll" (ByVal hwnd As Long,
 ByVal pszSubAppName As Long, ByVal pszSubIdList As Long) As Long

Private WithEvents m_cMenu As cPopupMenu
Attribute m_cMenu.VB_VarHelpID = -1
Private Sub pCreateMenu()
Dim iP As Long
Dim iP2 As Long

   With m_cMenu
      iP = .AddItem("&File", , , , , , , "mnuFileTOP")
      .AddItem "&Close", , , iP, , , , "mnuFile(0)"
      
      iP = .AddItem("&Button", , , , , , , "mnuButtonTOP")
      .AddItem "Button 2 &Visible", , , iP, , True, , "mnuButton(0)"
      .AddItem "Button 2 &Enabled", , , iP, , True, , "mnuButton(1)"
      .AddItem "-", , , iP, , , , "mnuButton(2)"
      .AddItem "Change Button 2 &Caption", , , iP, , , , "mnuButton(3)"
      .AddItem "Change Button 1 Captio&n", , , iP, , , , "mnuButton(4)"
      .AddItem "-", , , iP, , , , "mnuButton(5)"
      .AddItem "Change Button 2 &Image", , , iP, , , , "mnuButton(6)"
      .AddItem "Chec&k Last Button", , , iP, , , , "mnuButton(7)"
      .AddItem "-", , , iP, , , , "mnuButton(8)"
      .AddItem "In&sert Button...", , , iP, , , , "mnuButton(9)"
      .AddItem "-", , , iP, , , , "mnuButton(10)"
      .AddItem "&Show Captions", , , iP, , True, , "mnuButton(11)"
            
      iP = .AddItem("&View", , , , , , , "mnuPositionTOP")
      iP2 = .AddItem("&Top", , , iP, , , , "mnuPosition(0)")
      .RadioCheck(iP2) = True
      .AddItem "&Left", , , iP, , , , "mnuPosition(1)"
      .AddItem "&Right", , , iP, , , , "mnuPosition(2)"
      .AddItem "&Bottom", , , iP, , , , "mnuPosition(3)"
      .AddItem "-", , , iP, , , , "mnuPosition(4)"
      .AddItem "Back&ground Bitmap", , , iP, , , , "mnuPosition(5)"
      
      
      iP = .AddItem("&Window", , , , , , , "mnuWindowTOP")
      .AddItem "<WindowMenu>", , , iP, , , , "mnuWin(0)"
      
      iP = .AddItem("&Help", , , , , , , "mnuHelpTOP")
      .AddItem "&vbAccelerator on the Web" & vbTab & "F1", , , iP, , , ,
       "mnuHelp(0)"
      .AddItem "-", , , iP
      .AddItem "&About...", , , iP, , , , "mnuHelp:About"
   End With
End Sub
Private Sub pBackgroundBitmap(ByVal bState As Boolean)
   ' To change the background bitmap, we remove all bands
   ' and add them in again.
   ' In order to prevent flickering whilst the rebar builds,
   ' use LockWindowUpdate.  See Tips on vbAccelerator for
   ' more info.
   LockWindowUpdate Me.hwnd
   With cReBar1
      .ImageSource = CRBLoadFromFile
      If (bState) Then
         .DestroyRebarDontDestroyChildren
         .ImageFile = App.Path & "\iebar2.bmp"
         .CreateRebar picHolder.hwnd
         ' Add the bands:
         .AddBandByHwnd tbhMenu.hwnd, , , , "MenuBar"
         .BandChildMinWidth(0) = 64
         .AddBandByHwnd cToolbar1.hwnd, , , , "Toolbar1"
         .BandChildMinWidth(1) = 64
         .AddBandByHwnd cboTest.hwnd, "Style", True, , "Stylebar"
         tbhMenu.BackgroundBitmap = LoadPicture(App.Path & "\iebar2.bmp")
         Set m_cMenu.BackgroundPicture = LoadPicture(App.Path & "\iebar2.bmp")
      Else
         .DestroyRebarDontDestroyChildren
         .ImageFile = ""
         .CreateRebar picHolder.hwnd
         ' Add the bands:
         .AddBandByHwnd tbhMenu.hwnd, , , , "MenuBar"
         .BandChildMinWidth(0) = 64
         .AddBandByHwnd cToolbar1.hwnd, , , , "Toolbar1"
         .BandChildMinWidth(1) = 64
         .AddBandByHwnd cboTest.hwnd, "Style", True, , "Stylebar"
         tbhMenu.ClearPicture
         m_cMenu.ClearBackgroundPicture
      End If
   End With
   LockWindowUpdate 0

End Sub

Private Sub pFileMenu(ByVal lIndex As Long, ByVal sKey As String)
Dim lItemIndex As Long

   lItemIndex = CLng(Mid$(sKey, 9, 1))
   Select Case lItemIndex
   Case 0
      PostMessage Me.hwnd, WM_SYSCOMMAND, SC_CLOSE, 0
   End Select

End Sub
Private Sub pPositionMenu(ByVal lIndex As Long, ByVal sKey As String)
Dim i As Long
Dim lItemIndex As Long
   
   lItemIndex = CLng(Mid$(sKey, 13, 1))

   If lItemIndex = 5 Then
      m_cMenu.Checked(lIndex) = Not (m_cMenu.Checked(lIndex))
      pBackgroundBitmap m_cMenu.Checked(m_cMenu.IndexForKey(lIndex))
   Else

      LockWindowUpdate Me.hwnd
      Select Case lItemIndex
      Case 0
         picHolder.Align = vbAlignTop
         cReBar1.BandVisible(cReBar1.BandIndexForData("Stylebar")) = True
         cReBar1.BandVisible(cReBar1.BandIndexForData("picBar")) = True
         cReBar1.BandChildMinHeight(cReBar1.BandIndexForData("MenuBar")) =
          tbrMenu.ToolbarHeight
         cReBar1.Position = erbPositionTop
      Case 1
         picHolder.Align = vbAlignLeft
         cReBar1.BandVisible(cReBar1.BandIndexForData("Stylebar")) = False
         cReBar1.BandVisible(cReBar1.BandIndexForData("picBar")) = False
         cReBar1.BandChildMinHeight(cReBar1.BandIndexForData("MenuBar")) =
          tbrMenu.MaxButtonWidth
         cReBar1.Position = erbPositionLeft
      Case 2
         picHolder.Align = vbAlignRight
         cReBar1.BandVisible(cReBar1.BandIndexForData("Stylebar")) = False
         cReBar1.BandVisible(cReBar1.BandIndexForData("picBar")) = False
         cReBar1.BandChildMinHeight(cReBar1.BandIndexForData("MenuBar")) =
          tbrMenu.MaxButtonWidth
         cReBar1.Position = erbPositionRight
      Case 3
         picHolder.Align = vbAlignBottom
         cReBar1.BandVisible(cReBar1.BandIndexForData("Stylebar")) = True
         cReBar1.BandVisible(cReBar1.BandIndexForData("picBar")) = True
         cReBar1.BandChildMinHeight(cReBar1.BandIndexForData("MenuBar")) =
          tbrMenu.ToolbarHeight
         cReBar1.Position = erbPositionBottom
      End Select
      
      If lItemIndex = 1 Or lItemIndex = 2 Then
         ' left/right.  Note that the meanings of "Width" & "Height" are swapped
         ' when a rebar is aligned to the left or right.
         
         ' a) Set minimum width of bands:
         cReBar1.BandChildMinHeight(cReBar1.BandIndexForData("Toolbar1")) =
          cToolbar1.MaxButtonWidth
         ' b) menu shows to side
         tbrMenu.DropDownAlign = CTBDropDownAlignLeft
         cToolbar1.DropDownAlign = CTBDropDownAlignLeft
      Else
         ' a) Set minimum Height of bands:
         cReBar1.BandChildMinHeight(cReBar1.BandIndexForData("Toolbar1")) =
          cToolbar1.MaxButtonHeight
         ' b) menu shows below
         tbrMenu.DropDownAlign = CTBDropDownAlignBottom
         cToolbar1.DropDownAlign = CTBDropDownAlignBottom
      End If
      For i = 0 To 3
         lIndex = m_cMenu.IndexForKey("mnuPosition(" & i & ")")
         m_cMenu.RadioCheck(lIndex) = (lItemIndex = i)
      Next i
      LockWindowUpdate 0
   End If
   
End Sub


Private Sub cboTest_Click()
   frmMessages.Indicate "CLICK: " & cboTest.ListIndex
End Sub

Private Sub cReBar1_ChevronPushed(ByVal wID As Long, ByVal lLeft As Long, ByVal
 lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
Dim v As Variant
   frmMessages.Indicate "Chevron Pushed " & wID
   v = cReBar1.BandData(wID)
   If Not IsMissing(v) Then
      Debug.Print lRight, lTop
      Select Case v
      Case "MenuBar"
         tbrMenu.ChevronPress lRight \ Screen.TwipsPerPixelX + 1, lTop \
          Screen.TwipsPerPixelY
      Case "Toolbar1"
         cToolbar1.ChevronPress lRight \ Screen.TwipsPerPixelX + 1, lTop \
          Screen.TwipsPerPixelY
      End Select
   End If
End Sub

Private Sub cReBar1_HeightChanged(lNewHeight As Long)
   frmMessages.Indicate "Rebar HeightChanged " & lNewHeight
   If picHolder.Align = 1 Or picHolder.Align = 2 Then
      picHolder.Height = lNewHeight * Screen.TwipsPerPixelY
   Else
      picHolder.Width = lNewHeight * Screen.TwipsPerPixelY
   End If
End Sub

Private Sub cToolbar1_ButtonClick(ByVal lButton As Long)
   frmMessages.Indicate "Toolbar1 ButtonClick:" & vbTab & CStr(lButton) &
    ",Pressed=" & cToolbar1.ButtonPressed(lButton) & ",Checked=" &
    cToolbar1.ButtonChecked(lButton)
   If (lButton = 0) Then
      Dim fM As New frmMessages
      fM.Show
   End If
End Sub

Private Sub cToolbar1_DropDownPress(ByVal lButton As Long)
Dim x As Long, y As Long
   frmMessages.Indicate "Toolbar1 DropDownPress:" & vbTab & CStr(lButton)
   cToolbar1.GetDropDownPosition lButton, x, y
   y = y - picHolder.Height - 2 * Screen.TwipsPerPixelY
   'Me.PopupMenu mnuFileTOP, , x, y

End Sub

Private Sub m_cMenu_Click(ItemNumber As Long)
Dim sKey As String
   
   sKey = m_cMenu.ItemKey(ItemNumber)
   Debug.Print "Click:", sKey
   
   Select Case True
   Case Left$(sKey, 7) = "mnuFile"
      pFileMenu ItemNumber, sKey
   Case Left$(sKey, 7) = "mnuTest"
      frmMessages.Indicate "Click:" & sKey
   Case Left$(sKey, 9) = "mnuButton"
      'pButtonMenu ItemNumber, sKey
   Case Left$(sKey, 11) = "mnuPosition"
      pPositionMenu ItemNumber, sKey
   Case Left$(sKey, 6) = "mnuWin"
      WindowMenuClick m_cMenu.ItemData(ItemNumber)
   Case sKey = "mnuHelp:About"
      Dim fA As frmAbout
      Set fA = New frmAbout
      fA.Show vbModal, Me
   End Select
   
End Sub

Private Sub m_cMenu_InitPopupMenu(ParentItemNumber As Long)
   If m_cMenu.ItemKey(ParentItemNumber) = "mnuWindowTOP" Then
      CreateWindowMenu m_cMenu, "mnuWindowTOP"
   End If
End Sub

Private Sub MDIForm_Load()

   ' NB: If you place a picture box control on your MDI,
   ' the Rebar will be hosted in this.  The effect is much smoother that
   ' if the rebar is hosted directly in the MDI.
   
   With cToolbar1
      .ImageSource = CTBLoadFromFile
      .ImageFile = App.Path & "\small256.bmp"
      .CreateToolbar 16, , , True
      .AddButton "New", 0, , , "New", CTBDropDown
      .AddButton "Open", 1, , , "Open", CTBNormal
      .AddButton "Save", 2, , , "Save"
      .AddButton "", -1, , , , CTBSeparator
      .AddButton "Cut", 3, , , "Cut"
      .AddButton "Copy", 4, , , "Copy"
      .AddButton "Paste", 5, , , "Paste"
      .AddButton "", -1, , , , CTBSeparator
      .AddButton "CheckBox", 6, , , "Check", CTBCheck
      .AddButton "", -1, , , , CTBSeparator
      .AddButton "Print", 7, , , "Print", CTBDropDown
      .AddButton "", -1, , , , CTBSeparator
      .AddButton "Help", 8, , , "Help", CTBCheckGroup
      .AddButton "Whats This", 9, , , "Desktop", CTBCheckGroup
   End With
      
   Dim i As Long
   For i = 1 To cToolbar1.ButtonCount
     cboTest.AddItem cToolbar1.ButtonCaption(i - 1)
   Next i
   cboTest.ListIndex = 0
   
   Set m_cMenu = New cPopupMenu
   m_cMenu.hWndOwner = Me.hwnd
   m_cMenu.OfficeXpStyle = True
   pCreateMenu
   With tbrMenu
      .CreateFromMenu m_cMenu
      .Wrappable = True
      ' the menu toolbar doesn't look good if XP themes are switched on,
      ' so turn them off:
      On Error Resume Next
      SetWindowTheme tbrMenu.hwnd, StrPtr(" "), StrPtr(" ")
      On Error GoTo 0
   End With
   With tbhMenu
      .ImageSource = CTBLoadFromFile
      .MDIToolbar = True
      .Capture tbrMenu
      .Width = tbhMenu.MDIToolbarMinWidth * Screen.TwipsPerPixelX
   End With
   
   With cReBar1
      
      ' Create the rebar:
      .ImageSource = CRBLoadFromFile
      .CreateRebar picHolder.hwnd
      
      ' Add the bands:
      .AddBandByHwnd tbhMenu.hwnd, , , , "MenuBar"
      .BandChildMinWidth(0) = 64
      .AddBandByHwnd cToolbar1.hwnd, , , , "Toolbar1"
      .BandChildMinWidth(1) = 64
      .AddBandByHwnd cboTest.hwnd, "Style", True, , "Stylebar"
      
   End With
   
   ' NB: Don't show child forms until you have initialised the rebar!
   frmMessages.Show
   frmMessages.Indicate "Welcome to the vbAccelerator Rebar/Toolbar control
    Demonstration"
   frmMessages.Indicate ""
   frmMessages.Indicate "This form displays the Rebar/Toolbar hosted in an MDI
    form"
   frmMessages.Indicate ""

   
End Sub

Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   cReBar1.RemoveAllRebarBands
End Sub

Private Sub MDIForm_Resize()
   '
End Sub

Private Sub picHolder_Resize()
   cReBar1.RebarSize
   If picHolder.Align = 1 Or picHolder.Align = 2 Then
      picHolder.Height = cReBar1.RebarHeight * Screen.TwipsPerPixelY
   Else
      picHolder.Width = cReBar1.RebarHeight * Screen.TwipsPerPixelY
   End If
End Sub

Private Sub CreateWindowMenu( _
      ByRef cMenu As cPopupMenu, _
      ByVal sKey As String _
   )
Dim i As Long, j As Long
Dim f As Object
Dim lIndex As Long
Dim lPos As Long
Dim sCap() As String
Dim lIdx() As Long
Dim lCount As Long

   lIndex = m_cMenu.IndexForKey(sKey)
   If lIndex > 0 Then
      With m_cMenu
         .ClearSubMenusOfItem lIndex
         .AddItem "&Tile", , -8001, lIndex, 63, , , "mnuWin(0)"
         .AddItem "&Cascade", , -8002, lIndex, 62, , , "mnuWin(1)"
         .AddItem "Ma&ximise All", , -8003, lIndex, 65, , , "mnuWin(2)"
         .AddItem "Mi&nimise All", , -8004, lIndex, 68, , , "mnuWin(3)"
         .AddItem "-", , -1, lIndex, , , , "mnuWin(4)"
                                                                  
         For i = 0 To Forms.Count - 1
            Set f = Forms(i)
            If Not f Is Me Then
               If f.Visible And f.MDIChild Then
                  lCount = lCount + 1
                  ReDim Preserve lIdx(1 To lCount) As Long
                  ReDim Preserve sCap(1 To lCount) As String
                  If f Is Me.ActiveForm Then
                     For j = lCount - 1 To 1 Step -1
                        lIdx(j + 1) = lIdx(j)
                        sCap(j + 1) = sCap(j)
                     Next j
                     lPos = 1
                  Else
                     lPos = lCount
                  End If
                  lIdx(lPos) = i
                  sCap(lPos) = f.Caption
                  If Len(sCap(lPos)) > 32 Then
                     sCap(lPos) = Left$(sCap(lPos), 32) & "..."
                  End If
               End If
            End If
         Next i
      
         .AddItem "Ne&xt" & vbTab & "Ctrl+F6", , -8005, lIndex, 66, , (lCount >
          1), "mnuWin(5)"
         .AddItem "Pre&vious", , -8006, lIndex, 67, , (lCount > 1), "mnuWin(6)"

         If lCount > 0 Then
            .AddItem "-", , -1, lIndex, , , , "mnuWin(7)"
            If lCount > 11 Then lCount = 11
            For i = 1 To lCount
               If i <= 10 Then
                  sCap(i) = "&" & i & ") " & sCap(i)
               Else
                  sCap(i) = "&More Windows..."
                  lIdx(i) = -8007
               End If
               .AddItem sCap(i), , lIdx(i), lIndex, , (i = 1), , "mnuWin(" & 7
                + i & ")"
            Next i
         End If
      
      End With
   
   End If
   
End Sub
Private Sub WindowMenuClick(ByVal lItemData As Long)
Dim f As Object
Dim lhWnd As Long
Dim lhWndMDIClient
   Select Case lItemData
   Case Is >= 0
      Forms(lItemData).SetFocus
   Case -8001
      Me.Arrange vbTileHorizontal
   Case -8002
      Me.Arrange vbCascade
   Case -8003
      Me.ActiveForm.WindowState = vbMaximized
   Case -8004
      For Each f In Forms
         If Not f Is Me Then
            If f.Visible And f.MDIChild Then
               f.WindowState = vbMinimized
            End If
         End If
      Next f
   Case -8005
      lhWndMDIClient = FindWindowEx(Me.hwnd, 0, "MDIClient", ByVal 0&)
      lhWnd = Me.ActiveForm.hwnd
      PostMessage lhWndMDIClient, WM_MDINEXT, lhWnd, 0
   Case -8006
      lhWndMDIClient = FindWindowEx(Me.hwnd, 0, "MDIClient", ByVal 0&)
      lhWnd = Me.ActiveForm.hwnd
      PostMessage lhWndMDIClient, WM_MDINEXT, lhWnd, 1
   End Select
End Sub


Private Sub tbrMenu_ButtonClick(ByVal lButton As Long)
   Select Case tbrMenu.ButtonKey(lButton)
   Case "mnuWindowTOP"
      CreateWindowMenu m_cMenu, "mnuWindowTOP"
   End Select
End Sub