Outlookマクロで迷惑メール、スパムメール、フィッシングメールの一括削除 | エクセルマクロ(VBA)実践蔵(じっせんぐら)

トップ項目一覧

メールアドレスをネットに載せているので、毎日迷惑メールが届きます。

拒否するメールアドレスに設定しても、どんどんメールアドレスが変わるため、送信者名や件名をマクロでチェックするようにしてみました。

送信者名と件名を取得し、ブラックリストに登録した文言を含む場合は、削除します。

ブラックリストに入っている文言を使用したやりとりをする場合は、その言葉をブラックリストから除外してください。この記事の実行は、自己責任でお願いします。

あくまで、このメールアドレスには、本家のクレジット会社やAmazonからは通知がこない前提になります。

更新!　2025/3/14 ホワイトリストチェック機能を追加しました。ホワイトリストの言葉を含む場合、ブラックリストのチェックを行いません。また、処理の軽量化を行いました。

OutLookの開発タブを開き、VBAの画面を開くと、「ThisOutlookSession」に記述できます。開発タブが無い場合は、[ファイル]->[オプション]->[リボンのユーザ設定]ダイアログを開き、右側メインタブ一覧から[開発]の前のチェックボックスにチェックをつけます。

受信ボックスを選択し、マクロから「Project1.選択フォルダから迷惑メール削除」を選択すると、受信ボックスを対象に、マクロが作業を行います。そのため、あらかじめ、削除対象フォルダを選んでください。メールが直接格納されているフォルダを選択してください。フォルダを辿ることはできません。

2025/3/14以降のコードの場合、下記に「リストの初期化」が増えます。リストの更新(コードの変更)を行った直後のみ実行してください。

ブラックリストには、送信者名欄や件名に「ヤマト運輸」「えきねっと」「American Express」等を語る偽メール(フィッシングメール)が入っていたら削除しています。

本物かどうかの判定は行っていません。管理人がネットに公開しているメールアドレスは、本家からはそもそもこないので。

本家から受け取りたい場合は、ホワイトリストへ追加してください。ホワイトリストは送信者名のみを確認し、登録した単語を含む場合に、ブラックリストチェックの対象外となります。

受信トレイで実行した場合は、削除済みフォルダに入り、削除済みフォルダで実行した場合は、完全削除になります。

ブラックリストの編集は、SetBlackList()関数にて変更してください。ホワイトリストの編集は、SetWhiteList()関数になります。リストの更新を行った場合にかぎり、マクロの実行から「リスト初期化」を呼び出してください。前回まで載せていたものは、処理の中で常に最新を取得していましたが、処理が重くなるため、「リストが空のときだけ取得」に変更しています。その影響で、リストを更新した(マクロを書き換えた)場合に限り、手動で「リスト初期化」を呼び出さなければ、書き換えたリストの内容が反映されません。(もしくは、アプリ再起動で反映されます。)

下記のコードは、あくまで例なので、ブラックリストやホワイトリストは必ず内容を確認して変更してください。ホワイトリストには、下記のコードでは、1件しか現在登録していませんが、列挙の書き方は、ブラックリストと同じです。

列挙途中の改行は「 _」(スペースとアンダーバー)で表します。

注意事項：ホワイトリストに""(空)を設定しないでください。すべてのメールがホワイトリストと一致して、ブラックリストチェックが作動しなくなります。登録したいメールアドレスがない場合、自メールアドレスを登録してください。

最後に、ホワイトリストに該当なし、かつ、ブラックリストに該当なしであっても、「本文なし、かつ、添付なし」のメールも削除対象として、削除しています。よくわからない、空メールがくるので。。。

 
Option Explicit 
 
Public P_BLACKLIST As Variant  '送り主用ブラックリスト 
Public P_WHITELIST As Variant  '送り主用ホワイトリスト 
 
