asked on

Move both or more duplicate folders to one folder and rename as needed.

Hi,

Move both or more duplicate folders to one folder and rename as needed.
When macro run has to check my 4 pst's and see for a duplicate folder. 2 or more can be available and move them to a predefined folder path.
Example
\\Latest Mails\Inbox\JtoO\Microsoft
\\Jan2009\Inbox\Vendors\Microsoft

In the above case move "Microsoft" to a path.

REgards
Sharath

Script code examples to build from here:
http://www.outlookcode.com
http://www.slovaktech.com/code_samples.htm

Chris Bottomley

To confirm:

If any two folders have the same name, (whatever the folder path) then the contents are all moved to a specific folder?

Assuming yes, is that specific folder one of the duplicates or some specific path you want to identify?

Chris

ASKER

I want to move all that may be duplicate to the Mailbox\inbox. So later i can verify them and move the mails mamually into one and delete the empty folders...

ASKER

I meant move the duplicate folders along with mails to "mailbox\inbox"

Chris Bottomley

So if for example the found duplicates are:

\\Latest Mails\Inbox\JtoO\Microsoft
\\Jan2009\Inbox\Vendors\Microsoft

How do you want them moved?

\\Personal Folders\Inbox\Microsoft-2
\\Personal Folders\Inbox\Microsoft-1

OR all contents into:

\\Personal Folders\Inbox\Microsoft

Chris

ASKER

I will need them as this

\\Mailbox - Sharath\Inbox\Microsoft-2
\\Mailbox - Sharath\Inbox\Microsoft-1

Chris Bottomley

OKay

I think I have a solution as follows:

Run sub collateDupeFolders and any duplicated foldernames with contents are collated under the specified inbox.

Chris

Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each Fldr In Application.GetNamespace("mapi").folders
        Call pf_findDefaults(Fldr, defaultFolders, allFolders)
        Set allFolders = excludeDefaults(defaultFolders, allFolders)
    Next
    
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
    For Each itm In masterList.Keys
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If dupes.Exists(str) Then
            dupes(str) = dupes(str) & "|" & masterList.Item(itm)
        Else
            dupes.Add Key:=str, Item:=masterList.Item(itm)
        End If
    Next
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderIndex = 0 To UBound(fldrs)
                strFolder = fldrs(folderIndex)
                Set src = olNav2Folder(CStr(strFolder), False)
                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
'                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

Thanks Chris just started the macro and i am sure its going to take a while for the results
Can you have a look at this
https://www.experts-exchange.com/questions/24264376/Delete-all-Identical-mails-in-a-folder-Compare-the-Subject-and-then-the-body-data-of-the-mail-and-delete-all-except-1.html

ASKER

Chris the script has been running for a while. Does it search for a duplicate folder in all the pst's?

Chris Bottomley

Yup, I made a few assumptions ..

1. Search all PST's
2. Ignore standard folders
3. I haven't excluded public folders - more by omission thatn intent though

Chris

ASKER

Thanks i think i need to leave it for a long time to scan and diagnose all the folders... Shall get back when its done....

Chris Bottomley

Modified to exclude public folder ... should that be a requirement!

Chris

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
    For Each itm In masterList.Keys
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If dupes.Exists(str) Then
            dupes(str) = dupes(str) & "|" & masterList.Item(itm)
        Else
            dupes.Add Key:=str, Item:=masterList.Item(itm)
        End If
    Next
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderIndex = 0 To UBound(fldrs)
                strFolder = fldrs(folderIndex)
                Set src = olNav2Folder(CStr(strFolder), False)
                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
'                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

I get run time error 9

When debug it goes here
For Each itm In masterList.Keys
I think the time was taken on the public folders. thats for the exclusion

ASKER

Is the name of the mailbox i am going wrong.

i right click on the Mailbox and go to properties and thats the name i am mentioning

Chris Bottomley

CAn you do me a favour and try with the modified post?

Chris

ASKER

Yes i got the above error on the last code. In the first code it was going on running and did not end...

Chris Bottomley

Still works fine on my tests. I have modified to append an output to the immediate window ... can you examine and provide any data therefrom at the time of failure?

