Save all Outlook mailitems to disk with VBA

Question

I have some experience with VBA in Excel, but taking my first steps in Outlook. I need to save all e-mail messages in a designated Outlook folder (Inbox\input) to disk (D:\myArchive\Email\) as .msg files and move mail item to archive folder in Outlook (Inbox\archive).

I have set up a mail rule in Outlook that moves mail to archive folder and runs a script below which actually does what I need. The problem is that I get mail rule error pop-ups occasionally and I struggle to track down the reason. Hence looking to turn away from Outlook mail rule and cycle through all folder contents "on-demand".

How could I convert it to cycle through Outlook folder as well as displace the mail item? Currently running Outlook 2019. Thanks!

edit: sorry, late clarification - target folder is in another mailbox (Office 365 shared mailbox). How to target a different account?

Public Sub saveEmailtoDisk(itm As Outlook.MailItem)
    Dim saveFolder, msgName1, msgName2 As String
    
    saveFolder = "D:\myArchive\Email\"
    
    msgName1 = Replace(itm.Subject, ":", "")
    msgName2 = Replace(msgName1, "/", "_")
    
    itm.SaveAs saveFolder & msgName2 & ".msg", olMSG
    
End Sub

Domenic Domenic · Accepted Answer · 2021-05-31T13:59:20

The following code assumes that both the input and archive folders are located within the default inbox.

Public Sub saveAndArchiveInputEmails()

    Dim saveFolder As String
    saveFolder = "D:\myArchive\Email\"
    
    Dim sourceFolder As Folder
    Dim destFolder As Folder
    With Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
        Set sourceFolder = .Folders("input")
        Set destFolder = .Folders("archive")
    End With

    Dim itm As Object
    Dim i As Long
    With sourceFolder
        For i = .Items.Count To 1 Step -1
            Set itm = .Items(i)
            If TypeName(itm) = "MailItem" Then
                saveEmailtoDisk saveFolder, itm
                itm.Move destFolder
            End If
        Next i
    End With
    
End Sub

Public Sub saveEmailtoDisk(ByRef saveFolder As String, ByVal itm As Object)
    
    Dim msgName1, msgName2 As String
    
    msgName1 = Replace(itm.Subject, ":", "")
    msgName2 = Replace(msgName1, "/", "_")
    
    itm.SaveAs saveFolder & msgName2 & ".msg", olMSG
    
End Sub

EDIT

For a shared mailbox, try the following instead...

With Application.GetNamespace("MAPI")

    Dim sharedEmail As Recipient
    Set sharedEmail = .CreateRecipient("[email protected]")
    
    Dim sourceFolder As Folder
    Set sourceFolder = .GetSharedDefaultFolder(sharedEmail, olFolderInbox).Folders("input")
    
    Dim destFolder As Folder
    Set destFolder = .GetSharedDefaultFolder(sharedEmail, olFolderInbox).Folders("archive")
    

End With

For your default inbox...

Dim myInbox As Folder
Set myInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

Save all Outlook mailitems to disk with VBA

1 Answers