' @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