Public Sub GetCBs()
Dim db As DAO.Database
Dim strPath As String
Dim startUpform As String
Dim app As Access.Application
Dim custBars As Collection
Dim custShortCutBars As Collection
Dim custNonShortCutBars As Collection
Dim i As Integer
Dim blnAutoexec As Boolean
strPath = GetOpenFile()
'Get the db without opening in application
Set db = getDb(strPath)
'Get startupform
startUpform = getStartUp(db)
'Turn off the start up form
TurnOffStartUp db
'Check for and auto exec. If exists import and replace
If hasAutoexec(db) Then
blnAutoexec = True
ImportAutoExec (strPath)
End If
Set app = New Access.Application
'Open safely
app.OpenCurrentDatabase (strPath)
'Read command bars
Set custBars = getCustBars(app)
Set custShortCutBars = getCustShortCutBars(app)
Set custNonShortCutBars = getCustNonShortCutBars(app)
app.CloseCurrentDatabase
Set db = app.CurrentDb
Set db = getDb(strPath)
'Return start up form
TurnOnStartUp db, startUpform
db.Close
'Return auto exec
If blnAutoexec Then
ReturnAutoExec (strPath)
End If
Debug.Print "all custom bars:"
'All bars
For i = 1 To custBars.Count
Debug.Print custBars(i)
Next i
'Do something with the command bars
Debug.Print "all shortcut bars:"
'Short cut only
For i = 1 To custShortCutBars.Count
Debug.Print custShortCutBars(i)
Next i
'Not short cut
Debug.Print "Non shortCut"
For i = 1 To custNonShortCutBars.Count
Debug.Print custNonShortCutBars(i)
Next i
End Sub
Public Function getDb(strPath As String) As DAO.Database
Set getDb = DBEngine(0).OpenDatabase(strPath)
End Function
Public Function getCustBars(app As Access.Application) As Collection
' all bars
Dim col As New Collection
Dim cb As Object
For Each cb In app.CommandBars
If cb.BuiltIn = False Then
col.Add (cb.Name)
End If
Next cb
Set getCustBars = col
End Function
Public Function getCustShortCutBars(app As Access.Application) As Collection
' only short cut bars
Dim col As New Collection
Dim cb As commandbar
For Each cb In app.CommandBars
If cb.BuiltIn = False Then
If cb.Type = msoBarTypePopup Then
col.Add (cb.Name)
End If
End If
Next cb
Set getCustShortCutBars = col
End Function
Public Function getCustNonShortCutBars(app As Access.Application) As Collection
' Menu bars that are not shortcut bars
Dim col As New Collection
Dim cb As commandbar
For Each cb In app.CommandBars
If cb.BuiltIn = False Then
If cb.Type <> msoBarTypePopup Then
col.Add (cb.Name)
End If
End If
Next cb
Set getCustNonShortCutBars = col
End Function
Public Function getStartUp(db As DAO.Database) As String
Dim prp As DAO.Property
For Each prp In db.Properties
If prp.Name = "startupform" Then
getStartUp = prp.Value
Exit For
End If
Next
End Function
Public Sub TurnOffStartUp(db As DAO.Database)
Dim prp As DAO.Property
For Each prp In db.Properties
If prp.Name = "startupform" Then
prp.Value = "(None)"
Exit For
End If
Next
End Sub
Public Sub TurnOnStartUp(db As DAO.Database, strFrm As String)
Dim prp As DAO.Property
For Each prp In db.Properties
If prp.Name = "startupform" Then
prp.Value = strFrm
Exit For
End If
Next
End Sub
Public Sub ImportAutoExec(strPath As String)
On Error GoTo errLbl
DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acMacro, "AutoExec", "AutoExecBackup"
DoCmd.TransferDatabase acExport, "Microsoft Access", strPath, acMacro, "TempAutoExec", "AutoExec"
Exit Sub
errLbl:
If Err.Number = 7874 Then
Debug.Print "Auto Exec macro does not exist"
Else
MsgBox Err.Number & " " & Err.Description
End If
End Sub
Public Sub ReturnAutoExec(strPath As String)
On Error GoTo errLbl
DoCmd.TransferDatabase acExport, "Microsoft Access", strPath, acMacro, "AutoExecBackup", "AutoExec"
DoCmd.DeleteObject acMacro, "AutoExecBackup"
Exit Sub
errLbl:
If Err.Number = 7874 Then
Debug.Print "Auto Exec macro does not exist"
Else
MsgBox Err.Number & " " & Err.Description
End If
End Sub
Public Function hasAutoexec(db As DAO.Database) As Boolean
Dim rs As DAO.Recordset
Dim strSql As String
strSql = "SELECT MSysObjects.Name FROM MSysObjects WHERE MSysObjects.Name = 'AutoExec' AND MSysObjects.Type = -32766"
Set rs = db.OpenRecordset(strSql)
If Not (rs.EOF And rs.BOF) Then
hasAutoexec = True
End If
End Function
