VBA Code to secure access
Hi I need help improving a VBA code that someone created for me in 2012using Access 2010 while working at a different agency using a different network server. The code searches for a user's network name in a table called "tblAccess", if their network name isn't in the table, the users will get a message saying that they are not authorized and kick them out of the database. For users who are in the tblAccess table, the objects (tables and etc) are automatically hidden depending on a user's access level. There are two fields in the tblAccess - NetworkName and ScreenAccess (this grants access to certain forms using commands). Also, there is another code that searches for a user's network name in a table called "tblAdmins", if their network name isn't in the table, users will not have the ability to see the objects (tables and etc). The way that this happens is that there is a button that unhide the objects when clicked if the user's name is in the table. If a user name isn't in the table, the unhide button isn't visible. There is only one filed in the tblAdmin table - NetworkName.
The issue that I am having is that the code isn't working 100% correctly here at the new location. For one, at the old location, the code prevented users from right clicking the form to see the form in design view. Now, users who have access can right click the form and view the form in design view. For two, the code only prevents people who are using Access 2010. For people using Access 2013, they are able to access the database although their network name isn't listed in the tblAccess table. Below are the codes:
Module Code:
Option Compare Database
Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Const NoError = 0
Public Function CheckAdmins() As Boolean
Dim rs As ADODB.Recordset
Dim conn As ADODB.Connection
Dim c As String
Set conn = CurrentProject.Connection
Set rs = New ADODB.Recordset
c = "select count(id) as ADMINS from tblAdmins where NetworkName = '" & GetUserName & "';"
rs.ActiveConnection = conn
rs.Source = c
rs.CursorLocation = adUseServer
rs.LockType = adLockReadOnly
rs.CursorType = adOpenDynamic
rs.Open
CheckAdmins = False
If rs!ADMINS = 1 Then
CheckAdmins = True
End If
rs.Close
Set rs = Nothing
End Function
Public Function CA() As String
Dim rs As ADODB.Recordset
Dim conn As ADODB.Connection
Dim c As String
Set conn = New ADODB.Connection
Set conn = CurrentProject.AccessConnection
Set rs = New ADODB.Recordset
c = "select * from tblAccess where NetworkName = '" & GetUserName & "';"
rs.ActiveConnection = conn
rs.Source = c
rs.CursorLocation = adUseServer
rs.LockType = adLockReadOnly
rs.CursorType = adOpenDynamic
rs.Open
If rs.EOF Then
If CheckAdmins = False Then
MsgBox "You Are Not Authorized"
Application.Quit
End If
Else
CA = rs!ScreenAccess
End If
rs.Close
Set rs = Nothing
End Function
Function GetUserName()
Const lpnLength As Integer = 255
Dim STATUS As Integer
Dim lpName, lpUserName As String
lpUserName = Space$(lpnLength + 1)
STATUS = WNetGetUser(lpName, lpUserName, lpnLength)
If STATUS = NoError Then
lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
Else
MsgBox "Unable to get the name."
End
End If
GetUserName = lpUserName
End Function
Public Function UnHideIt()
If isDisableShift Then
If MsgBox("Do you want to Enable Shift", vbYesNo) = vbYes Then
ap_EnableShift
End If
End If
DoCmd.SelectObject acTable, "Form - Home", True
End Function
Public Function HideIt()
ap_DisableShift
DoCmd.SelectObject acTable, "Form - Home", True
DoCmd.RunCommand acCmdWindowHide
End Function
Function ap_EnableShift()
On Error GoTo errEnableShift
Dim db As DAO.Database
Dim prop As DAO.Property
Const conPropNotFound = 3270
Set db = CurrentDb()
db.Properties("AllowByPassKey") = True
Exit Function
errEnableShift:
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _
dbBoolean, True)
db.Properties.Append prop
Resume Next
Else
MsgBox "Function 'ap_DisableShift' did not complete successfully."
Exit Function
End If
End Function
Function isDisableShift() As Boolean
On Error GoTo errDisableShift
Dim db As DAO.Database
Dim prop As DAO.Property
Const conPropNotFound = 3270
Set db = CurrentDb()
isDisableShift = False
If db.Properties("AllowByPassKey") = False Then
isDisableShift = True
End If
Exit Function
errDisableShift:
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _
dbBoolean, False)
db.Properties.Append prop
Resume Next
Else
MsgBox "Function 'ap_DisableShift' did not complete successfully."
Exit Function
End If
End Function
Function ap_DisableShift()
On Error GoTo errDisableShift
Dim db As DAO.Database
Dim prop As DAO.Property
Const conPropNotFound = 3270
Set db = CurrentDb()
db.Properties("AllowByPassKey") = False
Exit Function
errDisableShift:
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _
dbBoolean, False)
db.Properties.Append prop
Resume Next
Else
MsgBox "Function 'ap_DisableShift' did not complete successfully."
Exit Function
End If
End Function
Form Code (where the unhide button resides):
Private Sub cmdUnhide_Click()
UnHideIt
End Sub
Private Sub Form_Current()
End Sub
Private Sub Form_Load()
Dim a As String
HideIt
cmdUnhide.Enabled = False
cmdUnhide.Visible = False
If CheckAdmins Then
cmdUnhide.Enabled = True
cmdUnhide.Visible = True
End If
a = CA
If a = "" Then
a = "admin"
End If
Command310.Enabled = False
Command248.Enabled = False
Command315.Enabled = False
If a = "View ASAP Master List" Then
Command248.Enabled = True
ElseIf a = "Manage ASAP Master List" Then
Command310.Enabled = True
ElseIf a = "Budget Personnel" Then
Command315.Enabled = True
ElseIf a = "admin" Then
Command310.Enabled = True
Command248.Enabled = True
Command315.Enabled = True
End If
ap_EnableShift
End Sub
|