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

Question

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

Answer 1

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