Active Directory et ASP

V'là ce qui traine chez Microsoft pour 'Example Code for Searching for Users' ...

URL = http://msdn.microsoft.com/library/default.asp?url=/library/en-us/netdir/ad/example_code_for_searching_for_users.asp

---------------------------------------------------------------------------

Dim Con As ADODB.Connection
Dim ocommand As ADODB.Command
Dim gc As IADs

On Error Resume Next
'Maximum number of items to list on a msgbox.
MAX_DISPLAY = 5

'Prompt for surname to search for.
strName = InputBox("This routine searches in the current domain for users with the specified surname." & vbCrLf & vbCrLf &"Specify the surname:")

If strName = "" Then
msgbox "No surname was specified. The routine will search for all users."
End If

'Create ADO connection object for Active Directory
Set Con = CreateObject("ADODB.Connection")
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on CreateObject"
End If
Con.Provider = "ADsDSOObject"
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on Provider"
End If
Con.Open "Active Directory Provider"
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on Open"
End If

'Create ADO command object for the connection.
Set ocommand = CreateObject("ADODB.Command")
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on CreateObject"
End If
ocommand.ActiveConnection = Con
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on Active Connection"
End If

'Get the ADsPath for the domain to search.
Set root = GetObject("LDAP://rootDSE")
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on GetObject for rootDSE"
End If
sDomain = root.Get("defaultNamingContext")
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on Get on defaultNamingContext"
End If
Set domain = GetObject("LDAP://" & sDomain)
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on GetObject for domain"
End If

'Build the ADsPath element of the commandtext
sADsPath = "<" & domain.ADsPath & ">"

'Build the filter element of the commandtext
If (strName = "") Then
sFilter = "(&(objectCategory=person)(objectClass=user))"
Else
sFilter = "(&(objectCategory=person)(objectClass=user)(sn=" & strName & "))"
End If

'Build the returned attributes element of the commandtext.
sAttribsToReturn = "name,distinguishedName"

'Build the depth element of the commandtext.
sDepth = "subTree"

'Assemble the commandtext.
ocommand.CommandText = sADsPath & ";" & sFilter & ";" & sAttribsToReturn & ";" & sDepth
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on CommandText"
End If
'Display
show_items "CommandText: " & ocommand.CommandText, ""

'Execute the query.
Set rs = ocommand.Execute
If (Err.Number <> 0) Then
BailOnFailure Err.Number, "on Execute"
End If

strText = "Found " & rs.RecordCount & " Users in the domain:"
intNumDisplay = 0
intCount = 0

' Navigate the record set
rs.MoveFirst
While Not rs.EOF
intCount = intCount + 1
strText = strText & vbCrLf & intCount & ") "
For i = 0 To rs.Fields.Count - 1
If rs.Fields(i).Type = adVariant And Not (IsNull(rs.Fields(i).Value)) Then
strText = strText & rs.Fields(i).Name & " = "
For j = LBound(rs.Fields(i).Value) To UBound(rs.Fields(i).Value)
strText = strText & rs.Fields(i).Value(j) & " "
Next
Else
strText = strText & rs.Fields(i).Name & " = " & rs.Fields(i).Value & vbCrLf
End If
Next
intNumDisplay = intNumDisplay + 1
'Display in msgbox if there are MAX_DISPLAY items to display
If intNumDisplay = MAX_DISPLAY Then
Call show_items(strText, "Users in domain")
strText = ""
intNumDisplay = 0
End If
rs.MoveNext
Wend

show_items strText, "Users in domain"
'''''''''''''''''''''''''''''''''''''''
'Display subroutines
'''''''''''''''''''''''''''''''''''''''
Sub show_items(strText, strName)
MsgBox strText, vbInformation, "Search domain for users with Surname " & strName
End Sub

Sub BailOnFailure(ErrNum, ErrText) strText = "Error 0x" & Hex(ErrNum) & " " & ErrText
MsgBox strText, vbInformation, "ADSI Error"
WScript.Quit
End Sub

Envoyé par Alexandre GROLLEAU
Alias kami58