Copy CommandBars using VBA

Question

How to copy commadbars using VBA ?

Answer

From: Shamil Salakhetdinov <shamil@marta.darts.spb.ru>
To: ACCESS-L <ACCESS-L@PEACH.EASE.LSOFT.COM>
Subject: CopyCommandBars
Date: 2 June 1998 13:33

Hi All,

Enclosed is a set of functions which allow to copy commandbars but I'm not sure they are 100% correct. I used them with my custom menu bars and it seems to me that they work OK. If you are interested in them please try them with your custom menu bars and send me your comments if possible.

Disclaimer: you are free to use the code as it is, do any corrections and use it any other ways in your apps. Please be careful when you test it to not loose your custom menubars - you'd better create new test .mdb and import all your custom menubars in it for testing. It copies custom menubar as toolbar to not hide default menubar - to convert toolbar into menubar go View->Toolbars->Customize->Properties->change custom toolbar's type to menubar. It also copies toolbars but it seems to me that it does not copy some of their important attributes (properties)... If you know which additional properties should be copied to make it working correctly with toolbars please send me a note... It should work also with short-cut menus after some corrections... "Window" menubar entry is an exception which should be handled special way - I still don't know it...

Any (private) messages with comments, advices etc. would be greately appreciated.

Best wishes,
Shamil


P.S. The functions:

Private Function a_test()
    Dim strSrcMdbPath As String
    Dim strNewMdbPath As String
    
    Dim strSrcCbrName As String
    Dim strNewCbrName As String
    
'
' Edit the code in this function to enter your menubar's names and test .mdb paths.
' Then umcomment the code lines of one of the four possible cases to test them...
'

    ' 1. Copy menu bar within current mdb
    'strSrcCbrName = "DAISY Test Menu Bar"
    'strNewCbrName = "Daisy Test Menu Bar (New)"
    'smsCbrCopyExt strSrcCbrName, strNewCbrName
    'Exit Function
    
    ' 2. From external into current
    'strSrcMdbPath = "c:\daisy\temp\sb_menus.mdb"
    'strSrcCbrName = "DAISY Test Menu Bar"
    'strNewCbrName = "Daisy Test Menu Bar (New)"
    'smsCbrCopyExt strSrcCbrName, strNewCbrName, strSrcMdbPath
    'Exit Function
    
    ' 3. From one external into (new) external
    'strSrcMdbPath = "c:\daisy\temp\sb_menus.mdb"
    'strSrcCbrName = "DAISY Test Menu Bar"
    'strNewMdbPath = "c:\daisy\temp\sb_test.mdb"
    'strNewCbrName = "Daisy Test Menu Bar (New)"
    'smsCbrCopyExt strSrcCbrName, strNewCbrName, strSrcMdbPath, strNewMdbPath
    'Exit Function
    
    ' 4. From current into new external
    'strSrcCbrName = "DAISY Test Menu Bar"
    'strNewMdbPath = "c:\daisy\temp\sb_test.mdb"
    'strNewCbrName = "Daisy Test Menu Bar (New)"
    'smsCbrCopyExt strSrcCbrName, strNewCbrName, , strNewMdbPath
    'Exit Function

End Function

'*+
'
'   A set of functions to copy menubars including copy between different .mdbs
'
'  Written by: Shamil Salakhetdinov, e-mail: shamil@marta.darts.spb.ru
'
'  Any comments and messages with related to commandbars info are very welcome to
'         the e-mail address above.
'
'*-
Public Function smsCbrCopyExt(ByVal vstrSrcCbrName As String, _
                              ByVal vstrNewCbrName As String, _
                              Optional ByVal vstrSrcMdbPath As String = "", _
                              Optional ByVal vstrNewMdbPath As String = "") _
                              As Boolean
    On Error Resume Next
    Dim intCase As Integer
    
    Dim objAccSrc As Access.Application
    Dim objAccNew As Access.Application
    
    Dim strSrcMdbPath As String
    Dim strNewMdbPath As String
    
    Dim strSrcCbrName As String
    Dim strNewCbrName As String
    
    If vstrSrcMdbPath = "" And vstrNewMdbPath = "" Then
       intCase = 1
    ElseIf vstrSrcMdbPath <> "" And vstrNewMdbPath = "" Then
       intCase = 2
    ElseIf vstrSrcMdbPath <> "" And vstrNewMdbPath <> "" Then
       intCase = 3
    ElseIf vstrSrcMdbPath = "" And vstrNewMdbPath <> "" Then
       intCase = 4
    End If
    
    strSrcMdbPath = vstrSrcMdbPath
    strSrcCbrName = vstrSrcCbrName
    
    strNewMdbPath = vstrNewMdbPath
    strNewCbrName = vstrNewCbrName
    
    Select Case intCase
    Case 1:   ' copy within current mdb
        smsCbrCopy strSrcCbrName, strNewCbrName
        
    Case 2:   ' copy from external mdb into current
        Set objAccSrc = New Access.Application
        objAccSrc.OpenCurrentDatabase strSrcMdbPath
        
        smsCbrCopy strSrcCbrName, strNewCbrName, objAccSrc
        
    Case 3:   ' copy from one (existing) external mdb into new external mdb
        Set objAccSrc = New Access.Application
        objAccSrc.OpenCurrentDatabase strSrcMdbPath
        
        Set objAccNew = New Access.Application
        Kill strNewMdbPath
        objAccNew.DBEngine.CreateDatabase strNewMdbPath, dbLangGeneral
        objAccNew.OpenCurrentDatabase strNewMdbPath
        
        smsCbrCopy strSrcCbrName, strNewCbrName, objAccSrc, objAccNew
      
    Case 4:   ' copy from current mdb into new external mdb
       
        Set objAccNew = New Access.Application
        Kill strNewMdbPath
        objAccNew.DBEngine.CreateDatabase strNewMdbPath, dbLangGeneral
        objAccNew.OpenCurrentDatabase strNewMdbPath
        
        smsCbrCopy strSrcCbrName, strNewCbrName, , objAccNew
    Case Else
    End Select
    

    If Not objAccSrc Is Nothing Then
        objAccSrc.CloseCurrentDatabase
        objAccSrc.Quit
        Set objAccSrc = Nothing
    End If
    
    If Not objAccNew Is Nothing Then
        objAccNew.CloseCurrentDatabase
        objAccNew.Quit
        Set objAccNew = Nothing
    End If
    