Chris

Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
    For Each itm In masterList.Keys
        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If dupes.Exists(str) Then
            dupes(str) = dupes(str) & "|" & masterList.Item(itm)
        Else
            dupes.Add Key:=str, Item:=masterList.Item(itm)
        End If
    Next
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderIndex = 0 To UBound(fldrs)
                strFolder = fldrs(folderIndex)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

I get this in the immediate window and get the error

1 \\Mailbox - Sharath
2 \\Mailbox - Sharath\Deleted Items
3 \\Mailbox - Sharath\Inbox
4 \\Mailbox - Sharath\Inbox\Dupes
5 \\Mailbox - Sharath\Inbox\Sophos old
6 \\Mailbox - Sharath\Inbox\Sophos old\Backup Sophos
7 \\Mailbox - Sharath\Inbox\Sophos old\27th
8 \\Mailbox - Sharath\Outbox
9 \\Mailbox - Sharath\Sent Items
10 \\Mailbox - Sharath\Calendar
11 \\Mailbox - Sharath\Contacts
12 \\Mailbox - Sharath\Drafts
13 \\Mailbox - Sharath\Journal
14 \\Mailbox - Sharath\Junk E-mail
15 \\Mailbox - Sharath\Notes
16 \\Mailbox - Sharath\Notes\Linked Notes
17 \\Mailbox - Sharath\RSS Feeds
18 \\Mailbox - Sharath\RSS Feeds\hu.com
19 \\Mailbox - Sharath\RSS Feeds\sha(1)
20 \\Mailbox - Sharath\Sophos Mails
21 \\Mailbox - Sharath\Sync Issues1
22 \\Mailbox - Sharath\Sync Issues1\Conflicts
23 \\Mailbox - Sharath\Sync Issues1\Local Failures
24 \\Mailbox - Sharath\Sync Issues1\Server Failures
25 \\Mailbox - Sharath\Tasks

Chris Bottomley

Okay another hack to see how many folders are stored and their names ... to see what might come after tasks.

Chris

Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
    For itm = 1 To masterList.count
        Debug.Print itm & vbTab & masterList.Item(itm)
    Next
    For Each itm In masterList.Keys
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If dupes.Exists(str) Then
            dupes(str) = dupes(str) & "|" & masterList.Item(itm)
        Else
            dupes.Add Key:=str, Item:=masterList.Item(itm)
        End If
    Next
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderIndex = 0 To UBound(fldrs)
                strFolder = fldrs(folderIndex)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

Still just get the same identical 25 and the error

Chris Bottomley

Once again it is unfortunately a case of suck it and see where it fails ... it works fine for me, and so I must be missing something and need a clue as to what!

Does the error occur at the same point ... i.e. break point?

Chris

ASKER

Yes the same point... Can i have the destination selecatable. Just to make sure that i am not mentioning the wrong path ?

Chris Bottomley

So it's not the data that failing per se .. I think, i'll look into a different structure in the morning and then see how that works.

Chris

Chris Bottomley

Restructured the main loop to reflect the test loop, still the outputs on screen so any better ... and if so i'll tidy up re outputs afterwards

Chris

Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
Dim intItem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
    For itm = 1 To masterList.count
        Debug.Print itm & vbTab & masterList.Item(itm)
    Next
    Stop
    For intItem = 1 To masterList.count
        itm = intItem
        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If dupes.Exists(str) Then
            dupes(str) = dupes(str) & "|" & masterList.Item(itm)
        Else
            dupes.Add Key:=str, Item:=masterList.Item(itm)
        End If
    Next
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderIndex = 0 To UBound(fldrs)
                strFolder = fldrs(folderIndex)
                Set src = olNav2Folder(CStr(strFolder), False)
                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
'                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function
 
 
 
 
Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Outlook.mailitem
Dim strFilter As String
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    On Error GoTo skipthisone
    For mailCounter = myfolder.items.count To 1 Step -1
        Set mai = myfolder.items(mailCounter)
        strFilter = "[Subject] = " & append_quotes(mai.subject)
        Set olkmailitems = myfolder.items.Restrict(strFilter)
        For bodyCount = olkmailitems.count - 1 To 1 Step -1
            If mai.body = olkmailitems(bodyCount).body Then
                olkmailitems(bodyCount).Delete
            End If
        Next
skipthisone:
    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function

Open in new window

ASKER

When run it just comes out after the 25 collection to
Stop

ASKER

When run it just comes out after the 25 collection to
Stop

