Pasted

Option Compare Database
Option Explicit
'This module locks down the current database
'global microsoft access object
Private app As Access.Application
 
Public Function tableExists(TBLNAME As String) As Boolean
'returns true if the table exists in the current database else false
'The comparison is case insensitive
    Dim tdf As TableDef
    For Each tdf In app.CurrentDb.TableDefs
        If StrComp(TBLNAME, tdf.name, vbTextCompare) = 0 Then
            tableExists = True
            GoTo exitSuccess
        End If
    Next tdf
exitSuccess:
    Exit Function
End Function
 
Private Sub create_hidden_ribbon()
'create hidden ribbon if it does not already exists
If Not tableExists("USysRibbons") Then
    app.CurrentDb.Execute "CREATE TABLE USysRibbons (RibbonName CHAR, RibbonXML Memo);"
End If
    app.DoCmd.SetWarnings False
    app.DoCmd.RunSQL "DELETE * FROM USysRibbons WHERE RibbonName='HideTheRibbon';"
    
    app.DoCmd.RunSQL "INSERT INTO USysRibbons ( RibbonName, RibbonXML ) SELECT 'HideTheRibbon' AS RibbonName, '<customUI xmlns=" & Chr(34) & "http://schemas.microsoft.com/office/2009/07/customui" & Chr(34) & " > <ribbon startFromScratch=" & Chr(34) & "true" & Chr(34) & "> </ribbon> <backstage>  <button idMso=" & Chr(34) & "ApplicationOptionsDialog" & Chr(34) & " visible=" & Chr(34) & "false" & Chr(34) & "/> </backstage> </customUI>' AS RibbonXML;"
 
    app.DoCmd.SetWarnings True
End Sub
 
Private Sub HideMenu(HideIt As Boolean)
'hide or unhide menu
    If HideIt = True Then
       app.DoCmd.NavigateTo "acNavigationCategoryObjectType"
       app.DoCmd.RunCommand acCmdWindowHide
       app.DoCmd.ShowToolbar "Ribbon", acToolbarNo
    Else
       app.DoCmd.SelectObject acTable, , True
       app.DoCmd.ShowToolbar "Ribbon", acToolbarYes
    End If
End Sub
 
Private Sub SetBoolProp(PropName As String, PropVal As Boolean)
'set boolean properties in the current database
   Dim prop As Property
On Error GoTo setproperty
   Set prop = app.CurrentDb.CreateProperty(PropName, dbBoolean, PropVal)
   app.CurrentDb.Properties.Append prop
setproperty:
   app.CurrentDb.Properties(PropName) = PropVal
End Sub
 
Private Sub SetStrProp(PropName As String, PropVal As String)
'set string properties in the current database
   Dim prop As Property
On Error GoTo setproperty
   Set prop = CurrentDb.CreateProperty(PropName, dbText, PropVal)
   app.CurrentDb.Properties.Append prop
setproperty:
   app.CurrentDb.Properties(PropName) = PropVal
End Sub
 
Private Sub HideTables(hide As Boolean)
'if set to true hides all tables in current database else makes all tables visible
    Dim tdf As TableDef
    For Each tdf In app.CurrentDb.TableDefs
        If Not (tdf.name Like "USys*" Or tdf.name Like "MSys*" Or tdf.name Like "~*") Then
            If hide = True Then
                tdf.Attributes = dbHiddenObject
            Else
                tdf.Attributes = 0
            End If
        End If
    Next tdf
End Sub
 
Private Sub lockdown_settings(lockDB As Boolean, dbApp As Access.Application)
'locks down database if lockdb is true else unlocks the database
 
    On Error GoTo errHandler
    Call create_hidden_ribbon
    If lockDB Then
        SetBoolProp "StartupShowDBWindow", False
        SetBoolProp "StartupShowStatusBar", False
        SetBoolProp "AllowBuiltinToolbars", False
        SetBoolProp "AllowFullMenus", False
        SetBoolProp "AllowShortcutMenus", False
        SetBoolProp "AllowBreakIntoCode", False
        SetBoolProp "AllowSpecialKeys", False
        SetBoolProp "AllowBypassKey", False
        SetBoolProp "AllowAutoCorrect", False
        SetBoolProp "AllowBuiltInToolbars", False
        SetStrProp "CustomRibbonID", "HideTheRibbon"
        HideTables True
    Else
        SetBoolProp "StartupShowDBWindow", True
        SetBoolProp "StartupShowStatusBar", True
        SetBoolProp "AllowBuiltinToolbars", True
        SetBoolProp "AllowFullMenus", True
        SetBoolProp "AllowShortcutMenus", True
        SetBoolProp "AllowBreakIntoCode", True
        SetBoolProp "AllowSpecialKeys", True
        SetBoolProp "AllowBypassKey", True
        SetBoolProp "AllowAutoCorrect", True
        SetBoolProp "AllowBuiltInToolbars", True
        SetStrProp "CustomRibbonID", "ShowTheRibbon"
        HideTables False
    End If
    Exit Sub
errHandler:
    display_error
    Resume Next
End Sub
 
Private Sub display_error()
'display error code number and description in the immediate window
    Debug.Print Err.Number, Err.Description
End Sub
 
Sub lockDownApp(dbPath As String, Optional lockDB As Boolean = True, Optional password As String = "")
    Dim item As Variant
    'create and access application control
    Set app = New Access.Application
    'make the access database visible
    app.Visible = True
 
    'open the database at given location
    app.OpenCurrentDatabase filepath:=dbPath, bstrPassword:=password
 
    Call lockdown_settings(lockDB, app)
End Sub
 
Sub lockdown_test()
    'unlock a secure database tests
    Call lockDownApp("C:\Users\codec\Desktop\MS Access Lockdown database example\My Secured DB.accde", True)
    Call examine_form1
End Sub
 
Sub examine_form1()
'look through form1 controls and get record rowsource of names combos box and form record source!
    Dim item As Variant
    For Each item In app.CurrentProject.AllForms
        Debug.Print "Form Name: " & item.name
    Next item
    For Each item In app.Forms![Form1].Controls
 
        Select Case item.ControlType
        
        Case acTextBox
            Debug.Print "Control Name: " & item.name & "Control Type: TextBox"
        Case acComboBox
            Debug.Print "Control Name: " & item.name & "Control Type: TextBox"
        End Select
        
    Next item
    Debug.Print "Names Combobox rowsource: " & app.Forms![Form1].cboNames.RowSource
    Debug.Print "Form1 recordSource: "; app.Forms![Form1].RecordSource
    app.CloseCurrentDatabase
    Set app = Nothing
End Sub