Outlookでメールアイテムを移動するVBAマクロ

GmailではIMAPフォルダーとしてラベルが使われています。IMAPフォルダーを削除してもラベルがなくなるだけでメールアイテム自体は消えません。
ですがOffice 365はIMAPフォルダーそのものなので、削除すると中のメールアイテムも消えてしまいます。
Gmailのような処理にしたければ、IMAPフォルダーを削除する前にメールアイテムを移動してやる必要がありますが手作業では面倒です。
そこでOutlookクライアントで一括でメールアーカイブするためのVBAマクロを作ってみました。

以下はInboxからArchiveフォルダにメールアイテムを移動するようになっていますが、mySrcFolderとmyDstFolderで移動元/移動先フォルダーを変更できます。

Sub ArchiveItems()

    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.Folder
    Dim myDstFolder As Outlook.Folder
    Dim mySrcFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myItem As Object

    Set myNameSpace = Application.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myDstFolder = myInbox.Parent.Folders("Archive")
    Set mySrcFolder = myInbox
    Set myItems = mySrcFolder.Items

    For Each myItem In myItems
        myItem.Move myDstFolder
    Next
    
    MsgBox "Complete!"

End Sub

おまけで現在操作中のフォルダー名を表示するマクロ。

Sub DisplayCurrentFolderName()

    Dim myExplorer As Outlook.Explorer
    Dim myFolder As Outlook.Folder

    Set myExplorer = Application.ActiveExplorer
    Set myFolder = myExplorer.CurrentFolder

    MsgBox myFolder.Name

End Sub