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

トップ項目一覧

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

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

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

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

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

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

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

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

本来は、ほんものかどうかのチェックを行うことが正しいのかもしれませんが、取り急ぎ、本家本物からはこない前提ですのでご注意ください。

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

ブラックリストの編集は、SetBlackList()関数にて変更してください。

 
Public P_BLACKLIST As Variant  '送り主用ブラックリスト 
 
Private Function SetBlackList() 
     
    '送り主名ブラックリスト 
    P_BLACKLIST = Array("ヤマト運輸", "えきねっと", "American Express", _ 
    "東京電力", "イオンペイ", "Amazon", "三井住友", "SMBC", _ 
    "View Card", "マイレージ", "エポスカード", "Vpass") 
 
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 
 

 
'引数のメールをチェックする関数 
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 
            Call item.Delete 
            '戻り値にFalseをセット 
            chkBlackList = False 
            Exit Function 
             
        End If 
     
        '件名もチェック 
        If InStr(1, chkSub, P_BLACKLIST(cnt)) > 0 Then 
            Call item.Delete 
            '戻り値にFalseをセット 
            chkBlackList = False 
            Exit Function 
             
        End If 
         
    Next cnt 
     
End Function 
 

下記が実行するマクロになります。上の記述部分は、下記から呼び出されます。

 
Sub 選択フォルダから迷惑メール削除() 
     
    Dim WorkFolder As Outlook.MAPIFolder 
    Dim i As Long     
     
    'ブラックリストの作成 
    Call SetBlackList 
     
    '選択中のフォルダ情報を取得 
    Set WorkFolder = ActiveExplorer().CurrentFolder 
     
    For i = WorkFolder.Items.Count To 1 Step -1 
        'フォルダ内メールをチェック 
        Call chkBlackList(WorkFolder.Items(i)) 
         
    Next i 
 
End Sub 

メールの受信タイミングで自動チェック

メールの受信タイミングで自動チェックさせたい場合は、下記のコードになります。

下記は、自動実行のため、手動によるマクロの実行は不要です。

上に記載している関数、SetBlackListとchkBlackListを呼び出します。

 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String) 
 
    Dim objId As Object 
    Dim RcvMail As Outlook.MailItem 
    Dim Nspace As Outlook.NameSpace 
     
    Set Nspace = GetNamespace("MAPI") 
    Set RcvMail = Nspace.GetItemFromID(EntryIDCollection) 
     
    'ブラックリストの作成 
    Call SetBlackList 
    'メールチェック関数の呼び出し 
    Call chkBlackList(RcvMail) 
     
End Sub 

ブラックリストの作成を毎回行うのは無駄かなと、配列サイズが0なら設定に行くようにコードを一度書いたのですが、途中でリストの更新が行われた場合に、初期化を入れないと反映させられなかったので、毎回リスト作成することにしました。