Trying to loop through RDOFolders Recursively

  • Thread starter Thread starter Bill Benson
  • Start date Start date
B

Bill Benson

The code below is designed for the purpose of recursively going through all
folders in my default pst store, and all subfolders of them, so long as the
defaultmessageclass is "IPM.NOTE". The problem I have is that when the
procedure calls itself, even though I am passing an object, it is being
recast as a string the first time it is actually passed.

So, on the first iteration, all's "well" because BeginHere is missing. But
then the procedure calls itself, tries to pass rfolder [which is of type
RDOFOlder2]; and if one were thereafter to type "?TypeName(BeginHere) in the
immediate pane, the result would say "String". Hey, that's no fair!! Can
someone who has Redemption test this, and save the day??

[The test for Err.Number <>0 was added as a debugging device, since in a
perfect world there would not be any error thrown by the line:
For Each objMsg In BeginHere.Items
]

Thanks anyone!!

Option Explicit
Dim g_ObjSession

Sub Get_smtpAddresses(Optional ByRef BeginHere)
Dim rfolder ' As RDOFolder2???? Does not seem to work
Dim MyStore As RDOPstStore
Dim objMsg As Object, ObjSender As Object
Dim g_GroupOfFolders

On Error Resume Next

If IsMissing(BeginHere) Then
Set g_ObjSession = CreateObject("Redemption.RDOSession")
g_ObjSession.Logon
Set MyStore = g_ObjSession.Stores.DefaultStore
For Each rfolder In MyStore.IPMRootFolder.Folders
If rfolder.DefaultMessageClass = "IPM.Note" Then
Get_smtpAddresses (rfolder)
End If
Next
Else
Err.Clear
For Each objMsg In BeginHere.Items
If Err.Number = 0 Then 'Note, shouldn't have to!! BeginHere is the problem
Set ObjSender = objMsg.Sender
If Not ObjSender Is Nothing Then
If InStr(ObjSender.SMTPAddress, "@") > 0 Then
Debug.Print ObjSender.SMTPAddress
End If
End If
Else
Err.Clear 'Move on
End If
Next
'Done with Items, now loop through folders if any
If IsEmpty(BeginHere) Then
Exit Sub
End If
For Each rfolder In BeginHere.Folders
If IsEmpty(rfolder) Then 'Note, Shouldn't have to trap errors
Exit Sub
End If
If rfolder.DefaultMessageClass = "IPM.Note" Then
Get_smtpAddresses (rfolder)
End If
Next
End If
End Sub
 
Hi Dmitry, thanks but I tried that already and the problem is, if you check
my code, you will see I am trying to reuse this function so as to send
rfolder (which has typename = RDOFolder2) back to the function ... which is
why I wanted to dim BeginHere as a variant. I get type mismatched error when
dimming BeginHere as an object. And actually, I can't tell whether it because
BeginHEre is dimmed as an object and passing something of type= RDOFolder2 to
something already declared as an Object fails .. or whether passing something
of type RDOFolder2 causes VBA to go back to its foolish tricks of really
trying to sneak a string in there in place of the RDOFolder2.

I am surprised there is no way to get this to work, but I have run into this
kind of thing before, were things passed to a function lose their type
classing or whatnot when passed as arguments.

A declaration as a variant should really behave itself, it would seem to me.

I hate to give up on this.

Sub thug()
GetAddresses
End Sub

Sub GetAddresses(BeginHere As Object)
Dim rfolder As RDOFolder2 'Does not seem to work
Dim MyStore As RDOPstStore
Dim TotalItems As Long
Dim objMsg As Object, ObjSender As Object

If BeginHere Is Nothing Then
'Set global vars, logon to Session, get initial default pst Store
Set g_Col = New Collection
Set g_ObjSession = CreateObject("Redemption.RDOSession")
g_ObjSession.Logon
Set MyStore = g_ObjSession.Stores.DefaultStore
'looped through subfolders of the IPMRootFolder
For Each rfolder In MyStore.IPMRootFolder.Folders
If rfolder.DefaultMessageClass = "IPM.Note" Then

''''PROBLEM HERE''''
GetAddresses (rfolder)
''''PROBLEM HERE''''


End If
 
Back
Top