· 6 years ago · Nov 11, 2019, 05:50 AM
1Option Compare Database
2Option Explicit
3'This module locks down the current database
4'global microsoft access object
5Private app As Access.Application
6
7Public Function tableExists(TBLNAME As String) As Boolean
8'returns true if the table exists in the current database else false
9'The comparison is case insensitive
10 Dim tdf As TableDef
11 For Each tdf In app.CurrentDb.TableDefs
12 If StrComp(TBLNAME, tdf.name, vbTextCompare) = 0 Then
13 tableExists = True
14 GoTo exitSuccess
15 End If
16 Next tdf
17exitSuccess:
18 Exit Function
19End Function
20
21Private Sub create_hidden_ribbon()
22'create hidden ribbon if it does not already exists
23If Not tableExists("USysRibbons") Then
24 app.CurrentDb.Execute "CREATE TABLE USysRibbons (RibbonName CHAR, RibbonXML Memo);"
25End If
26 app.DoCmd.SetWarnings False
27 app.DoCmd.RunSQL "DELETE * FROM USysRibbons WHERE RibbonName='HideTheRibbon';"
28
29 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;"
30
31 app.DoCmd.SetWarnings True
32End Sub
33
34Private Sub HideMenu(HideIt As Boolean)
35'hide or unhide menu
36 If HideIt = True Then
37 app.DoCmd.NavigateTo "acNavigationCategoryObjectType"
38 app.DoCmd.RunCommand acCmdWindowHide
39 app.DoCmd.ShowToolbar "Ribbon", acToolbarNo
40 Else
41 app.DoCmd.SelectObject acTable, , True
42 app.DoCmd.ShowToolbar "Ribbon", acToolbarYes
43 End If
44End Sub
45
46Private Sub SetBoolProp(PropName As String, PropVal As Boolean)
47'set boolean properties in the current database
48 Dim prop As Property
49On Error GoTo setproperty
50 Set prop = app.CurrentDb.CreateProperty(PropName, dbBoolean, PropVal)
51 app.CurrentDb.Properties.Append prop
52setproperty:
53 app.CurrentDb.Properties(PropName) = PropVal
54End Sub
55
56Private Sub SetStrProp(PropName As String, PropVal As String)
57'set string properties in the current database
58 Dim prop As Property
59On Error GoTo setproperty
60 Set prop = CurrentDb.CreateProperty(PropName, dbText, PropVal)
61 app.CurrentDb.Properties.Append prop
62setproperty:
63 app.CurrentDb.Properties(PropName) = PropVal
64End Sub
65
66Private Sub HideTables(hide As Boolean)
67'if set to true hides all tables in current database else makes all tables visible
68 Dim tdf As TableDef
69 For Each tdf In app.CurrentDb.TableDefs
70 If Not (tdf.name Like "USys*" Or tdf.name Like "MSys*" Or tdf.name Like "~*") Then
71 If hide = True Then
72 tdf.Attributes = dbHiddenObject
73 Else
74 tdf.Attributes = 0
75 End If
76 End If
77 Next tdf
78End Sub
79
80Private Sub lockdown_settings(lockDB As Boolean, dbApp As Access.Application)
81'locks down database if lockdb is true else unlocks the database
82
83 On Error GoTo errHandler
84 Call create_hidden_ribbon
85 If lockDB Then
86 SetBoolProp "StartupShowDBWindow", False
87 SetBoolProp "StartupShowStatusBar", False
88 SetBoolProp "AllowBuiltinToolbars", False
89 SetBoolProp "AllowFullMenus", False
90 SetBoolProp "AllowShortcutMenus", False
91 SetBoolProp "AllowBreakIntoCode", False
92 SetBoolProp "AllowSpecialKeys", False
93 SetBoolProp "AllowBypassKey", False
94 SetBoolProp "AllowAutoCorrect", False
95 SetBoolProp "AllowBuiltInToolbars", False
96 SetStrProp "CustomRibbonID", "HideTheRibbon"
97 HideTables True
98 Else
99 SetBoolProp "StartupShowDBWindow", True
100 SetBoolProp "StartupShowStatusBar", True
101 SetBoolProp "AllowBuiltinToolbars", True
102 SetBoolProp "AllowFullMenus", True
103 SetBoolProp "AllowShortcutMenus", True
104 SetBoolProp "AllowBreakIntoCode", True
105 SetBoolProp "AllowSpecialKeys", True
106 SetBoolProp "AllowBypassKey", True
107 SetBoolProp "AllowAutoCorrect", True
108 SetBoolProp "AllowBuiltInToolbars", True
109 SetStrProp "CustomRibbonID", "ShowTheRibbon"
110 HideTables False
111 End If
112 Exit Sub
113errHandler:
114 display_error
115 Resume Next
116End Sub
117
118Private Sub display_error()
119'display error code number and description in the immediate window
120 Debug.Print Err.Number, Err.Description
121End Sub
122
123Sub lockDownApp(dbPath As String, Optional lockDB As Boolean = True, Optional password As String = "")
124 Dim item As Variant
125 'create and access application control
126 Set app = New Access.Application
127 'make the access database visible
128 app.Visible = True
129
130 'open the database at given location
131 app.OpenCurrentDatabase filepath:=dbPath, bstrPassword:=password
132
133 Call lockdown_settings(lockDB, app)
134End Sub
135
136Sub lockdown_test()
137 'unlock a secure database tests
138 Call lockDownApp("C:\Users\codec\Desktop\MS Access Lockdown database example\My Secured DB.accde", True)
139 Call examine_form1
140End Sub
141
142Sub examine_form1()
143'look through form1 controls and get record rowsource of names combos box and form record source!
144 Dim item As Variant
145 For Each item In app.CurrentProject.AllForms
146 Debug.Print "Form Name: " & item.name
147 Next item
148 For Each item In app.Forms![Form1].Controls
149
150 Select Case item.ControlType
151
152 Case acTextBox
153 Debug.Print "Control Name: " & item.name & "Control Type: TextBox"
154 Case acComboBox
155 Debug.Print "Control Name: " & item.name & "Control Type: TextBox"
156 End Select
157
158 Next item
159 Debug.Print "Names Combobox rowsource: " & app.Forms![Form1].cboNames.RowSource
160 Debug.Print "Form1 recordSource: "; app.Forms![Form1].RecordSource
161 app.CloseCurrentDatabase
162 Set app = Nothing
163End Sub