Chris Bottomley

Overlooked that line

Chris

Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
Dim intItem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
    For itm = 1 To masterList.count
        Debug.Print itm & vbTab & masterList.Item(itm)
    Next
    'Stop
    For intItem = 1 To masterList.count
        itm = intItem
        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If dupes.Exists(str) Then
            dupes(str) = dupes(str) & "|" & masterList.Item(itm)
        Else
            dupes.Add Key:=str, Item:=masterList.Item(itm)
        End If
    Next
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderIndex = 0 To UBound(fldrs)
                strFolder = fldrs(folderIndex)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function
 
 
 
 
Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Outlook.mailitem
Dim strFilter As String
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    On Error GoTo skipthisone
    For mailCounter = myfolder.items.count To 1 Step -1
        Set mai = myfolder.items(mailCounter)
        strFilter = "[Subject] = " & append_quotes(mai.subject)
        Set olkmailitems = myfolder.items.Restrict(strFilter)
        For bodyCount = olkmailitems.count - 1 To 1 Step -1
            If mai.body = olkmailitems(bodyCount).body Then
                olkmailitems(bodyCount).Delete
            End If
        Next
skipthisone:
    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function

Open in new window

ASKER

Chris still gets stuck in the same 25 and get the error 91

Chris Bottomley

You are going to need to do some invest ...

I assume there are multiple PST's but we only seem to be processing the first one. How many folders are there in the postbox ... i.e. does 25 look correct for all folders and subfolders?

The fact that the error is now 91 means something has changed for the better. Is it still breaking on the same line?

Chris

ASKER

Yes...

i think just the mailbox is being processed and not any pst's

ASKER

Chris what i did is create a duplicate folder in the mailbox and checked it does work.
I get the error on this line
For itm = 1 To masterList.Count
So one thing we can be sure is the code works but just works on the mailbox. And not the other 5 pst's

Chris Bottomley

Only running on the mailbox because of the error, the loop on storesitem is a proven construct on previous posts with you so once we resolve the failure we should be okay for all pst's.

When it breaks on:
For itm = 1 To masterList.Count

Can you identify the values for the data in the immediate window, (ctrl + G) ... one I assume will bring an error up.

?itm
?masterlist.count

Chris

ASKER

I get this error after 25
---------------------------
Microsoft Visual Basic
---------------------------
Run-time error '91':

Object variable or With block variable not set
---------------------------
OK Help
---------------------------

When i take mouse over itm
i get
itm=Empty

ASKER

I get this error after 25
---------------------------
Microsoft Visual Basic
---------------------------
Run-time error '91':

Object variable or With block variable not set
---------------------------
OK Help
---------------------------

When i take mouse over itm
i get
itm=Empty

Chris Bottomley

masterlist.count value?

Chris

ASKER

I get this

---------------------------
Microsoft Visual Basic
---------------------------
Run-time error '424':

Object required
---------------------------
OK Help
---------------------------
When i put
?masterlist.count
in the Immediate window

ASKER

I get this

---------------------------
Microsoft Visual Basic
---------------------------
Run-time error '424':

Object required
---------------------------
OK Help
---------------------------
When i put
?masterlist.count
in the Immediate window

Chris Bottomley

I have moved the move operation to a sub and bracketed it with a check for the null condition, a test showed that a null input to the delete block produces the reported error ... and now reading your post I think you knew it but I missed the connection.

Chris

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
    For itm = 1 To masterList.count
        Debug.Print itm & vbTab & masterList.Item(itm)
    Next
    'Stop
    For intItem = 1 To masterList.count
        itm = intItem
        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If dupes.Exists(str) Then
            dupes(str) = dupes(str) & "|" & masterList.Item(itm)
        Else
            dupes.Add Key:=str, Item:=masterList.Item(itm)
        End If
    Next
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
 
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

Right after 25 i get the error 91

ASKER

Right after 25 i get the error 91

Chris Bottomley

Not able to reproduce the exact issue but there was a bug so please try this

Chris

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intItem = 1 To masterList.count
        itm = intItem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
 
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

I get run time error 91
When debug goes here
src.MoveTo tgt
When i take mouse over tgt i get

tgt = "Inbox"

ASKER

I get run time error 91
When debug goes here
src.MoveTo tgt
When i take mouse over tgt i get

