ExcelVBAでOutlookからメール受信 ２

はじめに

　前回はOutlookの「受信トレイ」（フォルダー）や、そのサブフォルダー（「受信アーカイブ」）にアクセスする方法を紹介しました。
　今回は、「受信トレイ」から「受信アーカイブ」にメールを移動する方法と、メールを削除する方法を見ていきましょう。

　Outlookのフォルダー構成は以下の様になっています。
　「受信トレイ」下に「受信アーカイブ」というサブフォルダーを作っていない方は作っておいてください。

メールの移動

　Outlook内のフォルダー間でメールを移動するには、移動元と移動先のフォルダーを取得しておきます。
　個々のメールはフォルダー内の Items配列に入っていますので、インデックス番号で指定してMoveメソッドで移動させます。

Sub moveMailTest1()
    Dim myNamespace As Outlook.Namespace
    Set myNamespace = Outlook.Application.GetNamespace("MAPI")
    
    Dim inFolder As Outlook.Folder
    Dim arcFolder As Outlook.Folder
    
    '受信トレイ
    Set inFolder = myNamespace.GetDefaultFolder(olFolderInbox)
    
    '受信トレイ下の受信アーカイブ
    Set arcFolder = myNamespace.GetDefaultFolder(olFolderInbox).Folders("受信アーカイブ")
    
    Dim num As Long
    num = inFolder.Items.Count  '受信トレイにあるメールの数を取得
    
    Dim i As Long
    Dim mItem As Outlook.MailItem
    
    '受信トレイのメール情報をワークシートに記録
    For i = 1 To num
        Set mItem = inFolder.Items(i)

        Cells(i, 1) = i
        Cells(i, 2) = mItem.ReceivedTime   '受信日時
        Cells(i, 3) = mItem.subject        '題名
        Cells(i, 4) = mItem.SenderName     '送信者名
        Cells(i, 5) = mItem.SenderEmailAddress     '送信メールアドレス
        Cells(i, 6) = Left(mItem.Body, 20)     '本文（先頭から20文字）
    Next

    '「受信アーカイブ」に移動
    inFolder.Items(1).Move arcFolder

End Sub

　このプログラムでは「受信トレイ」にあるメール一覧をワークシートに表示し、メールアイテム配列の一番目にあるメールを「受信アーカイブ」へ移動させています。
　実際に運用する際は、受信日で指定するなど、メールにある情報をもとに移動対象としていく事になるでしょう。
　
　大事なのは、複数のアイテムを移動する際は、繰返し処理を逆順にしなければいけない点です。
　これは、配列を移動するたびに配列の順番が変わるのを防ぐためです。

　以下のプログラムでは、ある日付より以前のメールを「受信アーカイブ」へ移動します。

Sub moveMailTest2()
    Dim myNamespace As Outlook.Namespace
    Set myNamespace = Outlook.Application.GetNamespace("MAPI")
    
    Dim inFolder As Outlook.Folder
    Dim arcFolder As Outlook.Folder
    
    '受信トレイ
    Set inFolder = myNamespace.GetDefaultFolder(olFolderInbox)
    
    '受信トレイ下の受信アーカイブ
    Set arcFolder = myNamespace.GetDefaultFolder(olFolderInbox).Folders("受信アーカイブ")
    
    Dim num As Long
    num = inFolder.Items.Count  '受信トレイにあるメールの数を取得
    
    Dim i As Long
    Dim mItem As Outlook.MailItem
    Dim myDate As Date
    myDate = #1/1/2023#
    
    '「受信アーカイブ」に移動
    For i = num To 1 Step -1             '逆順
        Set mItem = inFolder.Items(i)
        If myDate > mItem.ReceivedTime Then   '日付以前を対象とする
            mItem.Move arcFolder
        End If
    Next i
    
End Sub

メールの削除

　メールを削除するには、メールアイテムのDeleteメソッドを使用します。
　Deleteメソッドは、アイテム（メール）を 「削除済みアイテム」フォルダーに移動します。
　「削除済みアイテム」フォルダーでアイテムを削除（Delete メソッド）した場合は完全に削除されます。

