1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
| Option Compare Database
Option Explicit
Public Type typUser
Nom As String
Prenom As String
End Type
Sub Test()
Dim iTyp As typUser
iTyp = UserInfo("toto")
Debug.Print iTyp.Nom & " - " & iTyp.Prenom
End Sub
Public Function UserInfo(pStr_Login As String) As typUser
'PURPOSE: Display information that is available in
'the Active Directory about a given user
'PARAMETER: Login Name for user
'RETURNS: String with selected information about
'user, or empty string if there is no such
'login on the current domain
'REQUIRES: Windows 2000 ADSI, LDAP Provider
'Proper Security Credentials.
'EXAMPLE: msgbox UserInfo("Administrator")
Dim conn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim oRoot As Object
Dim oDomain As Object
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 user As Object 'IADsUser
Dim iTyp_User As typUser
On Error GoTo ErrHandler:
iTyp_User.Prenom = ""
iTyp_User.Nom = ""
Set oRoot = GetObject("LDAP://rootDSE")
'work in the default domain
sDomain = oRoot.Get("defaultNamingContext")
Set oDomain = GetObject("LDAP://" & sDomain)
sBase = "<" & oDomain.ADsPath & ">"
'Only get user name requested
sFilter = "(&(objectCategory=person)(objectClass=user)(name=" & pStr_Login & "))"
sAttribs = "adsPath"
sDepth = "subTree"
sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth
conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
Set rs = conn.Execute(sQuery)
If Not rs.EOF Then
Set user = GetObject(rs("adsPath"))
With user
'if the attribute is not stored in AD,
'an error will occur. Therefore, this
'will return data only from populated attributes
On Error Resume Next
iTyp_User.Prenom = .FirstName
iTyp_User.Nom = .LastName
sAns = sAns & "Employee ID: " & .EmployeeID & vbCrLf
sAns = sAns & "Title: " & .Title & vbCrLf
sAns = sAns & "Division: " & .Division & vbCrLf
sAns = sAns & "Department: " & .Department & vbCrLf
sAns = sAns & "Manager: " & .Manager & vbCrLf
sAns = sAns & "Phone Number: " & .TelephoneNumber & vbCrLf
sAns = sAns & "Fax Number: " & .FaxNumber & vbCrLf
sAns = sAns & "Email Address: " & .EmailAddress & vbCrLf
sAns = sAns & "Web Page: " & .HomePage & vbCrLf
sAns = sAns & "Last Login: " & .LastLogin & vbCrLf
sAns = sAns & "Last Logoff: " & .LastLogoff & vbCrLf
sAns = sAns & "Account Expiration Date: " _
& .AccountExpirationDate & vbCrLf
'IN RC2, this returned 1/1/1970 when password
'never expires option is set
sAns = sAns & "Password Expiration Date: " _
& .PasswordExpirationDate
'Debug.Print sAns
End With
Else
Debug.Print "No data"
End If
UserInfo = iTyp_User
ErrHandler:
On Error Resume Next
If Not rs Is Nothing Then
If rs.State <> 0 Then rs.Close
Set rs = Nothing
End If
If Not conn Is Nothing Then
If conn.State <> 0 Then conn.Close
Set conn = Nothing
End If
Set oRoot = Nothing
Set oDomain = Nothing
End Function |
Partager