Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement