Need to find duplicate folders and move mails accordingly

Hi,

Need to find duplicate folders and move mails accordingly

Say i have 2 identical folders within a root folder like

Sharath
Sharath1

1 will be the increment for the identical folder.

If found 1 at the end of the folder name then check for similar folder name without one. if found move all mails from the 1 named folder to the identical named folder and then delete the empty folder.

Regards
Sharath
LVL 11
bsharathAsked:
Who is Participating?
 
Chris BottomleyConnect With a Mentor Software Quality Lead EngineerCommented:
Think i've found that one but i'm using a function to change the method so see if you have the olkNav2Folder function somewhere and if not try Nav2Folder.

Chris
Sub Q25029903()
Dim myFolder As MAPIFolder
Dim intItem As Integer
Dim itm As Object
Dim fldr As Object
Dim intFldr As Integer
          
    Set myFolder = Application.GetNamespace("mapi").PickFolder
    If Not myFolder Is Nothing Then
        For intFldr = myFolder.folders.count To 1 Step -1
            Set fldr = myFolder.folders(intFldr)
            If IsNumeric(Right(fldr.Name, 1)) Then
                If Not olkNav2Folder(myFolder.folderpath & "\" & Left(fldr.Name, Len(fldr.Name) - 1)) Is Nothing Then
                    For intItem = fldr.items.count To 1 Step -1
                        Set itm = fldr.items(intItem)
                        itm.Move myFolder.folders(Left(fldr.Name, Len(fldr.Name) - 1))
                    Next
                    fldr.Delete
                End If
            End If
        Next
    End If
  
End Sub

Open in new window

0
 
David LeeCommented:
Hi, Sharath.

Search where?  All folders in all mailboxes and PST files?  Also are you saying that the name match is only to occur if the second folder has a 1 on the end?  For example, Sharath and Sharath1 would be considered a match but Sharath and Sharath2 would not.  Is that correct?
0
 
bsharathAuthor Commented:
Search just the subfolders that i select the root folder and run..
just the folders below the selected folder
Full exact name has to be matched and 1 alone. I havent seen any with 2 till now. So we shall take 1 into consideration and move mails from Sharath1 to Sharath and delete Sharath1
Find duplicates for all name matches. Folder names will have spaces....
0
Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Chris BottomleySoftware Quality Lead EngineerCommented:
bsharath:

Does this requirement apply only to those folders directly below the selected folder ...

fred
    doris
    doris1
    norman
        doris

i.e. if Fred is the root folder selected then the function applies to:
fred\doris
fred\doris1
fred\norman

AND NOT

fred\norman\doris

Chris
0
 
bsharathAuthor Commented:
It applies to just the Root folder

fred
    doris
    doris1
    norman
        doris
Only where no 1 shows as duplicate
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
fred
    doris
    doris1
    norman
        doris1

Sorry still not clear, is folder fred\norman\doris1 in the above scenario excluded

Chris
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Assuming it is just the immediate sub folders then:

Chris
Sub Q25029903()
Dim myFolder As MAPIFolder
Dim itm As Object
Dim fldr As Object
Dim intFldr As Integer
        
    Set myFolder = Application.GetNamespace("mapi").PickFolder
    If Not myFolder Is Nothing Then
        For intFldr = myFolder.folders.count To 1 Step -1
            Set fldr = myFolder.folders(intFldr)
            If IsNumeric(Right(fldr.Name, 1)) Then
                If Not myFolder.folders(Left(fldr.Name, Len(fldr.Name) - 1)) Is Nothing Then
                    For Each itm In fldr.items
                        itm.Move myFolder.folders(Left(fldr.Name, Len(fldr.Name) - 1))
                    Next
                    fldr.Delete
                End If
            End If
        Next
    End If

End Sub

Open in new window

0
 
bsharathAuthor Commented:
Chris its the immediate Sub folder.
Will it Copy emails and delete the duplicate folder also?
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
The script above processes the folders immediately below the selected folder and moves all the items in a numbered suffix to the folder of the same name without a suffix and then deletes the suffixed folder.

IF there is no folder without the suffix then it does nothing.

Chris
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Stupid mistake therein!  Please see correction

Chris
Sub Q25029903() 
Dim myFolder As MAPIFolder 
Dim intItem As integer 
Dim itm As Object 
Dim fldr As Object 
Dim intFldr As Integer 
         
    Set myFolder = Application.GetNamespace("mapi").PickFolder 
    If Not myFolder Is Nothing Then 
        For intFldr = myFolder.folders.count To 1 Step -1 
            Set fldr = myFolder.folders(intFldr) 
            If IsNumeric(Right(fldr.Name, 1)) Then 
                If Not myFolder.folders(Left(fldr.Name, Len(fldr.Name) - 1)) Is Nothing Then 
                    For intItem = fldr.items.count to 1 step -1
                        set itm = fldr.items(intItem)
                        itm.Move myFolder.folders(Left(fldr.Name, Len(fldr.Name) - 1)) 
                    Next 
                    fldr.Delete 
                End If 
            End If 
        Next 
    End If 
 
End Sub

Open in new window

0
 
bsharathAuthor Commented:
Chris i get this

An Object failed could not be found

WHEN DEBUG GOES HERE'
                If Not myFolder.Folders(Left(fldr.Name, Len(fldr.Name) - 1)) Is Nothing Then
0
 
bsharathAuthor Commented:
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.