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




Function CheckUser(username As String, passwd As String, Level As Integer) As Boolean

    On Error GoTo LDAP_Error

    username = "sharifu"
    passwd = "xxx"

    Const ADS_SCOPE_SUBTREE = 2

    Dim LDAPPath As String
    LDAPPath = "LDAP://172.16.0.12/OU=Sites;DC=domain;DC=com"

    Dim conn As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim rs As ADODB.Recordset

    Set conn = New ADODB.Connection
    Set cmd = New ADODB.Command
    conn.Provider = "ADsDSOObject"

    conn.Properties("User ID") = "domain\" & username
    conn.Properties("Password") = "" & passwd
    conn.Properties("Encrypt Password") = True
    'conn.Properties("ADSI Flag") = 3

    conn.Open "Active Directory Provider"
    Set cmd.ActiveConnection = conn

    cmd.Properties("Page Size") = 1000
    cmd.Properties("Searchscope") = ADS_SCOPE_SUBTREE


    cmd.CommandText = _
    "SELECT Name FROM '" & LDAPPath & "' WHERE " & "objectCategory='user'"

    Set rs = cmd.Execute

    rs.Close
    conn.Close

    CheckUser = True
    Exit Function

LDAP_Error:

    If Err.Number = -2147217911 Then

    MsgBox "Incorrect PeopleSoftID or Password!", vbExclamation, "HILDA"

    Else

    MsgBox "Error : " & Err.Description & " " & Err.Number, vbExclamation, "HILDA"

    End If
    CheckUser = False

    conn.Close


End Function








Public Function AllUsers() As String()

'PURPOSE:  Gets all user name for the current domain
'and returns them in a string array, using LDAP

'Requires: ADSI, LDAP provider
'This function tested on Windows 2000 RC2

'RETURNS: String array containing all
'Logon Names for the current domain

'Requires VB6 because in lower versions
'array cannot be return type for a
'function

'EXAMPLE
'Dim sArray() As String
'Dim iCtr As Integer

'sArray = AllUsers
'For iCtr = 0 To UBound(sArray)
'    Debug.Print sArray(iCtr)
'Next

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 iElement As Integer

On Error GoTo errhandler:

Set oRoot = GetObject("LDAP://rootDSE")
sDomain = oRoot.Get("defaultNamingContext")
Set oDomain = GetObject("LDAP://" & sDomain)
sBase = "<" & oDomain.ADsPath & ">"
sFilter = "(&(objectCategory=person)(objectClass=user))"
sAttribs = "name"
sDepth = "subTree"

sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth
                   
conn.Open _
  "Data Source=Active Directory Provider;Provider=ADsDSOObject"
  
Set rs = conn.Execute(sQuery)
ReDim sAns(0) As String

With rs
    Do While Not .EOF
        iElement = IIf(sAns(0) = "", 0, iElement + 1)
        ReDim Preserve sAns(iElement) As String
        sAns(iElement) = rs("name")
       .MoveNext
    Loop
End With
AllUsers = sAns

errhandler:

On Error Resume Next
If rs.State <> 0 Then rs.Close
If conn.State <> 0 Then conn.Close
Set rs = Nothing
Set conn = Nothing
Set oRoot = Nothing
Set oDomain = Nothing

End Function