Private Function SetBlackList() 
     
    'Static P_BLACKLIST As Variant 
    Dim cnt As Long 
     
    '送り主名ブラックリスト 
    P_BLACKLIST = Array("ヤマト運輸", "えきねっと", "American Express", _ 
    "東京電力", "イオンペイ", "Amazon", "三井住友", "SMBC", _ 
    "View Card", "マイレージ", "エポスカード", "Vpass", "イオン", _ 
    "カードサービス", "マイナポイント", "お荷物", "三菱ＵＦＪ銀行", "セゾンカード", _ 
    "Аmazon", "イオン銀行", "AEON", "GMO", "MyJCB", "e-Orico", "自動配信", "日本放送協会", _ 
    "VISA", "楽天", "Apple", "マスターカード", "自動メール", "NHK", "iCloud", "ANA", _ 
    "ヨドバシ", "Mastercard", "国税", "銀行", "ジャックス", "ユーネット", "オリコ", _ 
    "CARD", "ビューカード", "Express", "ライフカード", "UCカード", "支払い", "佐川急便", _ 
    "AUカード", "ネットバンク", "ETC", "Saison", "口座取引", "saison", "CUBIC", _ 
    "イオンカード", "ポイント交換", "アカウント情報", "税務署", "JRE", "JCB", "カード利用制限", _ 
    "TikTok", "tepco", "au PAY", "日本郵便", "ペイディ", "エキスプレスカード", "宅急便", _ 
    "メルカリ", "クレジットカード", "アプラス", "MUFGカード", "vpass", "PUBLIC", "DOCTYPE", _ 
    "ドコモ", "証券", "三菱ＵＦＪ会社", "アマゾン", "受け取れます", "メッセージＲ", "イープラス") 
     
    For cnt = 0 To UBound(P_BLACKLIST) 
        P_BLACKLIST(cnt) = FormatStr(P_BLACKLIST(cnt) & "") 
    Next cnt 
     
End Function 
 
Private Function SetWhiteList() 
    Dim cnt As Long 
   
    'ホワイトリスト作成 
    P_WHITELIST = Array("sakura.ne.jp") 
     
     
    For cnt = 0 To UBound(P_WHITELIST) 
        P_WHITELIST(cnt) = FormatStr(P_WHITELIST(cnt) & "") 
    Next cnt 
         
End Function 
 
Function ブラックリスト初期化() 
    P_BLACKLIST = Array("") 
    Call SetBlackList 
End Function 
 
Function ホワイトリスト初期化() 
    P_WHITELIST = Array("") 
    Call SetWhiteList 
End Function 
 
Sub リスト初期化() 
     
    Call ブラックリスト初期化 
    Call ホワイトリスト初期化 
     
End Sub 
 
Private Function SetChkBlackList() 
     
    If IsEmpty(P_BLACKLIST) Then 
        Call SetBlackList 
    ElseIf UBound(P_BLACKLIST) = 0 Then 
        Call SetBlackList 
    Else 
     
    End If 
     
End Function 
 
Private Function SetChkWhiteList() 
     
    If IsEmpty(P_WHITELIST) Then 
        Call SetWhiteList 
    ElseIf UBound(P_WHITELIST) = 0 Then 
        Call SetWhiteList 
    Else 
     
    End If 
     
End Function 
 
'フォーマット 
'空白、タブの削除、全角は半角に、大文字は小文字に統一する 
Private Function FormatStr(str As String) As String 
     
    '空白、タブの削除 
    str = Replace(str, " ", "") 
    str = Replace(str, "　", "") 
    str = Replace(str, vbTab, "") 
     
    '大文字は小文字 
    str = LCase(str) 
    '全角は半角に 
    str = StrConv(str, vbNarrow) 
     
    FormatStr = str 
     
End Function 
 
'ホワイトリストにヒットするとTrueを返す 
'ヒットしなければFalseを返す 
Private Function ChkWhiteList(item As Outlook.MailItem) As Boolean 
 
    Dim chkName As String 
    Dim cnt As Long 
     
    '戻り値の初期化 
    ChkWhiteList = False 
     
    '送信者名の取得 
    chkName = item.SenderName 
     
    'フォーマット 
    chkName = FormatStr(chkName) 
     
    For cnt = 0 To UBound(P_WHITELIST) 
     
        'リストをフォーマット 
        'P_WHITELIST(cnt) = FormatStr(P_WHITELIST(cnt) & "") 
         
        'メールと比較 
        If InStr(1, chkName, P_WHITELIST(cnt)) > 0 Then 
             
            ChkWhiteList = True 
            Exit Function 
             
        End If 
     
    Next cnt 
     