tgt = "Inbox"

Chris Bottomley

Can you see what src equates to? ... inbox is of course where the folder is to be moved to whereas src is the folder to be moved.

Chris

Chris Bottomley

Assuming it coresponds to something then in teh immediate window type ?src.folderpath and check for the existence of that folder.

Chris

ASKER

Src
tgt = "inbox"
When i put this

?src.folderpath

i get this

---------------------------
Microsoft Visual Basic
---------------------------
Run-time error '91':

Object variable or With block variable not set
---------------------------
OK Help
---------------------------

ASKER

Src
tgt = "inbox"
When i put this

?src.folderpath

i get this

---------------------------
Microsoft Visual Basic
---------------------------
Run-time error '91':

Object variable or With block variable not set
---------------------------
OK Help
---------------------------

Chris Bottomley

Added some debugging here ... can you supply the output ... something like:

Processing item 0,(\\Personal Folders\Inbox\fldr1) of 0 ... 1
Processing item 1,(\\Personal Folders\Inbox\fldr2) of 0 ... 1

Chris

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intItem = 1 To masterList.count
        itm = intItem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
 
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                Debug.Print "Processing item " & folderindex & ",(" & strFolder; ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

Got a lot of data above this which just went off

Same as below have the data from 2001 till this

Processing item 2283,() of 0 ... 2289
Processing item 2284,() of 0 ... 2289
Processing item 2285,() of 0 ... 2289
Processing item 2286,() of 0 ... 2289
Processing item 2287,() of 0 ... 2289
Processing item 2288,() of 0 ... 2289
Processing item 2289,() of 0 ... 2289

ASKER

Got a lot of data above this which just went off

Same as below have the data from 2001 till this

Processing item 2283,() of 0 ... 2289
Processing item 2284,() of 0 ... 2289
Processing item 2285,() of 0 ... 2289
Processing item 2286,() of 0 ... 2289
Processing item 2287,() of 0 ... 2289
Processing item 2288,() of 0 ... 2289
Processing item 2289,() of 0 ... 2289

Chris Bottomley

It's showing as a lot of folders that are null, I simply don't understand as on my stand alone it doesn't happen and I don't have access to a network pc with outlook 2007.

I will modify the output to a text file and then perhaps there will be more info.

Chris

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intItem = 1 To masterList.count
        itm = intItem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        outputFilePathandName = Environ("temp") & "\CRBDataTrace.txt"
        Set fso = CreateObject("scripting.filesystemobject")
        If fso.FileExists(outputFilePathandName) Then
            Set outputFile = fso.OpenTextFile(outputFilePathandName, 2, False)
        Else
            Set outputFile = fso.OpenTextFile(outputFilePathandName, 2, True)
        End If
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then outputFile.WriteLine "Processing item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

Chris Bottomley

