Option Compare Database
Option Explicit
' Note: If at all possible use the code for the Active
' Directory Login. This is more secure and easier
' to maintain.
' These variables are populated by the password code and
' are mainly used for security within the databases.
'User Name for Menu and Code for Who Added the Rec?
Global UserName As String
Global UserCode As String
Global IsAdministrator As Boolean
Global ProjectName As String
Global MySwitchboard As String
Global MyLogNo As Long
' !!!! Code for Passwords if Active Directory is available
'Variable to get the url for active directory
Public gstrLDAPURL As String
'Password setup
Global Password As String
Global VerifyPassword As String
Declare Function WNetGetUser Lib "mpr.dll" _
Alias "WNetGetUserA" (ByVal lpName As String, _
ByVal lpUserName As String, lpnLength As Long) As Long
Const NoError = 0 'The Function call was successful
Public Function GetUserName() As String
' Buffer size for the return string.
Const lpnLength As Integer = 255
' Get return buffer space.
Dim Status As Integer
' For getting user information.
Dim lpName, lpUserName As String
' Assign the buffer size constant to lpUserName.
lpUserName = Space$(lpnLength + 1)
' Get the log-on name of the person using product.
Status = WNetGetUser(lpName, lpUserName, lpnLength)
' See whether error occurred.
If Status = NoError Then
' This line removes the null character. Strings in C are null-
' terminated. Strings in Visual Basic are not null-terminated.
' The null character must be removed from the C strings to be used
' cleanly in Visual Basic.
lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
GetUserName = lpUserName
Else
GetUserName = "Unknown"
End If
End Function
Public Function Authenticate(strUserName As String, strPassword As String) As Boolean
On Error Resume Next
Dim conLDAP As ADODB.Connection
Dim strSQL As String
Dim strLDAPConn As String
Dim rsUser As ADODB.Recordset
Dim arrDesc
Set conLDAP = New ADODB.Connection
conLDAP.Provider = "ADSDSOOBject"
strSQL = "Select AdsPath, cn From 'LDAP://" & gstrLDAPURL _
& "' where objectClass='user'" _
& " and objectcategory='person' and" _
& " SamAccountName='" & strUserName & "'"
conLDAP.Provider = "ADsDSOObject"
conLDAP.Properties("User ID") = strUserName
conLDAP.Properties("Password") = strPassword
conLDAP.Properties("Encrypt Password") = True
'open connection + password
conLDAP.Open "DS Query", strUserName, strPassword
'execute LDAP query
Err.Clear
Set rsUser = conLDAP.Execute(strSQL)
'rs will be empty if authentication fail
Authenticate = False
If Err.Number = 0 Then
If Not (rsUser Is Nothing) Then
If Not (rsUser.EOF And rsUser.BOF) Then
Authenticate = True
End If
End If
ElseIf Err.Number = -2147217865 Then
MsgBox "Error in LDAP settings" & vbCrLf _
& "Call Admin"
End If
End Function
Function CheckAccess() As Boolean
' This function checks the users access to this database
If IsNull(DLookup("[Menu_Group]", "[UserLog]", "[User ID]= '" & UserName & "' and [Database]= '" & ProjectName & "'")) Then
CheckAccess = False
Else
MyLogNo = DLookup("[LogNo]", "[UserLog]", "[User ID]= '" & UserName & "' and [Database]= '" & ProjectName & "'")
MySwitchboard = DLookup("[Menu_Group]", "[UserLog]", "[LogNo]= " & MyLogNo)
UserCode = DLookup("[StaffID]", "[UserLog]", "[LogNo]= " & MyLogNo)
If DLookup("[Administrator]", "[UserLog]", "[LogNo]= " & MyLogNo) < 0 Then
IsAdministrator = True
End If
CheckAccess = True
End If
End Function
' !!!! Code for Passwords when Active Directory is NOT Available
Function Encr(In_Text As String) As String
Dim I As Integer
Dim Out_Num As Long
Dim Out_Text As String
On Error GoTo Encr_Error
Out_Num = 1
For I = 1 To Len(In_Text)
Out_Num = Out_Num + Asc(Mid$(In_Text, I, 1))
Next I
Encr = CStr(Out_Num)
Encr_Done:
Exit Function
Encr_Error:
Warning Error$, "Encr"
Resume Encr_Done
End Function
