Κλειδωμα βασης και αποκρυψη Ribbon

[gianniskar]

Καλησπερα.Εχω τον παρακατω κωδικα απο το forum.Θα ηθελα αν γινεταιοταν κλειδωνει η βαση να γινεται και αποκρυψη του ribbon.

Option Compare Database
Option Explicit
Const PropertyNotFound = 3270
Const DB_BOOLEAN = 1
Public pass As String
Dim msg As Integer

Function LockUnlockDatabase()
    Dim LockMode As Boolean, LockPassword As String
    LockMode = DLookup("IsLocked", "AdminLogin", "ID <>0")
    LockPassword = DLookup("LockPass", "AdminLogin", "ID <>0")
    On Error Resume Next
    If LockPassword = pass Then
    
    
        SetProperty "StartupShowDBWindow", DB_BOOLEAN, LockMode
        SetProperty "StartupShowStatusBar", DB_BOOLEAN, LockMode
        SetProperty "AllowBuiltinToolbars", DB_BOOLEAN, LockMode
        'SetProperty "AllowFullMenus", DB_BOOLEAN, LockMode
        SetProperty "AllowToolbarChanges", DB_BOOLEAN, LockMode
        SetProperty "AllowBreakIntoCode", DB_BOOLEAN, LockMode
        SetProperty "AllowSpecialKeys", DB_BOOLEAN, LockMode
        SetProperty "AllowBypassKey", DB_BOOLEAN, LockMode
        Application.SetOption "Show Hidden Objects", LockMode
        CurrentDb.Execute "UPDATE AdminLogin SET [IsLocked] = " & Int(Not LockMode)

End If
        msg = MsgBox("The current database is now " & IIf(LockMode, "unlocked!", "locked!") & _
               vbLf & "You must restart the current database for the specified options to take effect.", vbOKCancel)
        If msg = vbOK Then
            Restarter.RestartThisDB
        End If
    End If
   
End Function

Function SetProperty(PropertyName As String, PropertyType, PropertyValue)
    Dim prp As Object
    On Error GoTo ErrH
    With CurrentDb
        .Properties(PropertyName) = PropertyValue
ErrH:
        If err = PropertyNotFound Then
            Set prp = .CreateProperty(PropertyName, PropertyType, PropertyValue)
            .Properties.Append prp
            Resume Next
        End If
    End With
End Function
Function LoadLockedRibbon(ShowOptionsButton As String, startFromScratch As String)
    Dim strXML
    strXML = "<customUI xmlns=""http://schemas.microsoft.com/office/2009/07/customui"">" & _
             "<ribbon startFromScratch=""" & startFromScratch & """>" & _
             "</ribbon>" & _
             "<backstage>" & _
             "<button idMso=""ApplicationOptionsDialog"" visible=""" & ShowOptionsButton & """/>" & _
             "</backstage>" & _
             "</customUI>"
    CurrentDb.Execute "UPDATE USysRibbons SET USysRibbons.RibbonXml = '" & strXML & "' WHERE USysRibbons.ID=1"
End Function