Using ADSI and LDAP to retrieve user attributes from active direct

[nYssa]

Hello,

I have a custom outlook form for annual leave and I am trying to auto
populate the department field for the current outlook user based on the
department field stored in active directory. I am using outlook 2003 and not
having much luck.

I have tried the following code in the Item_Open function of my form and am
getting no records in my recordset.

GALQueryFilter = "(& (mailnickname=*) (|
(&(objectCategory=person)(objectClass=user)(!(homeMDB=*))(!(msExchHomeServerName=*)))(&(objectCategory=person)(objectClass=user)(|(homeMDB=*)(msExchHomeServerName=*)))(&(objectCategory=person)(objectClass=contact))(objectCategory=group)(objectCategory=publicFolder) ))"
strQuery = "<LDAP://" & DomainName & "/" & strDefaultNamingContext & ">;" &
GALQueryFilter & ";GivenName,sn,department;subtree"

Set oConn = CreateObject("ADODB.Connection")
Set oComm = CreateObject("ADODB.Command")
Set rs = CreateObject("ADODB.Recordset")
oConn.Provider = "ADsDSOOBJECT" ' ADSI OLE-DB provider
oConn.Open "ADs Provider"
oComm.ActiveConnection = oConn
oComm.Properties("Page Size") = 1000
oComm.CommandText = strQuery
'HAVE TRIED THIS WITH NO DIFFERENCE EITHER
'oComm.CommandText = "select GivenName,sn,department from 'LDAP://perss2'"

rs = oComm.Execute
item.userproperties("bDivisionName") = rs.Fields("department")

oConn.Close
set oConn = nothing
set oComm = nothing
set rs = nothing

HAVE ALSO TRIED THIS CODE with the same result, no records:

' Determine the DNS domain from the RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")

' Create and open an ADO connection to AD
Set objConnectionAD = CreateObject("ADODB.Connection")
Set objCommandAD = CreateObject("ADODB.Command")
Set objRecordSetAD = CreateObject("ADODB.Recordset")

objConnectionAD.Provider = "ADsDSOObject"
objConnectionAD.Open "Active Directory Provider"

' Set connection properties
With objCommandAD
.ActiveConnection = objConnectionAD
.CommandText = _
"Select userAccountControl, distinguishedName," & _
" sAMAccountname, department, displayName" & _
" FROM 'LDAP://" & strDNSDomain & "'" & _
" WHERE objectCategory = 'person' AND" & _
" objectClass = 'user' "
.Properties("Page Size") = 1000
.Properties("Timeout") = 30
.Properties("Searchscope") = ADS_SCOPE_SUBTREE
.Properties("Cache Results") = False
End With

Set objRecordSetAD = objCommandAD.Execute

' Move to the first record in the recordset
objRecordSetAD.MoveFirst
while not objRecordSetAD.EOF
mystring = mystring & " " & objRecordSetAD.Fields("department").Value
item.userproperties("bDivisionName") =
objRecordSetAD.Fields("department").Value
objRecordSetAD.MoveNext
wend

item.userproperties("bDivisionName") = mystring

'END CODE

Can someone please help. Thanks, nYssa

 

[nYssa]

Hello,

I solved my problem so I thought I would post the solution here.

'populate the Employee Name and Department field by looking it up in the
Exchange GAL
'For the current user

Const CdoPR_DISPLAY_NAME = &H3001001E ' DisplayName
Const CdoPR_DEPARTMENT_NAME = &H3A18001E ' Department Name

' Create session
Set objSession = Application.CreateObject("MAPI.Session")
strRetCode = objSession.Logon(Application.GetNameSpace("MAPI").CurrentUser,
"", False, False, 0)

' Get strUserName
strUserName = objSession.CurrentUser.UserName

On Error Resume Next

' We need to create a new message, Add recipient, and Set selected
recipient as new one
' Resolve recipient against the Exchange Directory
' Could have used the below to open up the GAL to select a mailbox
' --- Set objRecipients = objSession.AddressBook(,"Choose name:",True,,0)
' --- objNewRecip.Name = objRecipients.Item(1).Name

Set objNewMessage = objSession.Outbox.Messages.Add
Set objNewRecip = objNewMessage.Recipients.Add
objNewRecip.Name = item.session.currentuser.name
objNewRecip.Resolve

' Get AddressEntry of the current recipient
Set objNewUser = objNewRecip.AddressEntry

' Get fields collection of the selected recipient object
Set objNewFields = objNewUser.Fields
Set objDisplayName = objNewFields.Item(CdoPR_DISPLAY_NAME)
Set objDepartment = objNewFields.Item(CdoPR_DEPARTMENT_NAME)

item.userproperties("aEmployee") = objDisplayName
item.userproperties("bDivisionName") = objDepartment

Hope it helps someone else later!

nYssa