以下の2つのアプローチ
最初のコードは、ユーザー指定のドメインに対してExcelでGALの詳細のほとんどをダンプします-バリアント配列を使用するため、非常に高速にダンプされます
ドメインを追加するには、この行（私がサニタイズした）を変更する必要があります
Domains = Array("'LDAP://a.b.example.org/dc=a,dc=b,dc=example,dc=org'", "'LDAP://b.c.example.org//dc=b,dc=c,dc=example,dc=org'", "'LDAP://d.e.example.org//dc=d,dc=e,dc=example,dc=org'")
コード
Sub DumpGAl()
Dim ws As Worksheet
Dim X
Dim Domains
Dim Fields
Dim VarDomains
Dim VarFields
Dim objRecordSet
Dim i As Long
Dim lngCnt As Long
Dim lngCnt2 As Long
Set ws = ThisWorkbook.Sheets(1)
ws.UsedRange.ClearContents
Domains = Array("'LDAP://a.b.example.org/dc=a,dc=b,dc=example,dc=org'", "'LDAP://b.c.example.org//dc=b,dc=c,dc=example,dc=org'", "'LDAP://d.e.example.org//dc=d,dc=e,dc=example,dc=org'")`
Fields = Array("Last", "First", "Initials", "Company", "physicalDeliveryOfficeName", "Address", "City", "State", "Zip code", "Country", "Phone", "Title", "Department", "Distinguished Name", "Manager", "Email Address", "Mobile Phone", "Cost Centre", "Department", "sAMAccountName", "userPrincipalName", "msExchAssistantName")
lngCnt = 1
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
'For Each VarDomains In Domains
' objCommand.CommandText = "Select department, l, title, telephonenumber, givenName, sn, initials, department, displayname, name, mobile, sAMAccountName," _
' & "physicalDeliveryOfficeName, streetAddress, st, postalCode, c, company, distinguishedName, manager, mail, example, userPrincipalName, msExchAssistantName " _
' & "FROM " & VarDomains _
' & "WHERE objectCategory='user'"
' Set objRecordSet = objCommand.Execute
' lngCnt = lngCnt + objRecordSet.RecordCount
'Next
ReDim X(1 To 200001, 1 To 22)
For Each VarFields In Fields
lngCnt2 = lngCnt2 + 1
X(1, lngCnt2) = VarFields
Next
i = 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
For Each VarDomains In Domains
objcommand.CommandText = "Select department, l, title, telephonenumber, givenName, sn, initials, department, displayname, name, mobile, sAMAccountName," _
& "physicalDeliveryOfficeName, streetAddress, st, postalCode, c, company, distinguishedName, manager, mail, example, userPrincipalName, msExchAssistantName " _
& "FROM " & VarDomains _
& "WHERE objectCategory='user'"
Set objRecordSet = objcommand.Execute
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
If Not IsNull(Len(objRecordSet.Fields("sn").Value)) Then X(i, 1) = Trim(Replace(Replace(objRecordSet.Fields("sn").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("givenName").Value)) Then X(i, 2) = Trim(Replace(Replace(objRecordSet.Fields("givenName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("initials").Value)) Then X(i, 3) = Trim(Replace(Replace(objRecordSet.Fields("initials").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("company").Value)) Then X(i, 4) = Trim(Replace(Replace(objRecordSet.Fields("company").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("physicalDeliveryOfficeName").Value)) Then X(i, 5) = Trim(Replace(Replace(objRecordSet.Fields("physicalDeliveryOfficeName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("streetAddress").Value)) Then X(i, 6) = Trim(Replace(Replace(objRecordSet.Fields("streetAddress").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("l").Value)) Then X(i, 7) = Trim(Replace(Replace(objRecordSet.Fields("l").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("st").Value)) Then X(i, 8) = Trim(Replace(Replace(objRecordSet.Fields("st").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("postalCode").Value)) Then X(i, 9) = Trim(Replace(Replace(objRecordSet.Fields("postalCode").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("c").Value)) Then X(i, 10) = Trim(Replace(Replace(objRecordSet.Fields("c").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("telephoneNumber").Value)) Then X(i, 11) = Trim(Replace(Replace(objRecordSet.Fields("telephoneNumber").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("title").Value)) Then X(i, 12) = Trim(Replace(Replace(objRecordSet.Fields("title").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("department").Value)) Then X(i, 13) = Trim(Replace(Replace(objRecordSet.Fields("department").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("distinguishedName").Value)) Then X(i, 14) = Trim(Replace(Replace(objRecordSet.Fields("distinguishedName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("manager").Value)) Then X(i, 15) = Trim(Replace(Replace(objRecordSet.Fields("manager").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("mail").Value)) Then X(i, 16) = Trim(Replace(Replace(objRecordSet.Fields("mail").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("mobile").Value)) Then X(i, 17) = Trim(Replace(Replace(objRecordSet.Fields("mobile").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("example").Value)) Then X(i, 18) = Trim(Replace(Replace(objRecordSet.Fields("role").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("department").Value)) Then X(i, 19) = Trim(Replace(Replace(objRecordSet.Fields("department").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("sAMAccountName").Value)) Then X(i, 20) = Trim(Replace(Replace(objRecordSet.Fields("sAMAccountName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("userPrincipalName").Value)) Then X(i, 21) = Trim(Replace(Replace(objRecordSet.Fields("userPrincipalName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
If Not IsNull(Len(objRecordSet.Fields("msExchAssistantName").Value)) Then X(i, 22) = Trim(Replace(Replace(objRecordSet.Fields("msExchAssistantName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
i = i + 1
If i Mod 100 = 0 Then
Application.StatusBar = "Processing record " & i
DoEvents
End If
objRecordSet.MoveNext
Loop
Next
ws.[A1:V200001] = X
Application.StatusBar = vbNullString
With ws.[a1:v1]
.Font.Bold = True
.Font.Size = 12
.Font.Name = "Arial"
End With
ws.UsedRange.AutoFilter
Rows("2:2").Select
ActiveWindow.FreezePanes = True
End Sub
Active Directory。以下のコードは、ワイルドカードの電子メールアドレスに対して検索している私の電話番号を返します。David.Y.XXX*
以下のコードをExcelから実行しました
以下のキーコードスニペット、Get_LDAP_User_Properties関数はRobSampsonの好意により提供されています。
サブを呼び出す
Sub Main()
MsgBox Get_LDAP_User_Properties("user", "mail", "David.Y.XXX*", "telephoneNumber")
End Sub
主な機能
Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
' This is a custom function that connects to the Active Directory, and returns the specific
' Active Directory attribute value, of a specific Object.
' strObjectType: usually "User" or "Computer"
' strSearchField: the field by which to seach the AD by. This acts like an SQL Query's WHERE clause.
' It filters the results by the value of strObjectToGet
' strObjectToGet: the value by which the results are filtered by, according the strSearchField.
' For example, if you are searching based on the user account name, strSearchField
' would be "samAccountName", and strObjectToGet would be that speicific account name,
' such as "jsmith". This equates to "WHERE 'samAccountName' = 'jsmith'"
' strCommaDelimProps: the field from the object to actually return. For example, if you wanted
' the home folder path, as defined by the AD, for a specific user, this would be
' "homeDirectory". If you want to return the ADsPath so that you can bind to that
' user and get your own parameters from them, then use "ADsPath" as a return string,
' then bind to the user: Set objUser = GetObject("LDAP://" & strReturnADsPath)
' Now we're checking if the user account passed may have a domain already specified,
' in which case we connect to that domain in AD, instead of the default one.
If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
' Otherwise we just connect to the default domain
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
End If
strBase = "<LDAP://" & strDNSDomain & ">"
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set ADOConnection = CreateObject("ADODB.Connection")
ADOConnection.Provider = "ADsDSOObject"
ADOConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = ADOConnection
' Filter on user objects.
'strFilter = "(&(objectCategory=person)(objectClass=user))"
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"
' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
' Define the maximum records to return
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
' Run the query.
Set adoRecordset = adoCommand.Execute
' Enumerate the resulting recordset.
strReturnVal = ""
Do Until adoRecordset.EOF
' Retrieve values and display.
For intCount = LBound(arrProperties) To UBound(arrProperties)
If strReturnVal = "" Then
strReturnVal = adoRecordset.Fields(intCount).Value
Else
strReturnVal = strReturnVal & vbCrLf & adoRecordset.Fields(intCount).Value
End If
Next
' Move to the next record in the recordset.
adoRecordset.MoveNext
Loop
' Clean up.
adoRecordset.Close
ADOConnection.Close
Get_LDAP_User_Properties = strReturnVal
End Function