LDAP VBA Authentication

[VBAHelper]

I couldn't find an answer to how to use Active Directory for authentication using just VBA. I did find an example of logging in with alternate credentials which was the answer. The premise is that you attempt to login with the username and password combination. If it fails you get an error returned, if not the combination is valid. Since the userpassword field is write only, this is the only way to validate a password.

Const ADS_SECURE_AUTHENTICATION = &H1
Const ADS_SERVER_BIND = &H200
Public Sub CheckUser()
If Authenticate(Authentication_Form.UserName.Text, Authentication_Form.Password.Value) Then
MsgBox "Login Successful"
Else
MsgBox "User name and password combination did not match"
End If
End Sub
 
'Verify username and password combination are valid
Public Function Authenticate(strUser As String, strPassword As String) As Boolean
On Error GoTo ReportError
' Specify a server (Domain Controller).
strServer = "" 'Enter your server name here
 
' Determine DNS domain name. Use server binding and alternate ‘ credentials. The value of strDNSDomain can also be hard coded.
Set objNS = GetObject("LDAP:")
Set objRootDSE = objNS.OpenDSObject("LDAP://" & strServer & "/RootDSE", strUser, strPassword, ADS_SERVER_BIND Or ADS_SECURE_AUTHENTICATION)
 
strDNSDomain = objRootDSE.Get("defaultNamingContext")
 
Set objCommand = CreateObject("ADODB.Command")
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Properties("User ID") = strUser
objConnection.Properties("Password") = strPassword
objConnection.Properties("Encrypt Password") = True
objConnection.Properties("ADSI Flag") = ADS_SERVER_BIND Or ADS_SECURE_AUTHENTICATION
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
Authenticate = True 'If you were able to login the function returns true, it returns false if you received an error
 
ReportError:
   'This is the error number displayed when the login is not successful
   If Err.Number = -2147023570 Then
      Authenticate = False
   End If
End Function