' From the book "Active Directory, Third Edition" 
' ISBN: 0-596-10173-2

'**********************************************************************
'SearchAD Function (returns Boolean success or failure)
'**********************************************************************
Function SearchAD(ByVal strLDAPBase, ByVal strCriteria, ByVal strDepth, _
  ByVal strAttributeList, ByRef arrResults())
   
  Dim objConn, objComm, objRS
  Dim objDisconRS, intArrayIndex, attrib 
  Dim intAttributeArrayIndex, arrAttributes, arrAttributesUb 
   
  '**********************************************************************
  'Split out attributes to build disconnected recordset
  '**********************************************************************
  arrAttributes = Split(strAttributeList,",")
  arrAttributesUb = UBound(arrAttributes)
  
  On Error Resume Next
   
  '**********************************************************************
  'Create a disconnected recordset that we will use
  ' for temporary data storage
  '**********************************************************************
  Const adUseClient = 3
  Const adVarChar = 200
  Const maxCharacters = 255
   
  Set objDisconRS = CreateObject("ADODB.Recordset")
  objDisconRS.CursorLocation = adUseClient
  For intAttributeArrayIndex = 0 To arrAttributesUb
    attrib=arrAttributes(intAttributeArrayIndex)
    objDisconRS.Fields.Append attrib, adVarChar, MaxCharacters
  Next
  objDisconRS.Open
   
  '**********************************************************************
  'Used to specify an unsuccessful ADO connection
  '**********************************************************************
  Const adStateClosed = 0
   
  '**********************************************************************
  'Defined in ADS_SCOPEENUM (in the ADSI documentation) for a full 
  'subtree search starting at the defined root
  '**********************************************************************
  Const ADS_SCOPE_SUBTREE = 2 
   
  Set objConn = CreateObject("ADODB.Connection")
  Set objComm = CreateObject("ADODB.Command")
  Set objRS = CreateObject("ADODB.Recordset")
   
  objConn.Provider = "ADSDSOObject"
  objConn.Open "", vbNullString, vbNullString
   
  '**********************************************************************
  'If connection failed, then return FALSE
  '**********************************************************************
  If objConn.State = adStateClosed Then
    SearchAD = False
    Exit Function
  End If
   
  '**********************************************************************
  'Link the now-open connection with the empty command object 
  '**********************************************************************
  Set objComm.ActiveConnection = objConn
   
  '**********************************************************************
  'Populate the command object in order to execute a query through the
  'linked connection. Set the text of the query command (i.e., the search),
  'the max number of results to return, the timeout in seconds to wait 
  'for the query, and whether the results are to be cached.
  '**********************************************************************
  objComm.CommandText = "<" & strLDAPBase & ">;" & strCriteria & ";" _
    & strAttributeList & ";" & strDepth
  objComm.Properties("Page Size") = 1000
  objComm.Properties("Timeout") = 60
  objComm.Properties("searchscope") = ADS_SCOPE_SUBTREE
  objComm.Properties("Cache Results") = False
   
  '**********************************************************************
  'Execute the command through the linked connection
  '**********************************************************************
  Err.Clear
  Set objRS = objComm.Execute
   
  '**********************************************************************
  'If there was an error, then return FALSE
  '**********************************************************************
  If Err Then
    objConn.Close
    Set objRS = Nothing
    SearchAD = False
  Else
    '**********************************************************************
    'If we're pointing at the end of the resultset already (EOF) then there 
    'were no records returned (although the query did search the AD), so
    'return FALSE
    '**********************************************************************
    If objRS.EOF Then
      objConn.Close
      Set objRS = Nothing
      SearchAD = False
    Else
      'Loop through the resultset and populate the disconnected recordset,
      'which we will then use to build the array
      While Not objRS.EOF
        objDisconRS.AddNew
        For intAttributeArrayIndex = 0 To arrAttributesUb
          attrib=arrAttributes(intAttributeArrayIndex)
          objDisconRS.Fields.Item(attrib) = objRS.Fields.Item(attrib)
        Next 
        objDisconRS.Update
        objRS.MoveNext
      Wend
   
      '**********************************************************************
      'Close the connection
      '**********************************************************************
      objConn.Close
      Set objRS = Nothing
      
      '**********************************************************************
      'Now in order to place all the resulting attributes into the array that 
      'we'll pass back out, we need to redimension the array so that it is
      'large enough to hold the records. The array is multidimensional in
      'order to hold all the attribute fields.
      '**********************************************************************
      
      ReDim arrResults((objDisconRS.RecordCount - 1),arrAttributesUb)
      
      '**********************************************************************
      'Loop through the newly redimensioned array, starting at zero, and add
      'each field to the array
      '**********************************************************************
      intArrayIndex = 0
      objDisconRS.MoveFirst
      While Not objDisconRS.EOF
        For intAttributeArrayIndex=0 To arrAttributesUb
          attrib=arrAttributes(intAttributeArrayIndex)
          arrResults(intArrayIndex,intAttributeArrayIndex) = _
                                       objDisconRS.Fields.Item(attrib)
        Next
        intArrayIndex = intArrayIndex + 1
        objDisconRS.MoveNext
      Wend
      Set objDisconRS = Nothing
      SearchAD = True
    End If   
  End If
End Function