question

JamesShaw-6590 avatar image
0 Votes"
JamesShaw-6590 asked Viorel-1 edited

Macro to move mail to particular mailbox (depending on original inbox)

Hi guys,

I have two outlooks mailboxes.
I would like to have a single macro that would move selected mail from my work email to a folder called "Deleted(Temp)" (which is located in my work outlook),
at the same time if i ran the same macro in my personal inbox, the macro would move the selected email to a "Deleted(Temp)" folder within my personal outlook
The code below works, but it is too separate macros, I would like just one macro to do both.

Thanks guys.


 'Outlook VB Macro to move selected mail item(s) to a target folder
 'Macro moves file from inbox to "Deleted(Temp)" file
 '"Deleted(Temp)" cannot exist as a subfolder
    
    
    
 Sub MoveEmailGolderTempDelete()
 'On Error Resume Next
    
 Dim NS As Outlook.NameSpace
 Dim moveToFolder As Outlook.MAPIFolder
 Dim objItem As Outlook.MailItem
    
 Set NS = Application.GetNamespace("MAPI")
    
 'Define path to the target folder
 Set moveToFolder = NS.Folders("Jashaw@golder.com.au").Folders("Deleted(Temp)")
    
 If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox ("No item selected")
    Exit Sub
 End If
    
 If moveToFolder Is Nothing Then
    MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
 End If
    
 For Each objItem In Application.ActiveExplorer.Selection
    If moveToFolder.DefaultItemType = olMailItem Then
       If objItem.Class = olMail Then
          objItem.Move moveToFolder
       End If
   End If
 Next
    
 Set objItem = Nothing
 Set moveToFolder = Nothing
 Set NS = Nothing
    
 End Sub
    
    
    
    
 Sub MoveEmailPersonalTempDelete()
 'On Error Resume Next
    
 Dim NS As Outlook.NameSpace
 Dim moveToFolder As Outlook.MAPIFolder
 Dim objItem As Outlook.MailItem
    
 Set NS = Application.GetNamespace("MAPI")
    
 'Define path to the target folder
 Set moveToFolder = NS.Folders("jamesshaw@live.com.au").Folders("Deleted(Temp)")
    
 If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox ("No item selected")
    Exit Sub
 End If
    
 If moveToFolder Is Nothing Then
    MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
 End If
    
 For Each objItem In Application.ActiveExplorer.Selection
    If moveToFolder.DefaultItemType = olMailItem Then
       If objItem.Class = olMail Then
          objItem.Move moveToFolder
       End If
   End If
 Next
    
 Set objItem = Nothing
 Set moveToFolder = Nothing
 Set NS = Nothing
    
 End Sub
office-vba-dev
· 1
5 |1600 characters needed characters left characters exceeded

Up to 10 attachments (including images) can be used with a maximum of 3.0 MiB each and 30.0 MiB total.

Hi @JamesShaw-6590,

Welcome to our forum.

Please kindly understand under Outlook tag, we mainly focus on general issue on Outlook desktop client, considering your issue may be more related to VBA development, I would remove Outlook tag and add VBA development tag, thanks for your understanding and hope your issue would be resolved soon.

0 Votes 0 ·

1 Answer

Viorel-1 avatar image
0 Votes"
Viorel-1 answered Viorel-1 edited

Try something like this:

 Sub MoveEmails()
    MoveEmailsHelper "Jashaw@golder.com.au"
    MoveEmailsHelper "jamesshaw@live.com.au"
 End Sub
    
 Private Sub MoveEmailsHelper(ByVal folderName as String)
        
    Dim NS As Outlook.NameSpace
    Dim moveToFolder As Outlook.MAPIFolder
    Dim objItem As Outlook.MailItem
    
    Set NS = Application.GetNamespace("MAPI")
    
    'Define path to the target folder
    Set moveToFolder = NS.Folders(folderName).Folders("Deleted(Temp)")
    
    If Application.ActiveExplorer.Selection.Count = 0 Then
       MsgBox ("No item selected")
       Exit Sub
    End If
    
    If moveToFolder Is Nothing Then
       MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
      Exit Sub
    End If
    
    For Each objItem In Application.ActiveExplorer.Selection
       If moveToFolder.DefaultItemType = olMailItem Then
          If objItem.Class = olMail Then
             objItem.Move moveToFolder
          End If
       End If
    Next
    
    Set objItem = Nothing
    Set moveToFolder = Nothing
    Set NS = Nothing
        
 End Sub
5 |1600 characters needed characters left characters exceeded

Up to 10 attachments (including images) can be used with a maximum of 3.0 MiB each and 30.0 MiB total.