• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 202
  • Last Modified:

Move 7 folders data to another 7 locations when macro run. Outlook Macro that can do this.

Hi,

Move 7 folders data to another 7 locations when macro run. Outlook Macro that can do this.

I have these folders in this path

Mailbox -Sharath\Inbox\Sop1
Mailbox -Sharath\Inbox\Sop2
Mailbox -Sharath\Inbox\Sop 12
Mailbox -Sharath\Inbox\Sop3
Mailbox -Sharath\Inbox\Sop4
Mailbox -Sharath\Inbox\Sop5
Mailbox -Sharath\Inbox\Sop6

When right click and run macro i want each folder mails only to be moved to another location in a pst whose path is defined in the macro. I want to verify each folder email then move them later. So in this position i cannot use a direct rule.

Regards
Sharath

0
bsharath
Asked:
bsharath
  • 15
  • 15
1 Solution
 
Chris BottomleyCommented:
When you right click on an individual folder identified above all mails therein are to be moved to a specific folder, but only from the specific folder selected?

Chris
0
 
bsharathAuthor Commented:
Hi Chris
The from folder and to folder needs to be defined in the code...
So when i right click andy folder and say "Move 7" all the 7 folders data has to be moved to another 7 folders in respective pst as mentioned in code
0
 
Chris BottomleyCommented:
How are the 7 destination folders identified, by the same names as the original folders just a different root or something else?

Chris
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
bsharathAuthor Commented:
Each folder will have different paths like
All will be in this path
\\Mailbox - Sharat\inbox

But the destinations will be
\\All mails\Somename
\\All mails\Somename

\\Dated\Somename


0
 
Chris BottomleyCommented:
Can you upload your thisoutlooksession code so I can add the support for the feature ... ideally please identify the legend you want in the menu for example: "Move 7 Folders"

Chris
0
 
bsharathAuthor Commented:
Emailed you the code

we can have as "Move 7 folders"
0
 
Chris BottomleyCommented:
As ever sub olkNav2Folder is included for completeness but if there is already a copy in the module it should be left out.

Chris
Sub Q25048313()
Dim RootFolder As Object
Dim ProcessFolder As Object
Dim DestFolder As Object
Dim strRootFolder As Object
Dim strSourceFolders As String
Dim strProcessFolder As Variant
Dim itm As Object
Dim itmCount As Integer
Const strSop1Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop2Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop12Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop3Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop4Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop5Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop6Moveto As String = "\\personal folders\testmoves\Sop1"
    
    #If cbPC Then
        Set strRootFolder = Application.Session.folders("Personal Folders").folders("inbox")
    #Else
        Set strRootFolder = Application.Session.folders("Mailbox -Sharath").folders("inbox")
    #End If
    strSourceFolders = "Sop1, Sop2, Sop 12, Sop3, SOp4, Sop5, Sop6"
    For Each strProcessFolder In Split(Replace(strSourceFolders, ", ", ","), ",")
        Set ProcessFolder = strRootFolder.folders(strProcessFolder)
        Select Case LCase(strProcessFolder)
            Case "sop1"
                Set DestFolder = olkNav2Folder(strSop1Moveto, True)
            Case "sop2"
                Set DestFolder = olkNav2Folder(strSop2Moveto, True)
            Case "sop 12"
                Set DestFolder = olkNav2Folder(strSop12Moveto, True)
            Case "sop3"
                Set DestFolder = olkNav2Folder(strSop3Moveto, True)
            Case "sop4"
                Set DestFolder = olkNav2Folder(strSop4Moveto, True)
            Case "sop5"
                Set DestFolder = olkNav2Folder(strSop5Moveto, True)
            Case "sop6"
                Set DestFolder = olkNav2Folder(strSop6Moveto, True)
            Case Else
                MsgBox "Unexpected Folder detected"
        End Select
        For itmCount = ProcessFolder.items.count To 1 Step -1
            ProcessFolder.items(itmCount).Move DestFolder
        Next
    Next
    
End Sub

Public Function olkNav2Folder(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 olkNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

0
 
bsharathAuthor Commented:
Chris should i change these lines...

Const strSop1Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop2Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop12Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop3Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop4Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop5Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop6Moveto As String = "\\personal folders\testmoves\Sop1"
     
    #If cbPC Then
        Set strRootFolder = Application.Session.Folders("Personal Folders").Folders("inbox")
    #Else
        Set strRootFolder = Application.Session.Folders("Mailbox -Sharath").Folders("inbox")
    #End If
    strSourceFolders = "Sop1, Sop2, Sop 12, Sop3, SOp4, Sop5, Sop6"

Can you please tell me what has to be updated...
0
 
Chris BottomleyCommented:
Const strSop1Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop2Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop12Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop3Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop4Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop5Moveto As String = "\\personal folders\testmoves\Sop1"
Const strSop6Moveto As String = "\\personal folders\testmoves\Sop1"
All need to be changed to reference the destination folders for each of the '7' folders.

    #If cbPC Then
        Set strRootFolder = Application.Session.Folders("Personal Folders").Folders("inbox")
    #Else
        Set strRootFolder = Application.Session.Folders("Mailbox -Sharath").Folders("inbox")
    #End If
DOES NOT need changing it will work without alteration and makes debugging easier if kept.

    strSourceFolders = "Sop1, Sop2, Sop 12, Sop3, SOp4, Sop5, Sop6"
DOES NOT need changing it saved declaring seven similarly named subfolders for the source folders.

Note also I was over-zealous with cut and paste so I have mailed the modified thisOutlookSession code again.

Chris
0
 
bsharathAuthor Commented:
I just changes as this

Const strSop1Moveto As String = "\\All Mails\Inbox\Delivered&Read"
Const strSop2Moveto As String = "\\All Mails\Inbox\File server"
Const strSop12Moveto As String = "\\All Mails\Inbox\ICT"
Const strSop3Moveto As String = "\\All Mails\Inbox\Ram"
Const strSop4Moveto As String = "\\All Mails\Inbox\Scs"
Const strSop5Moveto As String = "\\All Mails\Inbox\Sophos"
Const strSop6Moveto As String = "\\All Mails\Inbox\External senders"
     
    #If cbPC Then
        Set strRootFolder = Application.Session.Folders("All Mails").Folders("inbox")
    #Else
        Set strRootFolder = Application.Session.Folders("Mailbox -Sharath").Folders("inbox")
    #End If
    strSourceFolders = "Delivered&Read,File server,ICT,Ram,Scs,Sophos,External Senders"

Is this right
As it does not work...
0
 
Chris BottomleyCommented:
   strSourceFolders = "Delivered&Read,File server,ICT,Ram,Scs,Sophos,External Senders"
would be a problem ... like I said:

    strSourceFolders = "Sop1, Sop2, Sop 12, Sop3, SOp4, Sop5, Sop6"
DOES NOT need changing it saved declaring seven similarly named subfolders for the source folders.

Chris
0
 
bsharathAuthor Commented:
I did the change and when run macro directly i get
Object could not be found

When debug goes here
        Set ProcessFolder = strRootFolder.Folders(strProcessFolder)

These 2 lines hsould it be from and to?

  Set strRootFolder = Application.Session.Folders("All Mails").Folders("inbox")
    #Else
        Set strRootFolder = Application.Session.Folders("Mailbox - Sharath").Folders("inbox")
0
 
Chris BottomleyCommented:

From only one works for me and one for you
0
 
Chris BottomleyCommented:
Back on the PC so I can try and explain better:

The code block:

    #If cbPC Then
        Set strRootFolder = Application.Session.Folders("All Mails").Folders("inbox")
    #Else
        Set strRootFolder = Application.Session.Folders("Mailbox -Sharath").Folders("inbox")
    #End If

Is the same as:
        Set strRootFolder = Application.Session.Folders("Mailbox -Sharath").Folders("inbox")
on your pc whereas it is the same as:
        Set strRootFolder = Application.Session.Folders("All Mails").Folders("inbox")
on mine.

In this way I can test on my PC and it is less likely I forget to make the correction when posting.  i.e. simply ignore the complexity as it is to all intents simply a single line that defines the root of the from folder and off which the sub folders in the strSourceFolders are defined.

As for the rep[orted error are you sure of folders in the string "Sop1, Sop2, Sop 12, Sop3, SOp4, Sop5, Sop6" already exist as subfolders off Mailbox -Sharath\Inbox.  Because it seems to be saying noting is found ...

i.e. what do you have now for the equivalent lines 23:25 in my earlier post?

Chris
0
 
bsharathAuthor Commented:
This is the destination paths

Const strSop1Moveto As String = "\\All Mails\Inbox\Delivered&Read"
Const strSop2Moveto As String = "\\All Mails\Inbox\File server"
Const strSop12Moveto As String = "\\All Mails\Inbox\ICT"
Const strSop3Moveto As String = "\\All Mails\Inbox\Ram"
Const strSop4Moveto As String = "\\All Mails\Inbox\Scs"
Const strSop5Moveto As String = "\\All Mails\Inbox\Sophos"
Const strSop6Moveto As String = "\\All Mails\Inbox\External senders"

or should it be the source paths


I havr the below lines

 Set strRootFolder = Application.Session.Folders("Mailbox - Sharath").Folders("inbox")
    #Else
        Set strRootFolder = Application.Session.Folders("All Mails").Folders("inbox")
    #End If
    strSourceFolders = "Sop1, Sop2, Sop 12, Sop3, Sop4, Sop5, Sop6"

0
 
Chris BottomleyCommented:
So far so good.

When it stops what value does strProcessFolder have .. a rollover of the cursor should tell you.

Chris
0
 
bsharathAuthor Commented:
I get process folder = nothing
0
 
Chris BottomleyCommented:
Can you upload the code as you are using it as something is wrong and it's either the code (I can check if something is significantly messed up in the edits) or the source folder(s) do not exist.

Chris
0
 
bsharathAuthor Commented:
Belo is the full code....
Sub Q25048313()
Dim RootFolder As Object
Dim ProcessFolder As Object
Dim DestFolder As Object
Dim strRootFolder As Object
Dim strSourceFolders As String
Dim strProcessFolder As Variant
Dim itm As Object
Dim itmCount As Integer
Const strSop1Moveto As String = "\\All Mails\Inbox\Delivered&Read"
Const strSop2Moveto As String = "\\All Mails\Inbox\File server"
Const strSop12Moveto As String = "\\All Mails\Inbox\ICT"
Const strSop3Moveto As String = "\\All Mails\Inbox\Ram"
Const strSop4Moveto As String = "\\All Mails\Inbox\Scs"
Const strSop5Moveto As String = "\\All Mails\Inbox\Sophos"
Const strSop6Moveto As String = "\\All Mails\Inbox\External senders"
     
    #If cbPC Then
        Set strRootFolder = Application.Session.Folders("Mailbox - Sharath").Folders("inbox")
    #Else
        Set strRootFolder = Application.Session.Folders("All Mails").Folders("inbox")
    #End If
    strSourceFolders = "Sop1, Sop2, Sop 12, Sop3, Sop4, Sop5, Sop6"
    For Each strProcessFolder In Split(Replace(strSourceFolders, ", ", ","), ",")
        Set ProcessFolder = strRootFolder.Folders(strProcessFolder)
        Select Case LCase(strProcessFolder)
            Case "sop1"
                Set DestFolder = olkNav2Folder(strSop1Moveto, True)
            Case "sop2"
                Set DestFolder = olkNav2Folder(strSop2Moveto, True)
            Case "sop 12"
                Set DestFolder = olkNav2Folder(strSop12Moveto, True)
            Case "sop3"
                Set DestFolder = olkNav2Folder(strSop3Moveto, True)
            Case "sop4"
                Set DestFolder = olkNav2Folder(strSop4Moveto, True)
            Case "sop5"
                Set DestFolder = olkNav2Folder(strSop5Moveto, True)
            Case "sop6"
                Set DestFolder = olkNav2Folder(strSop6Moveto, True)
            Case Else
                MsgBox "Unexpected Folder detected"
        End Select
        For itmCount = ProcessFolder.Items.Count To 1 Step -1
            ProcessFolder.Items(itmCount).Move DestFolder
        Next
    Next
     
End Sub
 
Public Function olkNav2Folder(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 olkNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

0
 
Chris BottomleyCommented:
I missed the change you hade to the #if construct assuming it was still as per the original post.  I have taken my original post and applied the changes from yours for ther destination folders.  Hopefully that will work without any other edit.

Chris
Sub Q25048313() 
Dim RootFolder As Object 
Dim ProcessFolder As Object 
Dim DestFolder As Object 
Dim strRootFolder As Object 
Dim strSourceFolders As String 
Dim strProcessFolder As Variant 
Dim itm As Object 
Dim itmCount As Integer 
Const strSop1Moveto As String = "\\All Mails\Inbox\Delivered&Read" 
Const strSop2Moveto As String = "\\All Mails\Inbox\File server" 
Const strSop12Moveto As String = "\\All Mails\Inbox\ICT" 
Const strSop3Moveto As String = "\\All Mails\Inbox\Ram" 
Const strSop4Moveto As String = "\\All Mails\Inbox\Scs" 
Const strSop5Moveto As String = "\\All Mails\Inbox\Sophos" 
Const strSop6Moveto As String = "\\All Mails\Inbox\External senders" 
     
    #If cbPC Then 
        Set strRootFolder = Application.Session.folders("Personal Folders").folders("inbox") 
    #Else 
        Set strRootFolder = Application.Session.folders("Mailbox -Sharath").folders("inbox") 
    #End If 
    strSourceFolders = "Sop1, Sop2, Sop 12, Sop3, SOp4, Sop5, Sop6" 
    For Each strProcessFolder In Split(Replace(strSourceFolders, ", ", ","), ",") 
        Set ProcessFolder = strRootFolder.folders(strProcessFolder) 
        Select Case LCase(strProcessFolder) 
            Case "sop1" 
                Set DestFolder = olkNav2Folder(strSop1Moveto, True) 
            Case "sop2" 
                Set DestFolder = olkNav2Folder(strSop2Moveto, True) 
            Case "sop 12" 
                Set DestFolder = olkNav2Folder(strSop12Moveto, True) 
            Case "sop3" 
                Set DestFolder = olkNav2Folder(strSop3Moveto, True) 
            Case "sop4" 
                Set DestFolder = olkNav2Folder(strSop4Moveto, True) 
            Case "sop5" 
                Set DestFolder = olkNav2Folder(strSop5Moveto, True) 
            Case "sop6" 
                Set DestFolder = olkNav2Folder(strSop6Moveto, True) 
            Case Else 
                MsgBox "Unexpected Folder detected" 
        End Select 
        For itmCount = ProcessFolder.items.count To 1 Step -1 
            ProcessFolder.items(itmCount).Move DestFolder 
        Next 
    Next 
     
End Sub 
 
Public Function olkNav2Folder(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 olkNav2Folder = reqdFolder 
    Set olApp = Nothing 
    Set olNS = Nothing 
    Set olfldr = Nothing 
    Set reqdFolder = Nothing 
End Function

Open in new window

0
 
bsharathAuthor Commented:
Chris still get the same message
But now when mouse over i get
strProcessFolder
> strProcessFolder= "sop1"
0
 
Chris BottomleyCommented:
Okay then either the root folder does not exist or the sop1 one.  Put the cursor in the outlook explorer onto the sop1 folder then in the VBE type:

?">>>" & application.ActiveExplorer.CurrentFolder.FolderPath & "<<<"

WHat do you get?

Chris
0
 
bsharathAuthor Commented:
I Get this

?">>>" & application.ActiveExplorer.CurrentFolder.FolderPath & "<<<"
>>>\\Mailbox - Sharath\Inbox\Delivered&Read<<<
0
 
Chris BottomleyCommented:
The sop1 folder is called "Delivered&Read"!!!!
In the original question you stated:
I have these folders in this path
Mailbox -Sharath\Inbox\Sop1
...
Mailbox -Sharath\Inbox\Sop6

I appreciate that is what you changed the strSourceFolders to say but it contradicts the original post so I thought you were referring to the destination folders when you edited it.  Since the situation is confused can you please identify a list of the folders to be processed and the folder to which each 'source' folder must move?

Chris
0
 
bsharathAuthor Commented:
Ok

I have the Mails here

\\Mailbox - Sharath\Inbox\Delivered&Read
\\Mailbox - Sharath\Inbox\File server
\\Mailbox - Sharath\Inbox\ICT
\\Mailbox - Sharath\Inbox\Ram
\\Mailbox - Sharath\Inbox\SCS
\\Mailbox - Sharath\Inbox\External senders

Need the folder mails to be moved to the below paths
"\\All Mails\Inbox\Delivered&Read"
"\\All Mails\Inbox\File server"
"\\All Mails\Inbox\ICT"
"\\All Mails\Inbox\Ram"
"\\All Mails\Inbox\Scs"
"\\All Mails\Inbox\Sophos"
"\\All Mails\Inbox\External senders"


Please change the lines

0
 
Chris BottomleyCommented:
How about the sophos source folder ... is that:

\\Mailbox - Sharath\Inbox\Sophos

Chris
0
 
bsharathAuthor Commented:
Sorry missed that here
But i have it on the code...

B ut i will have many more folders in the real paths which need to be skipped and move just 7 to 7
\Mailbox - Sharath\Inbox\Dead mails
\Mailbox - Sharath\Inbox\Alive mails
0
 
Chris BottomleyCommented:
Sharath

If I understand the situation correctly now then:

Chris
Sub Q25048313()
Dim RootFolder As Object
Dim ProcessFolder As Object
Dim DestFolder As Object
Dim strRootFolder As Object
Dim strDestRoot As Object
Dim strSourceFolders As String
Dim strProcessFolder As Variant
Dim itm As Object
Dim itmCount As Integer
Dim strFolderArray() As String
    
    #If cbPC Then
        Set strRootFolder = Application.Session.folders("Personal Folders").folders("inbox")
        Set strDestRoot = Application.Session.folders("Personal Folders").folders("testmoves")
        strSourceFolders = "Sop1, Sop2, Sop 12, Sop3, SOp4, Sop5, Sop6"
    #Else
        Set strRootFolder = Application.Session.folders("Mailbox -Sharath").folders("inbox")
        Set strDestRoot = Application.Session.folders("Mailbox -Sharath").folders("all mails")
        strSourceFolders = "Delivered&Read,File server,ICT,Ram,Scs,Sophos,External Senders"
    #End If
    strFolderArray = Split(Replace(strSourceFolders, ", ", ","), ",")
    For Each strProcessFolder In strFolderArray
        Set ProcessFolder = strRootFolder.folders(strProcessFolder)
        Set DestFolder = strDestRoot.folders(strProcessFolder)
        For itmCount = ProcessFolder.items.count To 1 Step -1
            ProcessFolder.items(itmCount).Move DestFolder
        Next
    Next
    
End Sub

Open in new window

0
 
bsharathAuthor Commented:
Thanks...
Works perfect....
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 15
  • 15
Tackle projects and never again get stuck behind a technical roadblock.
Join Now