Excel VBAを用いたOutlookメールの自動アーカイブ処理

この記事では、Excel VBAを用いて30日以上古いメールを「アーカイブ」フォルダに自動移動する処理方法について詳しくご紹介します。初心者向けに基本的なコードから、さらなる応用例までを解説していきます。この記事を通じて、日々増え続けるメールの整理をVBAの力を借りて行うことができるようになります。

基本コードの紹介

Sub ArchiveOldEmails()
    Dim OutlookApp As Object
    Dim Inbox As Object
    Dim ArchiveFolder As Object
    Dim Email As Object
    Dim i As Integer
    Set OutlookApp = CreateObject("Outlook.Application")
    Set Inbox = OutlookApp.GetNamespace("MAPI").GetDefaultFolder(6)
    Set ArchiveFolder = Inbox.Folders("アーカイブ")
    For i = Inbox.Items.Count To 1 Step -1
        Set Email = Inbox.Items(i)
        If Email.ReceivedTime <= Date - 30 Then
            Email.Move ArchiveFolder
        End If
    Next i
End Sub

コードの詳細解説

1. `Outlook.Application`オブジェクトを作成して、Outlookの操作を可能にします。
2. メインの受信箱（Inbox）とアーカイブフォルダ（ArchiveFolder）を取得します。
3. `For`ループを使って、受信箱の各メールを調査します。
4. メールの受信日が現在の日付から30日以上前であれば、メールをアーカイブフォルダに移動します。

応用例

1.特定の差出人のメールだけをアーカイブ

メールの整理を行う際、特定の差出人からのメールだけをアーカイブに移動したいケースも考えられます。以下はそのためのコード例です。

Sub ArchiveEmailsFromSender()
    Dim OutlookApp As Object
    Dim Inbox As Object
    Dim ArchiveFolder As Object
    Dim Email As Object
    Dim i As Integer
    Dim TargetSender As String
    TargetSender = "sender@example.com"
    Set OutlookApp = CreateObject("Outlook.Application")
    Set Inbox = OutlookApp.GetNamespace("MAPI").GetDefaultFolder(6)
    Set ArchiveFolder = Inbox.Folders("アーカイブ")
    For i = Inbox.Items.Count To 1 Step -1
        Set Email = Inbox.Items(i)
        If Email.ReceivedTime <= Date - 30 And Email.SenderEmailAddress = TargetSender Then
            Email.Move ArchiveFolder
        End If
    Next i
End Sub

2.特定のキーワードを含むメールをアーカイブ

特定のキーワードが含まれるメールだけをアーカイブに移動したい場合のコード例です。

Sub ArchiveEmailsByKeyword()
    Dim OutlookApp As Object
    Dim Inbox As Object
    Dim ArchiveFolder As Object
    Dim Email As Object
    Dim i As Integer
    Dim TargetKeyword As String
    TargetKeyword = "プロジェクトX"
    Set OutlookApp = CreateObject("Outlook.Application")
    Set Inbox = OutlookApp.GetNamespace("MAPI").GetDefaultFolder(6)
    Set ArchiveFolder = Inbox.Folders("アーカイブ")
    For i = Inbox.Items.Count To 1 Step -1
        Set Email = Inbox.Items(i)
        If Email.ReceivedTime <= Date - 30 And InStr(1, Email.Body, TargetKeyword, 1) > 0 Then
            Email.Move ArchiveFolder
        End If
    Next i
End Sub

3.アーカイブするフォルダを動的に選択

以下のコードでは、アーカイブする先のフォルダを動的に選択することができます。

Sub ArchiveToDynamicFolder()
    Dim OutlookApp As Object
    Dim Inbox As Object
    Dim ArchiveFolder As Object
    Dim Email As Object
    Dim i As Integer
    Dim FolderPath As String
    FolderPath = InputBox("アーカイブするフォルダのパスを入力してください（例：受信箱\アーカイブ）")
    Set OutlookApp = CreateObject("Outlook.Application")
    Set Inbox = OutlookApp.GetNamespace("MAPI").GetDefaultFolder(6)
    Set ArchiveFolder = OutlookApp.GetNamespace("MAPI").GetFolderFromID(FolderPath)
    For i = Inbox.Items.Count To 1 Step -1
        Set Email = Inbox.Items(i)
        If Email.ReceivedTime <= Date - 30 Then
            Email.Move ArchiveFolder
        End If
    Next i
End Sub

まとめ

Excel VBAを使用することで、Outlookのメール整理作業を自動化することができます。基本的なコードから、より具体的な応用例までを試してみて、日々の業務を効率化しましょう。