Active Directory authentication using Excel VBA

[DMcClenagan]

Hi,

From an Excel workbook userform, I want to capture a logon name and password, and then authenticate against Active Directory.

The only information I want from the process is whether the user name/password combination is valid in AD.

I know how to do all the Excel stuff (userform, etc.), and I know how to get information from AD using an administrator binding. What I am missing is being able to verify whether the Excel workbook user is the AD user that they claim to be.

Thanks,

Don McClenagan
vbatrain.com

 

[xenou]

Found this today rather by accident. I have no idea if its what you need but the first function on the page seems to be different from the API call - who knows?

http://www.vbaexpress.com/kb/getarticle.php?kb_id=768

 

[kolle_hond]

<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]Private Function ValidateActiveDirectoryLogin(ByVal Domain As String, ByVal Username As String, ByVal Password As String) As Boolean
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]        Dim Success As Boolean = False
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]        Dim Entry As New System.DirectoryServices.DirectoryEntry("LDAP://" & Domain, Username, Password)
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]        Dim Searcher As New System.DirectoryServices.DirectorySearcher(Entry)
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]        Searcher.SearchScope = DirectoryServices.SearchScope.OneLevel
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]        Try
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]            Dim Results As System.DirectoryServices.SearchResult = Searcher.FindOne
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]            Success = Not (Results Is Nothing)
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]        Catch
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]            Success = False
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]        End Try
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]        Return Success
[/FONT]
<li style="font-family: 'Courier New',Courier,monospace; color: black; font-weight: normal; font-style: normal;">[FONT=Courier New]    End Function [/FONT]

got it here

​

 

[kolle_hond]

Sorry about that, that was vb code and not vba.
I have however figured it out so for anyone who wants the function, here you go:

Public Function UserInfoAuth(LoginName As String, Pass 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 Object
Dim oDomain As Object
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 Object

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)(sAMaccountname=" _
  & LoginName & "))"
sAttribs = "adsPath"
sDepth = "subTree"

sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth
 
conn.Open _
  "Data Source=Active Directory Provider;Provider=ADsDSOObject", UserInfo(LoginName), Pass
  
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
UserInfoAuth = sAns
Exit Function
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

Loads of thanks to the original author of the information query (sorry, I couldn't remember who you were)
The code is used like this:

If Len(UserInfoAuth(TextBox1.Text, TextBox2.Text)) > 0 Then
'what happens when authentication is validated
else
'if user is not validated
end if

 

[janknation]

Hello All.

I am getting a Sub or Function Not Defined error when hitting the line conn.Open _
"Data Source=Active Directory Provider;Provider=ADsDSOObject", UserInfo(LoginName), Pass.

I have had to add several References via Tools > Reference. Not sure what is going on here? Sorry still some what of a VBA noob.

Any help would be greatly appreciated.

 

[kolle_hond]

Sorry, that is my fault. The system I wrote it for had different usernames and id's (this was quite frustrating). UserInfo() was just a conversion function I wrote. Just replace

UserInfo(LoginName)

with

LoginName

Terribly sorry about that.

 

[janknation]

Thanks Kolle.

I am getting everything to compile just find now. I still can't seem to implement this correctly in my code though.

My code is pretty straight forward (see below):

Code:

Public Sub CommandButton1_Click()
Dim varConnection
Dim varSQL
Dim oQt As QueryTable
Dim user As String
Dim password As String

'Opens a "Login" userform which asks for a username and password
UserForm1.Show

'these variables get used later when creating a ODBC connection
user = UserForm1.txt_user.Value
password = UserForm1.txt_password.Value

If Len(UserInfoAuth(UserForm1.txt_user.Value, UserForm1.txt_password.Value)) > 0 Then

MsgBox ("Did work")

.... a bunch of other code

Else

MsgBox ("Didn't work")

Unload UserForm1

End If

End Sub

 

[kolle_hond]

Thanks Kolle.

I am getting everything to compile just find now. I still can't seem to implement this correctly in my code though.

My code is pretty straight forward (see below):

Code:

Public Sub CommandButton1_Click()
Dim varConnection
Dim varSQL
Dim oQt As QueryTable
Dim user As String
Dim password As String

'Opens a "Login" userform which asks for a username and password
UserForm1.Show

'these variables get used later when creating a ODBC connection
user = UserForm1.txt_user.Value
password = UserForm1.txt_password.Value

If Len(UserInfoAuth(UserForm1.txt_user.Value, UserForm1.txt_password.Value)) > 0 Then

MsgBox ("Did work")

.... a bunch of other code

Else

MsgBox ("Didn't work")

Unload UserForm1

End If

End Sub

You try to authenticate before you have the chance of entering data. The form should be shown first and not called when you click the "login" button. I would also recommend using the "user" and "password" variables that you declared instead of the textboxes themselves. If that still doesn't work you must just make sure that the data in the active directory is correct. That's all I can think of right now, hope it helps.

 

[willwillpower]

Just thought I'd post a relatively simple way to do the same thing:

Function Authenticated(strUserID As String, strPassword As String, Optional strDNSDomain As String = "") As Boolean
If strDNSDomain = "" Then
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
End If

'Authenticate
Set dso = GetObject("LDAP:")
On Error Resume Next
Err.Clear
Set ou = dspenDSObject("LDAP://" & strDNSDomain, strUserID, strPassword, 1)
Authenticated = (Err.Number = 0)

End Function

 

[csigurdsson]

Sorry, that is my fault. The system I wrote it for had different usernames and id's (this was quite frustrating). UserInfo() was just a conversion function I wrote. Just replace

UserInfo(LoginName)

with

LoginName

Terribly sorry about that.

The returned record set is empty? any suggestions / explaination