| gianniskar | 16-06-20 12:04 |
Κλειδωμα βασης και αποκρυψη Ribbon
Καλησπερα.Εχω τον παρακατω κωδικα απο το 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
|
