VBA - Excel - Computername und Bezeichnung(description) aus Active Directory auslesen. Win2003 Domäne

Sub AD_auslesen()
'Auslsesen der Computernamen der AD  
  
  Dim strA() As String
  Dim i As Long
  Dim i2 As Long 'Zähler Blatt ADtest  
     
  strA = AllComputers
  i2 = 1
    
  If Not strA(0) = "" Then  
    For i = 0 To UBound(strA)
        For i3 = 4 To Sheets("Ausnahmen").UsedRange.Rows.Count  
            Sheets("Ausnahmen").Select  
            If strA(i) = Cells(i3, 1) Then GoTo 10
        Next i3
        
        Sheets("ADtest").Select  
        Cells(i2, 1) = strA(i)
        i2 = i2 + 1
10:
    Next
  End If
End Sub

==========================================================

Public Function AllComputers() As String()
  Dim conn As New Connection
  Dim rs As Recordset
 
  Dim Root As IADs
  Dim Domain As IADs
 
  Dim strBase As String
  Dim strFilter As String
  Dim strDomain As String
 
  Dim strAttr As String
  Dim strDepth As String
  Dim strQuery As String
  Dim strPC() As String
  Dim nElement As Integer
 
  On Error GoTo ErrHandler
 
  ReDim strPC(0) As String
 
  ' Pfad der gegenwärtigen Domäne (LDAP) einholen  
  Set Root = GetObject("LDAP://rootDSE")  
  strDomain = Root.Get("defaultNamingContext")  
  Set Domain = GetObject("LDAP://" & strDomain)  
 
  ' LDAP Base DN setzen  
  strBase = "<" & Domain.ADsPath & ">"  
 
  ' Filter auf die Kategorie Computer setzen  
  strFilter = "(&(objectCategory=Computer))"  
 
  ' Attribut setzen  
  strAttr = "name"  
 
  ' Suchtiefe setzen  
  strDepth = "subTree"  
 
  ' Abfrage zusammen setzen  
  strQuery = strBase & ";" & strFilter & ";" & strAttr & ";" & strDepth  
 
  ' Verbindung öffnen  
  conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"  
 
  ' Query ausführen  
  Set rs = conn.Execute(strQuery)
 
  Do While Not rs.EOF
    If strPC(0) = "" Then  
      nElement = 0
    Else
      nElement = nElement + 1
    End If
 
    ' das Array Redimensionieren  
    ReDim Preserve strPC(nElement) As String
 
    ' Den Computernamen in das Array schreiben  
    strPC(nElement) = rs("name")  
    rs.MoveNext
  Loop
 
  ' Das StringArray zurückgeben  
  AllComputers = strPC
 
  If rs.State <> 0 Then rs.Close
  If conn.State <> 0 Then conn.Close
 
' Error Handling  
ErrHandler:
  On Error Resume Next
  AllComputers = strPC
  Set rs = Nothing
  Set conn = Nothing
  Set Root = Nothing
  Set Domain = Nothing
End Function

==========================================================

Sub BezeichnungADauslsesen()
Dim strCN As String 'Computername  

On Error Resume Next

Dim WshShell, Hostname

For i = 1 To Sheets("ADtest").UsedRange.Rows.Count  
    Sheets("ADtest").Select  
    strCN = Cells(i, 1)
    
    Const ADS_SCOPE_SUBTREE = 2
    Set objConnection = CreateObject("ADODB.Connection")  
    Set objCommand = CreateObject("ADODB.Command")  
    objConnection.Provider = "ADsDSOObject"  
    objConnection.Open "Active Directory Provider"  
    Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 1000  
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE  
    objCommand.CommandText = _
       "SELECT ADsPath FROM 'LDAP://DC=satrup,DC=zmg,DC=local' WHERE objectCategory='computer' AND Name='" & strCN & "'"  
    Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst
    strADsPath = objRecordSet.Fields("ADsPath").Value  
    
    Set objComputer = GetObject(strADsPath)
    
    objproperty = objComputer.Get("Description")  
    
    Cells(i, 2) = objproperty
        
Next i

End Sub