Can you ensure you are happy to provide the file CRBDataTrace.txt in your temp folder, (in explorer type %temp% in the folderpath.

Chris

ASKER

Chris send the mail with the txt

ASKER

Chris send the mail with the txt

Chris Bottomley

Every last one of them is empty ... I need to think a bit, because it works for me :{

in the meantime you arer running on an office 2007 installation?

Chris

ASKER

yes office 2007 is what i use....

Chris Bottomley

Another quick hack to add some more data ... if you can upload it please?

Chris

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    End If
    folderList.Add folderList.count + 1, startFolder.folderpath
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intItem = 1 To masterList.count
        itm = intItem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        outputFilePathandName = Environ("temp") & "\CRBDataTrace.txt"
        Set fso = CreateObject("scripting.filesystemobject")
        If fso.FileExists(outputFilePathandName) Then
            Set outputFile = fso.OpenTextFile(outputFilePathandName, 2, False)
        Else
            Set outputFile = fso.OpenTextFile(outputFilePathandName, 2, True)
        End If
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then outputFile.WriteLine "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then outputFile.WriteLine "Processing item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

Hi Chris send a mail with the details..

I guess it pulled data from just 1 pst. the last one...

ASKER

Hi Chris send a mail with the details..

I guess it pulled data from just 1 pst. the last one...

Chris Bottomley

That's even stranger .. no folderpath data at all!

I have modified the below to print to the immendiate window the folderpaths ffom earlier in the sequence. Given what happened I need only have an idea of the last few lines hence didn't bother putting it to the logfile.

Note the error means the loop does not return to the initial loop on PSTs .. I hope, so that is why it appears as the mailbox only and is why I am ignoring those concerns for now.

Chris

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            For intitem = 1 To allFolders.count
                Debug.Print intitem & vbTab & allFolders(intitem)
            Next
'        Debug.Print itm & vbTab & masterList.Item(itm)
 
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        folderList.Add folderList.count + 1, startFolder.folderpath
    End If
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

I get runtime 424 When debug goes here

Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")

ASKER

I get runtime 424 When debug goes here

Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")

Chris Bottomley

Ah!

I have started to move to a library file these sort of capabilities ... and I started here after my last post.

For now append the following to the end of your code AND delete CRBDebug. including that 'dot' in the subroutine and retry

Chris

Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(outputFilePathandName) Then
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
    Else
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
    End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
    outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
    If IsArray(str) Then
        If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
        strline = Split(str, vbCrLf)
        For cnt = 0 To UBound(str)
            strline = str(cnt)
            outputFile.WriteLine strline
        Next
    Else
        outputFile.WriteLine str
    End If
 
End Sub

Open in new window

ASKER

I get object required error
When debug goes here
If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"

This is the full code i have now...

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            For intitem = 1 To allFolders.Count
                Debug.Print intitem & vbTab & allFolders(intitem)
            Next
'        Debug.Print itm & vbTab & masterList.Item(itm)
 
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        folderList.Add folderList.Count + 1, startFolder.folderPath
    End If
    For Each Fldr In startFolder.Folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        Err.Clear
        Fldr.Name = oldName & "ish"
        If Err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.Count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
                Set tgt = olNav2Folder("\\Mailbox - Sharath Reddy\Inbox", True)
'                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.Folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.Folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.Folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.Folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(outputFilePathandName) Then
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
    Else
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
    End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
    outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
    If IsArray(str) Then
        If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
        strline = Split(str, vbCrLf)
        For cnt = 0 To UBound(str)
            strline = str(cnt)
            outputFile.WriteLine strline
        Next
    Else
        outputFile.WriteLine str
    End If
 
End Sub

Open in new window

ASKER

I get object required error
When debug goes here
If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"

This is the full code i have now...

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            For intitem = 1 To allFolders.Count
                Debug.Print intitem & vbTab & allFolders(intitem)
            Next
'        Debug.Print itm & vbTab & masterList.Item(itm)
 
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        folderList.Add folderList.Count + 1, startFolder.folderPath
    End If
    For Each Fldr In startFolder.Folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        Err.Clear
        Fldr.Name = oldName & "ish"
        If Err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.Count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
                Set tgt = olNav2Folder("\\Mailbox - Sharath Reddy\Inbox", True)
'                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.Folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.Folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.Folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.Folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(outputFilePathandName) Then
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
    Else
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
    End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
    outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
    If IsArray(str) Then
        If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
        strline = Split(str, vbCrLf)
        For cnt = 0 To UBound(str)
            strline = str(cnt)
            outputFile.WriteLine strline
        Next
    Else
        outputFile.WriteLine str
    End If
 
End Sub

Open in new window

Chris Bottomley

This is the reference I made to deleting crbdebug, (there were multiple references). done as below for you

Chris

Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            For intitem = 1 To allFolders.Count
                Debug.Print intitem & vbTab & allFolders(intitem)
            Next
'        Debug.Print itm & vbTab & masterList.Item(itm)
 
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        folderList.Add folderList.Count + 1, startFolder.folderPath
    End If
    For Each Fldr In startFolder.Folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        Err.Clear
        Fldr.Name = oldName & "ish"
        If Err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.Count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
                Set tgt = olNav2Folder("\\Mailbox - Sharath Reddy\Inbox", True)
'                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
    If db Then closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.Folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.Folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.Folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.Folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(outputFilePathandName) Then
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
    Else
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
    End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
    outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
    If IsArray(str) Then
        If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
        strline = Split(str, vbCrLf)
        For cnt = 0 To UBound(str)
            strline = str(cnt)
            outputFile.WriteLine strline
        Next
    Else
        outputFile.WriteLine str
    End If
 
End Sub

Open in new window

ASKER

Sent a mail to u

ASKER

Sent a mail to u

Chris Bottomley

It's actually the output in the immediate window I am looking for this time?

Chris

Chris Bottomley

I have moved some of the debug variables to globals so please replace with the full code as attached. The debug log file contains the data I 'want' this time.

Chris

Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            db = True
            If db Then
                Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
            End If
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            If db Then CRBDebug.closeDebugFile outputFile
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        If db Then CRBDebug.writeLineDebugFile outputFile, folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
        folderList.Add folderList.count + 1, startFolder.folderpath
    End If
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
    Debug.Print folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

I get runtime error 424
When debug goes here
Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
I even tried removing 'CRBDebug." but no luck... :-(

Sorry for being a pain on this...

ASKER

I get runtime error 424
When debug goes here
Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
I even tried removing 'CRBDebug." but no luck... :-(

Sorry for being a pain on this...

Chris Bottomley

Many apologies I lied ... this set should be better ... I forgot to add the debug subs as well as their names.

Whilst the Q is a pain, I do not give up easily and it's not your fault ... yet :o). I truly do not understand why it works for me but not you, but hopefully all this fiddling will get us there.

Chris

Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            db = True
            If db Then
                Set outputFile = openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
            End If
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            If db Then closeDebugFile outputFile
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        If db Then writeLineDebugFile outputFile, folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
        folderList.Add folderList.count + 1, startFolder.folderpath
    End If
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
    Debug.Print folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function 
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(outputFilePathandName) Then
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
    Else
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
    End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
    outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
    If IsArray(str) Then
        If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
        strline = Split(str, vbCrLf)
        For cnt = 0 To UBound(str)
            strline = str(cnt)
            outputFile.WriteLine strline
        Next
    Else
        outputFile.WriteLine str
    End If
 
End Sub

Open in new window

ASKER

Chris no errors now and i could see that it scanned all the folders fine "2367" and all had names.
but just few are visible in the immediate window.
I could not get any results as duplicate folders moving to the Inbox but did not get an error now

ASKER

Chris no errors now and i could see that it scanned all the folders fine "2367" and all had names.
but just few are visible in the immediate window.
I could not get any results as duplicate folders moving to the Inbox but did not get an error now

Chris Bottomley

Another output to debug file

Option Explicit
Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            db = True
            If db Then
                Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
            End If
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            If db Then CRBDebug.writeLineDebugFile outputFile, ""
            If db Then CRBDebug.writeLineDebugFile outputFile, ""
            If db Then CRBDebug.writeLineDebugFile outputFile, 1 & ":" & vbTab & allFolders.Item(1)
            If db Then CRBDebug.writeLineDebugFile outputFile, allFolders.count & ":" & vbTab & allFolders.Item(allFolders.count)
            If db Then CRBDebug.closeDebugFile outputFile
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        folderList.Add folderList.count + 1, startFolder.folderpath
        If db Then CRBDebug.writeLineDebugFile outputFile, folderList.count & ":" & vbTab & folderList.Item(folderList.count)
    End If
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(outputFilePathandName) Then
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
    Else
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
    End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
    outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
    If IsArray(str) Then
        If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
        strline = Split(str, vbCrLf)
        For cnt = 0 To UBound(str)
            strline = str(cnt)
            outputFile.WriteLine strline
        Next
    Else
        outputFile.WriteLine str
    End If
 
End Sub

Open in new window

Chris Bottomley

Sorry assumed still would be problems ... I haven't fixed anything!

ASKER

Hope you asked me to wait right....
Could not follow your last comment right

ASKER

Hope you asked me to wait right....
Could not follow your last comment right

Chris Bottomley

As I said I didn't fix anything but had commented out a long while back teh business end of the script but before I start to re-enable I will delete debug bits and see if still runs without error. Assuming it does i'll re-enable functionality

Chris

Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            db = false
            If db Then
                Set outputFile = openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
            End If
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            If db Then closeDebugFile outputFile
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        If db Then writeLineDebugFile outputFile, folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
        folderList.Add folderList.count + 1, startFolder.folderpath
    End If
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
'    Debug.Print folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
'                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
'                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function 
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(outputFilePathandName) Then
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
    Else
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
    End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
    outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
    If IsArray(str) Then
        If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
        strline = Split(str, vbCrLf)
        For cnt = 0 To UBound(str)
            strline = str(cnt)
            outputFile.WriteLine strline
        Next
    Else
        outputFile.WriteLine str
    End If
 
End Sub

Open in new window

ASKER

No errors and the folders did not move

ASKER

No errors and the folders did not move

Chris Bottomley

OK then hopefully moving teh files

Chris

Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            db = false
            If db Then
                Set outputFile = openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
            End If
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            If db Then closeDebugFile outputFile
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        If db Then writeLineDebugFile outputFile, folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
        folderList.Add folderList.count + 1, startFolder.folderpath
    End If
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
'    Debug.Print folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
'                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function 
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(outputFilePathandName) Then
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
    Else
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
    End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
    outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
    If IsArray(str) Then
        If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
        strline = Split(str, vbCrLf)
        For cnt = 0 To UBound(str)
            strline = str(cnt)
            outputFile.WriteLine strline
        Next
    Else
        outputFile.WriteLine str
    End If
 
End Sub

Open in new window

ASKER

I get run time error 91
When debug goes here
src.MoveTo tgt
When i take the mouse over tgt i get

tgt="inbox"

ASKER

I get run time error 91
When debug goes here
src.MoveTo tgt
When i take the mouse over tgt i get

tgt="inbox"

Chris Bottomley

Trying to think what could have happened ... is there any chance thta some duplicated sub folder names themselves have sub folders?

Chris

ASKER

I dont think so but not sure :-((

Chris Bottomley

A quick hack to skip errors and see if it helps.

Chris

Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            db = false
            If db Then
                Set outputFile = openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
            End If
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            If db Then closeDebugFile outputFile
            Set allFolders = excludeDefaults(defaultFolders, allFolders)
            moveSome allFolders
        End If
    Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        If db Then writeLineDebugFile outputFile, folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
        folderList.Add folderList.count + 1, startFolder.folderpath
    End If
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
'    Debug.Print folderList.count & vbTab & startFolder.Name & vbTab & startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\"))
        If Not def.Exists(str) And str <> "Personal Folders" Then
            If dupes.Exists(str) Then
                dupes(str) = dupes(str) & "|" & masterList.Item(itm)
            Else
                dupes.Add Key:=str, Item:=masterList.Item(itm)
            End If
        End If
    Next
    Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    on error resume next
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
'                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function 
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(outputFilePathandName) Then
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
    Else
        Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
    End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
    outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
    If IsArray(str) Then
        If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
        strline = Split(str, vbCrLf)
        For cnt = 0 To UBound(str)
            strline = str(cnt)
            outputFile.WriteLine strline
        Next
    Else
        outputFile.WriteLine str
    End If
 
End Sub

Open in new window

ASKER

Chris it does work i got say 9 folders moved to the inbox.
Now my Q is did it scan all the folders and sub folders.
And how does it consider it to be a duplicate
1. Is case a matter
2. Will the first word or all words be considered.
3. Is any depth checked like

inbox
>Sharath
>> Ramesh
>>> Sharath
Is this also checked.

And now i just tested it for some time.

Like i create a similar folder in all my 5 psts in the root and sub folders but not even one was moved... :-(

Chris Bottomley

Does it scan all the folders and sub folders:
Not exactly, if it finds a high level folder that meets the criterial it'll move that part of the folder tree

Is case a matter ... shouldn't be since folder names are case insensitive

Will the first word or all words be considered ... All

THat said your comment that some are not processed concerns me BUT I'll not a chance to look again till tomorrow

Chris

ASKER

Ok no problem there are few folders that moved but when i manually tested it did not work

Chris Bottomley

Okay a few issues in the code linked to the fact I assumed that the additional PST's would work whereas now I have implemented a second PST and tested that subject to the previous constraints.

There was also a bug with case considerations that is also fixed.

ONE PROVISO, the additional PST's MUST be uniquely named in the folder window.

Fingers crossed!
Chris

Option Explicit
Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
    Set defaultFolders = CreateObject("scripting.dictionary")
    Set allFolders = CreateObject("scripting.dictionary")
    For Each strStoresItem In Application.Session.Stores
        If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
            Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
            db = True
            If db Then
                Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
            End If
            Call pf_findDefaults(Fldr, defaultFolders, allFolders)
            If db Then CRBDebug.writeLineDebugFile outputFile, ""
            If db Then CRBDebug.writeLineDebugFile outputFile, ""
            If db Then CRBDebug.writeLineDebugFile outputFile, 1 & ":" & vbTab & allFolders.Item(1)
            If db Then CRBDebug.writeLineDebugFile outputFile, allFolders.count & ":" & vbTab & allFolders.Item(allFolders.count)
            If db Then CRBDebug.closeDebugFile outputFile
        End If
    Next
    excludeDefaults defaultFolders, allFolders
    moveSome allFolders
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
    
    On Error Resume Next
    
    ' process all the subfolders of this folder
    If isDefaultFolder(startFolder) Then
        If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
    Else
        folderList.Add folderList.count + 1, startFolder.folderpath
        If db Then CRBDebug.writeLineDebugFile outputFile, folderList.count & ":" & vbTab & folderList.Item(folderList.count)
    End If
    For Each Fldr In startFolder.folders
        Call pf_findDefaults(Fldr, dict, folderList)
    Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
        oldName = Fldr.Name
        On Error Resume Next
        err.Clear
        Fldr.Name = oldName & "ish"
        If err.Number <> 0 Then
            isDefaultFolder = True
        Else
            Fldr.Name = oldName
            isDefaultFolder = False
        End If
        On Error GoTo 0
        
End Function
Function excludeDefaults(def As Object, ByRef masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
    Set dupes = CreateObject("scripting.dictionary")
'    For itm = 1 To masterList.count
'        Debug.Print itm & vbTab & masterList.Item(itm)
'    Next
    'Stop
    For intitem = 1 To masterList.count
        itm = intitem
'        Debug.Print itm & vbTab & masterList.Item(itm)
        str = LCase(Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), "\")))
        If (InStr(3, masterList.Item(itm), "\") <> 0) Then
            If Not def.Exists(str) Then
                If dupes.Exists(LCase(str)) Then
                    dupes(str) = dupes(str) & "|" & LCase(masterList.Item(itm))
                Else
                    dupes.Add Key:=LCase(str), Item:=LCase(masterList.Item(itm))
                End If
            End If
        End If
'        If Not def.Exists(str) And str <> "Personal Folders" Then
'            If dupes.Exists(LCase(str)) Then
'                dupes(str) = dupes(str) & "|" & LCase(masterList.Item(itm))
'            Else
'                dupes.Add Key:=LCase(str), Item:=LCase(masterList.Item(itm))
'            End If
'        End If
    Next
    Set masterList = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
    If db Then
        Set outputFile = CRBDebug.openDebugFile(Environ("temp") & "\CRBDataTrace.txt")
    End If
    If dupes Is Nothing Then Exit Function
    For Each itm In dupes.Keys
        If db Then CRBDebug.writeLineDebugFile outputFile, "Processing item " & itm & ", (" & dupes.Item(itm) & ")"
        If InStr(dupes.Item(itm), "|") > 0 Then
            fldrs = Split(dupes.Item(itm), "|")
            For folderindex = 0 To UBound(fldrs)
                strFolder = fldrs(folderindex)
                If db Then CRBDebug.writeLineDebugFile outputFile, "Processing Line item " & folderindex & ",(" & strFolder & ") of 0 ... " & UBound(fldrs)
                Set src = olNav2Folder(CStr(strFolder), False)
                Set tgt = olNav2Folder("\\Mailbox - Sharath\Inbox", True)
'                Set tgt = olNav2Folder("\\Personal Folders\Inbox", True)
                src.moveto tgt
            Next
        End If
    Next
    If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

ASKER

I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

Variable not defined
---------------------------
OK Help
---------------------------

ASKER

I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

Variable not defined
---------------------------
OK Help
---------------------------

ASKER CERTIFIED SOLUTION

Chris Bottomley

membership

Create a free account to see this answer

Signing up is free and takes 30 seconds. No credit card required.

ASKER

Thanks a lot Chris at last we made it work. Its fast and acurate too. It works Awesome and was able to retrieve more than 100 duplicate folders... :-))) THANK YOU........................

ASKER

Thanks a lot Chris at last we made it work. Its fast and acurate too. It works Awesome and was able to retrieve more than 100 duplicate folders... :-))) THANK YOU........................

Chris Bottomley

PHEEEEEEEEEw