It's a bit clunky, but I'll explain what's going on as best I can...
Disclaimer: This is probably NOT the best way to go about it, but it works
for my purposes so far. My only issue with it is that I don't have a
recursive function for reading the level on controls. Right now my controls
are only nested 2 deep... I stopped playing around with the module at some
point, other things to do, and it works for me now but is not quite ideal as
of yet. It's not far off, but it still needs a little work.
I hope you find this useful, quite frankly this was a real pain to pull
together and refresh myself on what I have going on. Luckily I included at
least some minor commenting to help me out. I don't mind, as long as
someone's getting some use out of it...
Overview:
The default main menu is turned off, replaced with a custom menubar named
"dsMenu". The File menu is setup up on it's own, regardless of user status.
The items are either enabled or disabled depending on whether a user is
currently logged in or not. Constants are used for the menu and menuitem
names to avoid hardcoding directly to the procedures. The functions are
called from startup in this sequence...
Startup: DSMenuLoggedState False
Login: DSMenuLoggedState True
SetUserMenus
Logout: DSMenuLoggedState False
You'll notice that the DSMenuLoggedState function includes a call to the
previously posted MenuControlsVisible, so on logout by calling the
LoggedState function you are inherently turning visibility off to all of the
controls.
The status of a logged user is held in a Public Property called gUSER. As a
side note, on Shutdown, the code checks for the existence of a user in the
gUSER property and runs the logout procedure if gUSER has a value. Also,
you'll notice that the SetUserMenus function references qryUMenus... this
query is a record listing of jtblUMenus (see below) based on the current
status of gUSER. If gUSER is blank, there qryUMenus contains no records and
therefore no changes are made to the menubar. This qry pulls values from
jtblUMenus and corresponding values from tblMenus, filtered by the active
user.
Here's the three tables that I use for this:
tblUsers
fldUser (PK - Text)
tblMenus
fldID (PK - Long Int)
fldName (str - ex "File" or "Reporting")
fldControlLevel (Integer - Level in Menu)
1 - Base level (on menu itself) (ex. Reporting)
2 - 2nd Level, ex Reporting -> Company Reports
fldParent (Long - fldID reference to the parent control)
this is only applicable on level 2+ ControlLevels
fldCommand (str - Function to run, ex dsCmdRunUMCompanies())
jtblUMenus (Junction table between tblUsers and tblMenus)
fldUser (PK - Text)
fldMenu (PK - Long Integer)
fldEnabled (Integer)
SQL for qryUMenus:
SELECT jtblUMenus.fldUser,
jtblUMenus.fldMenu,
jtblUMenus.fldEnabled,
tblMenus.fldName,
tblMenus.fldControlLevel,
tblMenus.fldParent
FROM jtblUMenus, tblMenus
WHERE ((([jtblUMenus].[fldUser])=gUSER()))
ORDER BY tblMenus.fldControlLevel;
And finally, the code....
'==============================
Option Compare Database
Option Explicit
' PUBLIC CONST FOR dsMENU NAME
Public Const cMB_DSMENU As String = "dsMenu"
'PRIVATE CONSTANTS FOR DSMENU
Private Const pcFILE As String = "File"
Private Const pcFILELOGIN As String = "Login"
Private Const pcFILELOGOUT As String = "Logout"
Private Const pcFILEEXIT As String = "Exit"
'==============================================================================
' NAME: DSMenuLoggedState
' DESC: Formats the File menu on dsMenu for logged out/in states
' This will run before user-specific menus on logi
'==============================================================================
'ErrStrV3.00
Public Function DSMenuLoggedState(bLogged As Boolean) As Boolean
On Error GoTo Error_Proc
Dim Ret As Boolean
'=========================
Dim cbar As CommandBar
Dim cbarc As CommandBarControl
'=========================
DoCmd.Echo False
'init visibility false on all commandbars
MenuControlsVisible cMB_DSMENU
'set command bar
Set cbar = Application.CommandBars(cMB_DSMENU)
cbar.Visible = True
cbar.Enabled = True
'Set File and Subsidaries
For Each cbarc In cbar.Controls(pcFILE).Controls
cbarc.Visible = True
Next
Set cbarc = Nothing
Set cbarc = cbar.Controls(pcFILE)
With cbarc
.Visible = True
.Enabled = True
.Controls(pcFILELOGIN).Enabled = Not bLogged
.Controls(pcFILELOGOUT).Enabled = bLogged
.Controls(pcFILEEXIT).Enabled = True
End With
Set cbarc = Nothing
Ret = True
'=========================
Exit_Proc:
DoCmd.Echo True
Set cbar = Nothing
Set cbarc = Nothing
DSMenuLoggedState = Ret
Exit Function
Error_Proc:
DoCmd.Echo True
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.Description & vbCrLf & vbCrLf & _
"Module: modMenuBars, Procedure: DSMenuLoggedState" _
, vbCritical, "Error!"
Resume Exit_Proc
Resume
End Function
'==============================================================================
' NAME: SetUserMenus
' DESC: Loops the qryUMenus and handles each menuitem accordingly
'
' !!!!!!! CURRENTLY HANDLES UP TO LEVEL 2 CONTROL ONLY !!!!!!!!!
'
'==============================================================================
'ErrStrV3.00
Public Function SetUserMenus() As Boolean
On Error GoTo Error_Proc
Dim Ret As Boolean
'=========================
Dim cbar As CommandBar 'dsMenu
Dim cbarc1 As CommandBarControl 'ControlLevel1 controls
Dim cbarc2 As CommandBarControl 'ControlLevel2 controls
Dim rs As DAO.Recordset 'qryUMenus
Dim sName As String 'control name
'=========================
'set dsMenu (cbar)
Set cbar = Application.CommandBars(cMB_DSMENU)
Set rs = CurrentDb.OpenRecordset("qryUMenus")
If rs.RecordCount <> 0 Then
rs.MoveFirst
While Not rs.EOF
'init cbarc's
Set cbarc1 = Nothing
Set cbarc2 = Nothing
If rs("fldControlLevel") = 1 Then
'this is a base control, no parent settings needed
'level 1 controls are automatically visible and have no enabled
setting
sName = rs("fldName")
cbar.Controls(sName).Visible = True
ElseIf rs("fldControlLevel") = 2 Then
'this is a second level control, 1 parent setting is required (cbarc1)
'set the parent control (cbarc1)
sName = ELookup("fldName", "tblMenus", "fldID = " & rs("fldParent"))
Set cbarc1 = cbar.Controls(sName)
'set the target control (cbarc2)
sName = rs("fldName")
Set cbarc2 = cbarc1.Controls(sName)
'set visible and enabled properties
cbarc2.Visible = True
cbarc2.Enabled = rs("fldEnabled")
End If
rs.MoveNext
Wend
End If
rs.Close
Ret = True
'=========================
Exit_Proc:
Set rs = Nothing
Set cbar = Nothing
Set cbarc1 = Nothing
Set cbarc2 = Nothing
SetUserMenus = Ret
Exit Function
Error_Proc:
rs.Close
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.Description & vbCrLf & vbCrLf & _
"Module: modMenuBars, Procedure: SetUserMenus" _
, vbCritical, "Error!"
Resume Exit_Proc
Resume
End Function
'==============================================================================
' NAME: RunMenuCmd
' DESC: Runs command based on passed Menu Index
' The Action event for the command in the menubar control
properties is set with the control's ID as the argument
' modCommands has the actual functions as stored in tblMenus
'==============================================================================
'ErrStrV3.00
Public Function RunMenuCmd(lIndex As Long) As Long
On Error GoTo Error_Proc
Dim Ret As Long
'=========================
Dim sCommand As String 'command to run
Dim x As Variant 'dummy return for Eval
'=========================
sCommand = Nz(ELookup("fldCommand", "tblMenus", "fldID = " & lIndex), "")
'verify return
If Len(sCommand) = 0 Then
MsgBox "An error has occured running a menu command." _
, vbCritical + vbOKOnly, "Error!"
GoTo Exit_Proc
End If
x = Eval(sCommand)
'=========================
Exit_Proc:
Exit Function
Error_Proc:
If Err.Number = 2425 Then 'command not found
MsgBox "An error has occured running a menu command." _
, vbCritical + vbOKOnly, "Error!"
Resume Exit_Proc
End If
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.Description & vbCrLf & vbCrLf & _
"Module: modMenuBars, Procedure: RunMenuCmd" _
, vbCritical, "Error!"
Resume Exit_Proc
Resume
End Function
'==============================================================================
' NAME: MenuControlsVisible
' DESC: Sets Visible property for every nested control in the passed
commandbar
' DEPENDANCY: pfRecurseControls()
'==============================================================================
'ErrStrV3.00
Public Function MenuControlsVisible( _
sMenuName As String, _
Optional bVisible As Boolean = False _
) As Boolean
On Error GoTo Error_Proc
Dim Ret As Boolean
'=========================
Dim cbarc As CommandBarControl
'=========================
For Each cbarc In CommandBars(sMenuName).Controls
pfRecuseControls cbarc, bVisible
Next cbarc
Ret = True
'=========================
Exit_Proc:
Set cbarc = Nothing
MenuControlsVisible = Ret
Exit Function
Error_Proc:
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.Description & vbCrLf & vbCrLf & _
"Module: modMenuBars, Procedure: MenuControlsVisible" _
, vbCritical, "Error!"
Resume Exit_Proc
Resume
End Function
'==============================================================================
' NAME: pfRecuseControls
' DESC: recurses itself for each nested set of controls found
'==============================================================================
'ErrStrV3.00
Private Function pfRecuseControls( _
cbarc As CommandBarControl, _
bVisible As Boolean _
)
On Error GoTo Error_Proc
'=========================
Dim ctl As CommandBarControl
'=========================
'find out if there's a controls collection
On Error Resume Next
Set ctl = cbarc.Controls(1)
If Err.Number = 0 Then
'theres further controls... handle them
Err.Clear
On Error GoTo Error_Proc
'recurse the function for the next nested set
For Each ctl In cbarc.Controls
pfRecuseControls ctl, bVisible
Next
ElseIf Err.Number = 438 Then
'no controls collection
Err.Clear
On Error GoTo Error_Proc
Else
'unexpected error
GoTo Error_Proc
End If
cbarc.Visible = bVisible
'=========================
Exit_Proc:
Set cbarc = Nothing
Exit Function
Error_Proc:
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.Description & vbCrLf & vbCrLf & _
"Module: modMenuBars, Procedure: pfRecuseControls" _
, vbCritical, "Error!"
Resume Exit_Proc
Resume
End Function
--
Jack Leach
www.tristatemachine.com
"I haven''t failed, I''ve found ten thousand ways that don''t work."
-Thomas Edison (1847-1931)
