Active Directory Authentication

[manthony]

Hi, I am trying to get this macro to work and getting nowhere fast. It involves a Private Sub UserForm_Click and a Public Function.

The idea is, I have a userform with two text boxes, one for employee ID (always numbers and text box named "txtUser.Value") and the other for password (can be numbers and/or text and text box named "txtPass.Value"). The person enters their information into the two text boxes and clicks a login button. The public function then compares their credentials from the computers/network active directory against what they typed in.

When I click login the Private Sub cmdCheck_Click() runs this code below and I get a 'compile error: expected array' that highlights the Private Sub cmdCheck_Click() line. Below is the code for the Private Sub cmdCheck_Click() and the Public Function that the Sub uses. Any help would be greatly appreciated. I am extremely stumped.



Private Sub cmdCheck_Click()
Dim UserInfoAuth As String
Dim strUserID As String
Dim strPassword As String


strUserID = Me.txtUser.Value
strPassword = Me.txtPass.Value


If Len(UserInfoAuth(Me.txtUser.Value, Me.txtPass.Value)) > 0 Then


MsgBox ("Did work")
Else


MsgBox ("Didn't work")
End If


End Sub




----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Public Function UserInfo(LoginName As String) As String
'PURPOSE: Display information that is available in
'the Active Directory about a given user


'PARAMETER: Login Name for user


'RETURNS: String with selected information about
'user, or empty string if there is no such
'login on the current domain


'REQUIRES: Windows 2000 ADSI, LDAP Provider
'Proper Security Credentials.


'EXAMPLE: msgbox UserInfo("Administrator")


Dim conn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim oRoot As IADs
Dim oDomain As IADs
Dim sBase As String
Dim sFilter As String
Dim sDomain As String


Dim sAttribs As String
Dim sDepth As String
Dim sQuery As String
Dim sAns As String


Dim user As IADsUser


On Error GoTo ErrHandler:


'Get user Using LDAP/ADO. There is an easier way
'to bind to a user object using the WinNT provider,
'but this way is a better for educational purposes
Set oRoot = GetObject("LDAP://rootDSE")
'work in the default domain
sDomain = oRoot.Get("defaultNamingContext")
Set oDomain = GetObject("LDAP://" & sDomain)
sBase = "<" & oDomain.ADsPath & ">"
'Only get user name requested
sFilter = "(&(objectCategory=person)(objectClass=user)(name=" _
& LoginName & "))"
sAttribs = "adsPath"
sDepth = "subTree"


sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth

conn.Open _
"Data Source=Active Directory Provider;Provider=ADsDSOObject"

Set rs = conn.Execute(sQuery)


If Not rs.EOF Then
Set user = GetObject(rs("adsPath"))
With user

'if the attribute is not stored in AD,
'an error will occur. Therefore, this
'will return data only from populated attributes
On Error Resume Next

sAns = "First Name: " & .FirstName & vbCrLf
sAns = sAns & "Last Name " & .LastName & vbCrLf
sAns = sAns & "Employee ID: " & .EmployeeID & vbCrLf
sAns = sAns & "Title: " & .Title & vbCrLf
sAns = sAns & "Division: " & .Division & vbCrLf
sAns = sAns & "Department: " & .Department & vbCrLf
sAns = sAns & "Manager: " & .Manager & vbCrLf


sAns = sAns & "Phone Number: " & .TelephoneNumber & vbCrLf
sAns = sAns & "Fax Number: " & .FaxNumber & vbCrLf

sAns = sAns & "Email Address: " & .EmailAddress & vbCrLf
sAns = sAns & "Web Page: " & .HomePage & vbCrLf
sAns = sAns & "Last Login: " & .LastLogin & vbCrLf
sAns = sAns & "Last Logoff: " & .LastLogoff & vbCrLf

sAns = sAns & "Account Expiration Date: " _
& .AccountExpirationDate & vbCrLf

'IN RC2, this returned 1/1/1970 when password
'never expires option is set
sAns = sAns & "Password Expiration Date: " _
& .PasswordExpirationDate

End With
End If
UserInfo = sAns
ErrHandler:


On Error Resume Next
If Not rs Is Nothing Then
If rs.State <> 0 Then rs.Close
Set rs = Nothing
End If


If Not conn Is Nothing Then
If conn.State <> 0 Then conn.Close
Set conn = Nothing
End If


Set oRoot = Nothing
Set oDomain = Nothing
End Function

 

[Jeffrey Mahoney]

If Len(UserInfoAuth(Me.txtUser.Value, Me.txtPass.Value)) > 0 Then

This doesn't make sense to me. You have Dimmed UserInfoAuth as a string, but yet you are calling it like a SUB. Strings cannot have variables passed to them.

 

[manthony]

Hi Jefferey,

Thank you for your help, and my apologies I am very new to VBA. If I change Dim UserInfoAuth As Variant and Dim strUserID As Boolean, strPassword As Boolean I get a type mismatch error.

I got code originally from this post: https://www.mrexcel.com/forum/excel...-using-excel-visual-basic-applications-2.html

I do not know if seeing that will help make thing clearer. Essentially I am trying to compare the ID and password that is entered into the userform to the ID and password stored elsewhere in our system.

Thank you again for your help.

 

[Jeffrey Mahoney]

Change your code to this and see what happens:

Private Sub cmdCheck_Click()
  Dim UserInfoAuth As String
  Dim strUserID As String
  Dim strPassword As String


  strUserID = Me.txtUser.Value
  strPassword = Me.txtPass.Value
  
  If Len(UserInfo(Me.txtUser.Value, Me.txtPass.Value)) > 0 Then
  
    MsgBox ("Did work")
  Else
    MsgBox ("Didn't work")
  End If




End Sub

 

[manthony]

Hi Jeffrey,

Thank you for the code, but no luck. I still get the same Complie error: expected array problem on the Private Sub cmdCheck_Click() line.

 

[xenou]

The function takes only a user name as input - only one variable. You are trying to give it two. No can do.
Also, it can't check the password so far as I can tell - the AD function doesn't use or provide a password. So I'm not sure why you are trying to give it one. That's even if it works at all - it's an old post and you have to try to verify it in a very simple way if it even works as shown.