Save all Outlook mailitems to disk and move to shared mailbox with VBA

Question

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 the mailitems to an archive folder in Outlook (Inbox\archive).

I set up a rule that moves mail to an archive folder and runs a script.

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

A rule error pop-ups occasionally and I struggle to track down the reason. Hence looking to turn away from the rule and cycling through all folder contents "on-demand".

How could I cycle through the Outlook folder as well as displace the mail item?

Running Outlook 2019.

The target folder is in another mailbox (Office 365 shared mailbox).

Answer 1

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)