End Function

Function smsCbrCopy(ByVal vstrSrcCbrName As String, _
                    ByRef vstrNewCbrName As String, _
                    Optional ByRef robjSrcAcc As Access.Application = Nothing, _
                    Optional ByRef robjNewAcc As Access.Application = Nothing) As Boolean
    
    On Error Resume Next
    
    Dim objSrcAcc As Access.Application
    Dim objNewAcc As Access.Application
    Dim cbrSrc As CommandBar
    Dim cbrNew As CommandBar
    Dim cbrCtlSrc As CommandBarControl
    Dim cbrCtlNew As CommandBarControl

    If robjSrcAcc Is Nothing Then
       Set objSrcAcc = Application
    Else
       Set objSrcAcc = robjSrcAcc
    End If

    If robjNewAcc Is Nothing Then
       Set objNewAcc = Application
    Else
       Set objNewAcc = robjNewAcc
    End If
    
    objNewAcc.CommandBars(vstrNewCbrName).Delete
    
    Set cbrSrc = objSrcAcc.CommandBars(vstrSrcCbrName)
    Set cbrNew = objNewAcc.CommandBars.Add(vstrNewCbrName, _
                                 cbrSrc.Position, _
                                 False, _
                                 False)
    
    cbrNew.Visible = True
       
    For Each cbrCtlSrc In cbrSrc.Controls
        With cbrCtlSrc
            Set cbrCtlNew = cbrNew.Controls.Add(Type:=.Type, Id:=.Id, Temporary:=False)
            smsCbrCtlCopy cbrCtlSrc, cbrCtlNew
        End With
    Next

End Function


Private Function smsCbrCtlCopy(ByRef rcbrSrc As CommandBarControl, _
                            ByRef rcbrNew As CommandBarControl)
    On Error Resume Next
    
    Dim cbrCtlSrc As CommandBarControl
    Dim cbrCtlNew As CommandBarControl
        
    cbrCtlPrpsCopy rcbrSrc, rcbrNew

    If smsCbrCtlHasControls(rcbrSrc) Then
      For Each cbrCtlSrc In rcbrSrc.Controls
        With cbrCtlSrc
            Set cbrCtlNew = rcbrNew.Controls.Add( _
                            Type:=.Type, _
                            Id:=.Id, _
                            Temporary:=False)
            
            DoEvents
            smsCbrCtlCopy cbrCtlSrc, cbrCtlNew
            
        End With
      Next
    End If
End Function

Private Function cbrCtlPrpsCopy(ByRef rcbrCtlSrc As CommandBarControl, _
                                ByRef rcbrCtlNew As CommandBarControl)
        On Error Resume Next
        
        With rcbrCtlSrc
            'BuilIt - read-only
            'rcbrCtlNew.BuiltIn = .BuiltIn
            'Id - read-only
            'rcbrCtlNew.Id = .Id
            'BeginGroup
            rcbrCtlNew.BeginGroup = .BeginGroup
            'Caption
            rcbrCtlNew.Caption = .Caption
            'DescriptionText
            rcbrCtlNew.DescriptionText = .DescriptionText
            '.Name
            rcbrCtlNew.Name = .Name
            'Enabled
            rcbrCtlNew.Enabled = .Enabled
            'HelpContextId
            rcbrCtlNew.HelpContextId = .HelpContextId
            'HelpFile
            rcbrCtlNew.HelpFile = .HelpFile
            'Parameter - keep parameter values
            rcbrCtlNew.Parameter = .Parameter
            'Tag
            rcbrCtlNew.Tag = .Tag
            'ToolTipText
            rcbrCtlNew.TooltipText = .TooltipText
            'Visible
            rcbrCtlNew.Visible = .Visible
            'OnAction
            rcbrCtlNew.OnAction = .OnAction
            '
            ' What else ???
            '
        End With
End Function

Private Function smsCbrCtlHasControls(ByRef rcbr As CommandBarControl) As Boolean
    Dim blnRet As Boolean
    
    Select Case rcbr.Type
    
    Case msoControlButton, _
         msoControlEdit, _
         msoControlGauge:
         
         blnRet = False
    
    Case msoControlButtonDropdown, _
         msoControlButtonPopup, _
         msoControlComboBox, _
         msoControlDropdown, _
         msoControlExpandingGrid, _
         msoControlGraphicCombo, _
         msoControlGraphicDropdown, _
         msoControlGrid, _
         msoControlOCXDropdown, _
         msoControlPopup, _
         msoControlSplitButtonMRUPopup, _
         msoControlSplitButtonPopup, _
         msoControlSplitDropdown:
         
         If rcbr.Controls.Count > 0 Then
            blnRet = True
         Else
            blnRet = False
         End If

    Case msoControlCustom, _
         msoControlGenericDropdown, _
         msoControlGraphicPopup, _
         msoControlLabel, _
         msoControlSplitExpandingGrid:
         
         blnRet = False
    Case Else
         blnRet = False
    End Select
    
    smsCbrCtlHasControls = blnRet
End Function