　つまり、メールを完全に削除する時は2段階の処理が必要になります。
　
　また、メールの移動と同じで、メールアイテムの削除は繰返し処理を逆順にして行う必要があります。
　
　以下のプログラムでは特定のキーワードを含むメールアイテムを「受信トレイ」で削除してみます。
　含むキーワードはメールの題名でもアドレスでも設定可能です。また完全一致で無くても削除対象に出来ますので、Outlookにはないフィルターをかける事ができます。
　
　今回は、メールアドレスにあるキーワードが含まれている場合に削除対象としてみましょう。
　キーワードは削除したいメールアドレスの特徴的な部分を選択します。
　残したいメールアドレスと被らないように注意してください。

Sub deleteMailTest1()
    Dim myNamespace As Outlook.Namespace
    Set myNamespace = Outlook.Application.GetNamespace("MAPI")
    
    Dim inFolder As Outlook.Folder
    Dim arcFolder As Outlook.Folder
    
    '受信トレイ
    Set inFolder = myNamespace.GetDefaultFolder(olFolderInbox)
    
    '受信トレイ下の受信アーカイブ
    Set arcFolder = myNamespace.GetDefaultFolder(olFolderInbox).Folders("受信アーカイブ")
    
    Dim num As Long
    num = inFolder.Items.Count  '受信トレイにあるメールの数を取得
    
    Dim i As Long, cnt As Long
    Dim mItem As Outlook.MailItem
    Dim keyStr As String
    
    keyStr = "ｘｘｘｘｘ@meiwaku"     '/// 削除したいメールアドレスのキーワードを設定 ///
    
    '「受信アーカイブ」から削除（「削除済みアイテム」に移動する）
    cnt = 0
    For i = num To 1 Step -1
        Set mItem = inFolder.Items(i)
        If InStr(mItem.SenderEmailAddress, keyStr) > 0 Then
            mItem.Delete
            cnt = cnt + 1
        End If
    Next i
    
    MsgBox cnt & "件のメッセージを削除しました。"
    
End Sub

「削除済みアイテム」フォルダ一覧

　削除されたか確認するには、「削除済みアイテム」を見ればわかります。
　「削除済みアイテム」フォルダの一覧は、GetDefaultFolderで olFolderDeletedItems を指定すれば「受信トレイ」と同じように取得できます。

　前のプログラムで削除されたメールは、「削除済みアイテム」フォルダ内にあるはずです。

Sub myDeleteItemist()
    Dim myNamespace As Outlook.Namespace
    Set myNamespace = Outlook.Application.GetNamespace("MAPI")
    
    Dim delFolder As Outlook.Folder
    
    '削除済みアイテム
    Set delFolder = myNamespace.GetDefaultFolder(olFolderDeletedItems)
    
    Dim i As Long
    Dim mItem As Outlook.MailItem
    
    Application.ScreenUpdating = False

    For i = 1 To delFolder.Items.Count
        Set mItem = delFolder.Items(i)

        Cells(i, 1) = i
        Cells(i, 2) = mItem.ReceivedTime   '受信日時
        Cells(i, 3) = mItem.subject        '題名
        Cells(i, 4) = mItem.SenderName     '送信者名
        Cells(i, 5) = mItem.SenderEmailAddress     '送信メールアドレス
        Cells(i, 6) = Left(mItem.Body, 20)     '本文（先頭から20文字）
    Next
    
    Application.ScreenUpdating = True
End Sub

まとめ

　今回は、メールの移動と削除について解説しました。
　これで、目的のフォルダーからメールを移動したり削除したり出来るようになりましたが、問題は、対象をどのように選別するかという事です。
　
　また、削除のプログラム（deleteMailTest1）のキーワードを複数にする事もできますが、対象のメール一覧 × キーワード数となりループ回数が増えればそれなりに処理する時間は増えていきます。
　対策としては、「受信トレイ」のメールを常に少なくなるように整理しておくと良いでしょう。