Find Duplicate folders only from 4 of my Pst's. Need to scan each and every folder name in all pst's in the outlook and get the duplicate folder names alone to an excel/txt file.

• MyPsts(1) = "2003"
• MyPsts(2) = "2004"
• MyPsts(3) = "2005"
• MyPsts(4) = "2006"

ption Explicit
 
Sub FolderList()
    Dim myNamespace As Outlook.NameSpace
    Dim MyPsts(1 To 4) As String, Pst
    Dim MyDic, objFSO, objTextFile
    Dim MainFolder As MAPIFolder
 
    Set objFSO = CreateObject("scripting.filesystemobject")
    Set objTextFile = objFSO.createtextfile("c:\duplist.csv")
    Set myNamespace = Application.GetNamespace("MAPI")
    Set MyDic = CreateObject("scripting.dictionary")
    MyPsts(1) = "2003"
    MyPsts(2) = "2004"
MyPsts(3) = "2005"
MyPsts(4) = "2006"
    For Each Pst In MyPsts
        Set MainFolder = myNamespace.Folders(Pst)
        Call ProcessFolder(MainFolder, MyDic, objTextFile)
    Next
    Set MyDic = Nothing
    objTextFile.Close
    Set objFSO = Nothing
    
    MsgBox "Done"
End Sub
 
 
 
Sub ProcessFolder(ByVal MainFolder As MAPIFolder, ByVal MyDic, ByVal objTextFile)
    Dim objFolder As Outlook.MAPIFolder
 
    For Each objFolder In MainFolder.Folders
        If MyDic.exists(objFolder.Name) Then
            objTextFile.Write objFolder.FolderPath & "," & Right$(MyDic(objFolder.Name), Len(MyDic(objFolder.Name)) - InStr(MyDic(objFolder.Name), "|||") - 2)
            objTextFile.Writeline
        Else
            MyDic.Add objFolder.Name, objFolder.Name & "|||" & objFolder.FolderPath
        End If
        Call ProcessFolder(objFolder, MyDic, objTextFile)
    Next
    Set objFolder = Nothing
End Sub

Select allOpen in new window

Option Explicit
Sub FolderList()
    Dim myNameSpace As Outlook.NameSpace
    Dim Pst
    Dim MyDic, objFSO, objTextFile
    Dim MainFolder As MAPIFolder
 
    Set objFSO = CreateObject("scripting.filesystemobject")
    Set objTextFile = objFSO.createtextfile("c:\duplist.csv")
    Set myNameSpace = Application.GetNamespace("MAPI")
    Set MyDic = CreateObject("scripting.dictionary")
 
    For Each Pst In myNameSpace.Folders
        Set MainFolder = myNameSpace.Folders(Pst.Name)
        Call ProcessFolder(MainFolder, MyDic, objTextFile)
    Next
    Set MyDic = Nothing
    objTextFile.Close
    Set objFSO = Nothing
 
    MsgBox "Done"
End Sub
 
 
 
Sub ProcessFolder(ByVal MainFolder As MAPIFolder, ByVal MyDic, ByVal objTextFile)
    Dim objFolder As Outlook.MAPIFolder
 
    For Each objFolder In MainFolder.Folders
        If MyDic.exists(objFolder.Name) Then
            objTextFile.Write objFolder.FolderPath & "," & Right$(MyDic(objFolder.Name), Len(MyDic(objFolder.Name)) - InStr(MyDic(objFolder.Name), "|||") - 2)
            objTextFile.Writeline
        Else
            MyDic.Add objFolder.Name, objFolder.Name & "|||" & objFolder.FolderPath
        End If
        Call ProcessFolder(objFolder, MyDic, objTextFile)
    Next
    Set objFolder = Nothing
End Sub

Select allOpen in new window