Error reading from AD

[mobiius]

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.

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

[mobiius]

Will someone help me if I narrow the problem down to this line...

'If extensionAttribute14 is NOT null
If Not IsNull(objA14.Get("extensionAttribute14")) Then
If DumpFile And VerboseDump Then Print #2, "A14 contains: " + objA14.Get("extensionAttribute14")

[mobiius]

No one?
No one at all has any idea on how to check if a record exists or not?
No tips on avoiding this error?

[mobiius]

Well I'd like to thank everyone for there helpful comments. I couldn't have solved this issue without your help, oh wait... I did solve it without your help. :(

Since I'm a helpful guy, I'll provide my extremely simple fix.

In my error checking code, I needed to change the line..
Goto SkipAD:

To be...
Resume SkipAD:

Using GOTO to escape from an error checking routine will not reset it so will result in unpredictable results. Using resume will return cleanly and reset the error handler correctly.

I guess if anyone actually read the code they would have realised this.

[Aussiebear]

Your comments are noted. As I'm also an extremely helpful guy, I'll pass on my relatively simple solution.

The members who operate in these forums, do so on a voluntary basis, assisting where possible, when possible. Given that they also have lives to run, their time here and the effort they put in is their own.

In Post #2 you suggested

Will someone help me if I narrow the problem down to this line...



VBA:

'If extensionAttribute14 is NOT null
If Not IsNull(objA14.Get("extensionAttribute14")) Then
If DumpFile And VerboseDump Then Print #2, "A14 contains: " + objA14.Get("extensionAttribute14")

Maybe, we didn't see a problem with this section of code, but you seemed awful sure that this was where the issue lay.

I'm guessing that by now you have lost some of the frustration that was present when you posted the comments in post #4. Comments like these, will be remembered by others and may prove to add some resistance to offerring you assistance in the future on some other issue.

An apology would be helpful,and since you're an extremely helpful guy, this wouldn't be a problem, right?

[mobiius]

I'm guessing that by now you have lost some of the frustration that was present when you posted the comments in post #4
Indeed I have.


An apology would be helpful,and since you're an extremely helpful guy, this wouldn't be a problem, right?
Fair point, I apologise.

[Aussiebear]

Thanks for that. Deep down I knew you were a top bloke.