mdlACCDE
' @title ACCDE protection
' @desc This module is used to protect a compiled Access application (ACCDE)
' @desc by setting properties and chanching the ribbon XML. By using this module you
' @desc can change the startup options of your application in a way the database
' @desc Window and developer tools will disappear and the special start up
' @desc keys are disabled.
' @desc Add this module to your project and add a call to ACCDE_init.
' @example ' Add this code to your start up function (AutoExec macro,
' @example ' start-up form or the ribbon onLoad callback function):
' @example Call ACCDE_init
Option Compare Database
Option Explicit
Const cVersion = "1.0"
Const cEyeCatcher = "ACCDEsecure"
Const cRibbonID = "CustomRibbonID"
Const cribbonBackstageTabel = "USysRibbons"
'--------------------------------------------------------------------------------
' @desc Base function to protect an ACCDE application. Make sure this function
' @desc is called at start up of your application.
' @tag System
' @see SetApplicationTitle
' @see ChangeProperty
' @see PropertyExists
' @see TableExists
' @see ChangeRibbon
'--------------------------------------------------------------------------------
Public Function ACCDE_init()
Dim i
' Set development stage
If Not IsACCDE() Then
Call SetApplicationTitle(cVersion, "development")
Exit Function
End If
' Here : it's a ACCDE
' Check if the eye-cather exists. If it does, this function
' already has been executed
If PropertyExists(cEyeCatcher) Then Exit Function
'
' Change the application title
'
Call SetApplicationTitle(cVersion)
'
' Set all necessary properties
ChangeProperty cEyeCatcher, dbBoolean, True
ChangeProperty "AllowBypassKey", dbBoolean, False
ChangeProperty "StartUpShowDBWindow", dbBoolean, False
ChangeProperty "StartUpShowStatusBar", dbBoolean, False
ChangeProperty "AllowShortCutMenus", dbBoolean, True
ChangeProperty "AllowFullMenus", dbBoolean, False
ChangeProperty "AllowBuiltInToolbars", dbBoolean, False
ChangeProperty "AllowToolbarChanges", dbBoolean, False
ChangeProperty "AllowSpecialKeys", dbBoolean, False
' Do we use a ribbon?
If PropertyExists(cRibbonID) Then
Dim ribbonName As String
' Get the name of the ribbon
ribbonName = CurrentDb.Properties(cRibbonID)
' Only possible when the USysRibbon table is used
If TableExists(cribbonBackstageTabel) Then
Dim rs As Recordset
' Get the riboon XML and remove the standard Access-stuff
Set rs = CurrentDb.OpenRecordset("SELECT RibbonXML " & _
"FROM " & cribbonBackstageTabel & _
" WHERE RibbonName = '" & ribbonName & "'")
If Not rs.EOF Then
rs.MoveFirst
rs.Edit
rs!RibbonXML = ChangeRibbon(rs!RibbonXML)
rs.Update
End If
rs.Close
Set rs = Nothing
End If
End If
' Application settings are secure now. Notify the user and quit the application.
' At next start up, this code is not called again
MsgBox "The application has been set up! Your application need to be restarted." & _
vbCrLf & _
"Click the OK button to close the application.", _
vbInformation, GetApplicationTitle()
Application.Quit
ACCDE_init_exit:
Exit Function
ACCDE_init_error:
Resume ACCDE_init_exit
End Function
'--------------------------------------------------------------------------------
' @desc Changes the Ribbon XML to remove the standard Access ribbons
' @desc and add a default backstage if no backstage has been defined.
' @parm XML The Ribbon XML to be changed
' @return The changed Ribbon XML
' @tag XML
'--------------------------------------------------------------------------------
Private Function ChangeRibbon(XML As String) As String
Dim pos As Long
Dim bsXML As String
' Changing the value of the startFormScratch attribute from false to true
' makes sure the standard Access-ribbons will disappear
XML = Replace(XML, _
"startFromScratch=" & Chr(34) & "false" & Chr(34), _
"startFromScratch=" & Chr(34) & "true" & Chr(34) & "")
' Check if some backstage logic is added to the Ribbon XML.
' If not then add an almost empty backstage to the XML.
pos = InStr(XML, "<backstage")
If pos = 0 Then
' Make sure only Print and Exit are available on the backstage
bsXML = "<backstage>" & _
ribbonBackstageTab("TabPrint", "true") & _
ribbonBackstageButton("ApplicationOptionsDialog", "false") & _
ribbonBackstageButton("FileExit", "true") & _
"</backstage>"
' Add Backstage XML by replacing the closing tag of the Ribbon itself
XML = Replace(XML, "</customUI>", bsXML & "</customUI>")
End If
ChangeRibbon = XML
End Function
'--------------------------------------------------------------------------------
'@desc @Private function which returns a @String containing XML for a
'@desc Button on the Backstage of the application.
'@parm idMso A valid Access Mso Id
'@parm visible Contains "true" or "false" to indicate the button is visible or not
'@return XML for the specified button
'@see ChangeRibbon
'@tag XML
'--------------------------------------------------------------------------------
Private Function ribbonBackstageButton(idMso As String, _
visible As String) As String
ribbonBackstageButton = "<button idMso=" & Chr(34) & idMso & Chr(34) & _
" visible=" & Chr(34) & visible & Chr(34) & "/>"
End Function
'--------------------------------------------------------------------------------
'@desc @Private function which returns a @String containing XML for a
'@desc Tab on the Backstage of the application.
'@parm idMso A valid Access Mso Id
'@parm visible Contains "true" or "false" to indicate the tab is visible or not
'@return XML for the specified tab
'@see ChangeRibbon
'@tag XML
'--------------------------------------------------------------------------------
Private Function ribbonBackstageTab(idMso As String, _
visible As String) As String
ribbonBackstageTab = "<tab idMso=" & Chr(34) & idMso & Chr(34) & _
" visible=" & Chr(34) & visible & Chr(34) & "/>"
End Function