Hello. I have a macro which is supposed to search active directory using LDAP to return the primary email address for everyone in my company. The code I have mostly works except for one error I can't seem to get around.
I keep getting the error: "The directory property cannot be found in the cache."
I have an on error statement which is supposed to ignore this error and move to the next record, however it only seems to work once. Any further errors cause the code to quit. (I need it to keep going, ignoring errors)
Can anyone give me some pointers, tips or advice on how to solve this issue as I'm all out of options. :(
I'll attach the macro code below, but as it's company specific I have to change certain AD fields and values.
[vba]Private Function QueryAD(Dump$, Subject$, Message$)
Dim rs As Object
Dim uName As String
Dim OldName As String
Dim extensions() As Variant
Dim i As Integer
Dim FQDN As String
'Instantiate The ADODB Connection.
Set Con = CreateObject("ADODB.Connection")
Set Cmd = CreateObject("ADODB.Command")
Con.Provider = "ADSDSOObject"
Con.Open "Active Directory Provider"
Set Cmd.ActiveConnection = Con
Cmd.Properties("Page Size") = 2000: ' Change this number to alter the number of records returned
' in one go. Smaller numbers access AD for shorter periods,
' but more times, and bigger numbers access it for longer
' periods, but less times. 1000 is the default.
' Create Our LDAP Query
FQDN = "LDAP://MyServer/OU=Users,OU=Accounts,DC=domain,DC=co,DC=uk"
' Create the SQL statement to return the correct fields
Cmd.CommandText = "SELECT sAMAccountName, Mail, PrimaryObject, extensionAttribute15 " & _
"FROM '" & FQDN & "'" & _
"WHERE objectClass='user' AND objectCategory='Person'"
'Open LDAP recordset
Set rs = Cmd.Execute
DumpFile = 1
VerboseDump = 0
'Create a text file with which to dump all email addresses into to avoid accessing AD again.
Open Dump$ For Output As #1
Path$ = Replace(LCase(GetSpecialfolder(&H0)), "desktop", "SubFolder\MacroTest\")
Path$ = Replace(LCase$(Path$), "c:\documents and settings", "\\MyFilestore")
Open Path$ + "Log.Txt" For Output As #2
'Tracking variables to count number of records found, and time taken to complete.
Count = 0: StartTime = Timer
'Iterate through recordset
While Not rs.EOF
On Error GoTo ADError:
If DumpFile And VerboseDump Then Print #2, ""
If DumpFile And VerboseDump Then Print #2, "New AD Check."
If DumpFile And VerboseDump Then Print #2, ""
'If the current account is NOT null
If Not IsNull(rs.fields("extensionAttribute15")) Then
If DumpFile And VerboseDump Then Print #2, "A15 is not null"
'If the current account is NOT a role account...
If LCase$(rs.fields("extensionAttribute15")) <> "role" Then
If DumpFile And VerboseDump Then Print #2, "A15 is not a role"
'If PrimaryObject is NOT null
If Not IsNull(rs.fields("PrimaryObject")) Then
If DumpFile And VerboseDump Then Print #2, "PriObj is not null"
'If PrimaryObject does not link to a deleted object
PriObj$ = rs.fields("PrimaryObject")
If InStr(PriObj$, "CN=Deleted Objects") = 0 And InStr(PriObj$, "CN=RG_") = 0 Then
If DumpFile And VerboseDump Then Print #2, "PriObj is not a deleted or role group account"
'Do another query on the PriObj object
Set objA14 = GetObject("LDAP://MyServer/" & PriObj$)
If DumpFile And VerboseDump Then Print #2, "Reading from: " + "LDAP://MyServer/" & PriObj$
'If extensionAttribute14 is NOT null
If Not IsNull(objA14.Get("extensionAttribute14")) Then
If DumpFile And VerboseDump Then Print #2, "A14 contains: " + objA14.Get("extensionAttribute14")
'Look at extensionAttribute14, if it's primary...
If LCase$(objA14.Get("extensionAttribute14")) = "primary" Then
If DumpFile And VerboseDump Then Print #2, "A14 is primary"
'Set uName to the users primary role address
If Not IsNull(objA14.Get("cn")) Then uName = objA14.Get("cn"): If DumpFile And VerboseDump Then Print #2, "uName = 'cn'"
'If extensionAttribute14 is not primary...
Else
If DumpFile And VerboseDump Then Print #2, "A14 is not primary"
'Use the address from the users Mail property
uName = rs.fields("Mail")
If DumpFile And VerboseDump Then Print #2, "uName = 'Mail'"
End If
Else
If DumpFile And VerboseDump Then Print #2, "A14 is null"
'Use the address from the users Mail property
uName = rs.fields("Mail")
If DumpFile And VerboseDump Then Print #2, "uName = 'Mail'"
End If
Set objA14 = Nothing
End If
'If PrimaryObject IS null
Else
If DumpFile And VerboseDump Then Print #2, "PriObj is null"
'Use the address from the users Mail property
uName = rs.fields("Mail")
If DumpFile And VerboseDump Then Print #2, "uName = 'Mail'"
End If
Else
If DumpFile And VerboseDump Then Print #2, "A15 is a role"
'Do Nothing
End If
'If the current account IS a role account...
Else
If DumpFile And VerboseDump Then Print #2, "A15 is null"
'Do Nothing
End If
'Check the last address against the new address, if it's not the same....
If uName <> OldName Then
'Output the email address to the dump file
Print #1, uName
If DumpFile And VerboseDump Then Print #2, "Adding Address: " + uName
'Increment the count of found records.
Count = Count + 1
'Add the address to the recipient list...
Recipient$ = Recipient$ + uName + ","
'Record this email address for checking against next loop.
OldName = uName
End If
'If We Have Read 1000 Addresses, Then Send The Email
If Count Mod 1000 = 0 Or rs.EOF Then Recipient$ = ""
SkipAD:
'Find the next record
rs.movenext
Wend
'Find out how long the AD search took. (In seconds)
Duration = Timer - StartTime
'Display the number of records found and the duration to signal completion.
If Duration < 60 Then Final$ = Str$(Count) + " Records Found. Process Completed In " + Trim$(Str$(Duration)) + " Seconds."
If Duration >= 60 And Duration < 3600 Then Final$ = Str$(Count) + " records Found. Process Completed In " + Trim$(Str$(Duration / 60)) + " Minutes."
If Duration >= 3600 Then Final$ = Str$(Count) + " records Found. Process Completed In " + Trim$(Str$((Duration / 60) / 60)) + " Hours."
If DumpFile = 1 Then Print #2, Final$
'Close connection and tidy up
Close #1
Close #2
rs.Close
Set rs = Nothing
MsgBox Final$
End
ADError:
Duration = Timer - StartTime
If DumpFile = 1 Then
Print #2, ""
Print #2, "************************************************************"
Print #2, "Error! " + Err.Description
Print #2, "Time until failure: " + Trim$(Str$(Duration / 60)) + " minutes."
Print #2, "There were " + Trim$(Str$(Count)) + " records found."
Print #2, ""
End If
Err.Clear
Set objA14 = Nothing
GoTo SkipAD:
End Function[/vba]
