Outlook で特定の添付ファイルに基づいてメールを自動的にフラグ付けするには、どうすればよいですか？

特定の重要な添付ファイルが含まれるメールを受信した際に、あらかじめフラグを付けておけば、後で迅速かつ簡単にフォローアップできます。本記事では、指定した名前の添付ファイルを持つメールを自動的にフラグ付けする簡単な方法をご紹介します。

VBA コードを使用して、特定の添付ファイルに基づきメールを自動フラグ付けする

---

VBA コードを使用して、特定の添付ファイルに基づきメールを自動フラグ付けする

特定の添付ファイルを含むメールを自動でフラグ付けするには、以下の VBA コードを適用してください。

1．Outlook を起動し、「Alt + F11」キーを押して「Microsoft Visual Basic for Applications」ウィンドウを開きます。

2．「Microsoft Visual Basic for Applications」ウィンドウで、「Project1 (VbaProject.OTM)」ペインにある「ThisOutlookSession」をダブルクリックしてモジュールを開き、次のコードを表示された空のモジュールにコピー＆ペーストしてください。

VBA コード：特定の添付ファイルに基づいてメールを自動フラグ付けする：

Public WithEvents GMailItems As Outlook.Items
Private Sub Application_Startup()
    Set GMailItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub GMailItems_ItemAdd(ByVal Item As Object)
    If Item.Class <> olMail Then Exit Sub
    FlagEmail_SpecificAttachments Item
End Sub

Sub FlagEmail_SpecificAttachments(Mail As Outlook.MailItem)
    Dim xAttachment As Outlook.Attachment
    Dim xExt As String
    Dim xFileName As String
    If Mail.Attachments.Count = 0 Then Exit Sub
    For Each xAttachment In Mail.Attachments
        xExt = SplitPath(xAttachment.FileName, 2)
        xFileName = SplitPath(xAttachment.FileName, 1)
        Select Case xExt
            Case "txt", "xlsx", "docx", "pdf"
                If InStr(LCase(xFileName), LCase("KTO")) > 0 Then
                    With Mail
                        .ReminderSet = True
                        .ReminderTime = Now + 1
                        .MarkAsTask olMarkTomorrow
                        .Save
                    End With
                End If
        End Select
    Next
End Sub

Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim xSplitPos As Integer, xDotPos As Integer
xSplitPos = InStrRev(FullPath, "/")
xDotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
    Case 0
        SplitPath = Left(FullPath, xSplitPos - 1)
    Case 1
        If xDotPos = 0 Then xDotPos = Len(FullPath) + 1
        SplitPath = Mid(FullPath, xSplitPos + 1, xDotPos - xSplitPos - 1)
    Case 2
        If xDotPos = 0 Then xDotPos = Len(FullPath)
        SplitPath = Mid(FullPath, xDotPos + 1)
    Case Else
    Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function

注：上記コードでは、必要に応じてファイル拡張子や添付ファイル名を変更できます。

3．次にコードを保存し、Outlook を再起動してコードを有効化してください。これにより、指定したテキストを含む名前の添付ファイルが届いたメールを受信した際、Outlook が自動的にそのメールにフォローアップ用のフラグを付けます（下記スクリーンショット参照）。