EUREKA!!!!
Code:
Public Function AuthenticateAD(Username As String, Optional Password As String = "") As Boolean
On Error GoTo Error_AuthenticateAD
Dim adoConn As New ADODB.Connection
Dim rst As ADODB.Recordset
Dim objDomain As Object
Dim objUser As Object
Dim strAttribs As String
Dim strBase As String
Dim strDepth As String
Dim strFilter As String
Dim strLoginName As String
Dim strQuery As String
AuthenticateAD = False
Set objDomain = GetObject("LDAP://" & GetObject("LDAP://rootDSE").Get("defaultNamingContext"))
strBase = "<" & objDomain.ADsPath & ">"
strAttribs = "adsPath"
strDepth = "subTree"
strFilter = "(&(objectCategory=person)" & _
"(objectClass=user)" & _
"(cn=" & Username & "))"
strQuery = strBase & ";" & strFilter & ";" & strAttribs & ";" & strDepth
On Error Resume Next ' Don't break on failed login
adoConn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject", Username, Password
Set rst = adoConn.Execute(strQuery)
Debug.Print "Login Attempt 1, Username=" & Username & ", Error=" & Err.Number
If Err.Number = -2147217911 Then
' User Name and SAM Account Name may be different, check!
On Error GoTo 0
adoConn.Close
adoConn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject" ' Connect anonymously to search for User Name
' Look for the CN of our current User ID
strFilter = "(&(objectCategory=person)" & _
"(objectClass=user)" & _
"(sAMAccountName=" & Username & "))"
strQuery = strBase & ";" & strFilter & ";" & strAttribs & ";" & strDepth
Set rst = adoConn.Execute(strQuery) ' Search!
If Not rst.RecordCount = 0 Then
Set objUser = GetObject(rst("adsPath"))
strLoginName = objUser.cn
Set objUser = Nothing
On Error Resume Next
Err.Clear
adoConn.Close
adoConn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject", strLoginName, Password
Set rst = adoConn.Execute(strQuery)
Debug.Print "Login Attempt 2, Username=" & strLoginName & ", Error=" & Err.Number
On Error GoTo 0
End If
End If
If Err.Number = 0 Then
AuthenticateAD = True
End If
Function_Closing:
If Not rst Is Nothing Then
If rst.State <> 0 Then
rst.Close
End If
Set rst = Nothing
End If
If Not adoConn Is Nothing Then
If adoConn.State <> 0 Then
adoConn.Close
End If
Set adoConn = Nothing
End If
Set objDomain = Nothing
Exit Function
Error_AuthenticateAD:
AuthenticateAD = False
Resume Function_Closing
End Function
The above function will return True if the user exists in Active Directory AND the supplied password matches. I had to add an extra check because (at least where I work), the actual name of the User Object in AD and the "login account name" aren't always the same.