End Function 
 
Private Function ChkBlackList(item As Outlook.MailItem) As Boolean 
     
    Dim chkName As String 
    Dim chkSub As String 
    Dim cnt As Long 
     
    '戻り値の初期化 
    ChkBlackList = True 
     
    '送信者名の取得 
    chkName = item.SenderName 
     
    'フォーマット 
    chkName = FormatStr(chkName) 
     
    '件名の取得 
    chkSub = item.Subject 
     
    'フォーマット 
    chkSub = FormatStr(chkSub) 
        
    For cnt = 0 To UBound(P_BLACKLIST) 
         
        'リストをフォーマット 
        'P_BLACKLIST(cnt) = FormatStr(P_BLACKLIST(cnt) & "") 
         
        'メールと比較 
        If InStr(1, chkName, P_BLACKLIST(cnt)) > 0 Then 
            '戻り値にFalseをセット 
            ChkBlackList = False 
            Exit Function 
             
        End If 
     
        '件名もチェック 
        If InStr(1, chkSub, P_BLACKLIST(cnt)) > 0 Then 
            '戻り値にFalseをセット 
            ChkBlackList = False 
            Exit Function 
             
        End If 
         
    Next cnt 
     
End Function 
 
Sub 選択フォルダから迷惑メール削除() 
     
    Dim WorkFolder As Outlook.MAPIFolder 
    Dim i As Long 
    Dim chkMail As Outlook.MailItem 
    Dim result As Boolean 
     
    'ブラックリストの確認(初回なら作成、作成済みなら何もしない) 
    'Call SetBlackList 
    Call SetChkBlackList 
    'ホワイトリストの作成(初回なら作成、作成済みなら何もしない) 
    'Call SetWhiteList 
    Call SetChkWhiteList 
     
     
    '選択中のフォルダ情報を取得 
    Set WorkFolder = ActiveExplorer().CurrentFolder 
     
    For i = WorkFolder.Items.Count To 1 Step -1 
 
        If ChkWhiteList(WorkFolder.Items(i)) = False Then 
        'ホワイトリストと一致するなら、ブラックリストはチェックしない 
         
            'フォルダ内メールをチェック 
            result = ChkBlackList(WorkFolder.Items(i)) 
             
            'リストにかかったメールを削除 
            If result = False Then 
            	’2025/3/18 訂正 
                WorkFolder.Items(i).Delete 
            Else 
                '謎の空メールも消したい！ 
                Set chkMail = WorkFolder.Items(i) 
                If chkMail.Body = "" And chkMail.Attachments.Count = 0 Then 
                    chkMail.Delete 
                End If 
            End If 
         
        End If 
         
    Next i 
 
End Sub 
 

手動でフォルダを選択して、該当フォルダのメールを削除する場合は、上記までのマクロで問題ありません。

動作に問題ない場合、下記を追記すると、新たに受信したメールを対象として、ホワイトリストチェックやブラックリストチェック、空メールの確認が実行され、該当メールは、削除済みフォルダに入ります。

 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String) 
 
    Dim objId As Object 
    Dim RcvMail As Outlook.MailItem 
    Dim Nspace As Outlook.NameSpace 
    Dim result As Boolean 
     
    Set Nspace = GetNamespace("MAPI") 
    Set RcvMail = Nspace.GetItemFromID(EntryIDCollection) 
     
    'ホワイトリストの作成(初回なら作成、作成済みなら何もしない) 
    'Call SetWhileList 
    Call SetChkWhiteList 
     
    'ブラックリストの作成(初回なら作成、作成済みなら何もしない) 
    'Call SetBlackList 
    Call SetChkBlackList 
     
    If ChkWhiteList(RcvMail) = False Then 
    'ホワイトリストと一致するなら、ブラックリストはチェックしない 
             
        'メールチェック関数の呼び出し 
        result = ChkBlackList(RcvMail) 
         
        'リストにかかったメールを削除 
        If result = False Then 
            RcvMail.Delete 
        Else 
            '空メールも消したい！ 
            If RcvMail.Body = "" And RcvMail.Attachments.Count = 0 Then 
                RcvMail.Delete 
            End If 
         
        End If 
         
    End If 
     
End Sub