Microsoft Outlook（アウトルック）をお使いで、「差出人」や「件名」が空白（空欄）のメールが受信トレイに紛れ込み、その処理に手間がかかっている、ということはありませんか？ 迷惑メールフィルターをすり抜けたり、通常の仕分けルールでは対応しきれなかったりして、手動での削除が面倒だと感じている方もいらっしゃるかもしれません。
Option Explicit
' --- 設定項目 ---
' 迷惑メール判定の条件: True = 件名か差出人のどちらか一方が空白なら削除 (リスク高)
' False = 件名と差出人の両方が空白の場合のみ削除 (より安全)
Const DELETE_IF_EITHER_IS_BLANK As Boolean = True ' ★True(または) / False(かつ) を選択
' 移動先フォルダ: 通常は「削除済みアイテム」でOK
Const TARGET_FOLDER As Integer = 3 ' olFolderDeletedItems (削除済みアイテム)
' 参考: olFolderJunk = 23 (迷惑メールフォルダ)
' --- 設定ここまで ---
' 新着メールイベント処理 (メール受信時に自動実行される)
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Const olMail As Integer = 43 ' メールアイテムの識別番号
' 変数の宣言
Dim arrEntryIDs As Variant ' 受信メールIDの配列
Dim objMail As Object ' メールアイテム用オブジェクト
Dim targetFolderObject As Outlook.MAPIFolder ' 移動先フォルダ用オブジェクト
Dim ns As Outlook.NameSpace ' Outlook名前空間用オブジェクト
Dim i As Long ' ループカウンター
Dim subjectIsEmpty As Boolean ' 件名が空白かのフラグ
Dim senderIsEmpty As Boolean ' 差出人が空白かのフラグ
Dim deleteThisMail As Boolean ' 削除対象かのフラグ
On Error GoTo GeneralError ' マクロ全体で予期せぬエラーが起きた場合の飛び先
' Outlookの基本的な機能へアクセスするための準備
Set ns = Application.GetNamespace("MAPI")
' 設定された番号に基づいて移動先フォルダを取得
On Error Resume Next ' 特定フォルダが存在しない等のエラーを一旦無視
Set targetFolderObject = ns.GetDefaultFolder(TARGET_FOLDER)
On Error GoTo 0 ' エラー処理を通常に戻す
' 移動先フォルダが見つからなかった場合 (通常は起こり得ないが念のため)
If targetFolderObject Is Nothing Then
Debug.Print Now & ": 移動先フォルダ (番号 " & TARGET_FOLDER & ") が見つかりません。処理を中断します。"
GoTo Cleanup ' 後処理にジャンプして終了
End If
' 受信したメールのIDを分割して配列に入れる (複数メール同時受信対応)
arrEntryIDs = Split(EntryIDCollection, ",")
' --- 受信したメールを一件ずつチェックするループ ---
For i = LBound(arrEntryIDs) To UBound(arrEntryIDs)
Set objMail = Nothing ' 前のループのオブジェクトをクリア
' メールIDからメールアイテムを取得 (失敗してもエラーで止めずに次へ)
On Error Resume Next
Set objMail = ns.GetItemFromID(arrEntryIDs(i))
On Error GoTo 0 ' エラー処理を通常に戻す
' メールアイテムが正しく取得できた場合のみ、以下の処理を実行
If Not objMail Is Nothing Then
' アイテムの種類が「メール」であるかを確認
If objMail.Class = olMail Then
' 件名と差出人が空白かどうかをチェック (Trimで前後のスペースを除去)
subjectIsEmpty = (Trim(objMail.Subject) = "")
senderIsEmpty = (Trim(objMail.SenderName) = "") ' SenderNameで判定
' --- 削除条件の判定 ---
deleteThisMail = False ' まず削除しないとして初期化
If DELETE_IF_EITHER_IS_BLANK Then ' もし「どちらか空白で削除(True)」設定なら
If subjectIsEmpty Or senderIsEmpty Then deleteThisMail = True
Else ' もし「両方空白で削除(False)」設定なら
If subjectIsEmpty And senderIsEmpty Then deleteThisMail = True
End If
' --- 判定ここまで ---
' 削除条件に合致した場合、メールを指定フォルダへ移動
If deleteThisMail Then
On Error Resume Next ' 移動時のエラー(例:アイテムがロックされている等)は無視
objMail.Move targetFolderObject
If Err.Number <> 0 Then ' 移動でエラーが発生した場合、イミディエイトウィンドウに記録を残す
Debug.Print Now & ": メール移動エラー: " & Err.Description & " (件名: '" & objMail.Subject & "', 差出人: '" & objMail.SenderName & "')"
Err.Clear
End If
On Error GoTo 0 ' エラー処理を通常に戻す
End If
End If
Else
' メール取得自体に失敗した場合の記録 (Debug.Print)
Debug.Print Now & ": メール取得エラー (EntryID: " & arrEntryIDs(i) & ")"
End If
'ContinueLoop: ' エラー時のジャンプ先として使用していたが、ループのNextで自然に継続するため必須ではない
Next i
' --- ループ終了 ---
' 後処理: 使用したオブジェクト変数をメモリから解放 (定型処理)
Cleanup:
Set objMail = Nothing
Set targetFolderObject = Nothing
Set ns = Nothing
Exit Sub ' サブルーチンを終了
' 一般エラーハンドラ: ループ中以外での予期せぬエラー発生時の処理
GeneralError:
Debug.Print Now & ": マクロ実行中に予期せぬエラー発生: " & Err.Description & " (Error No: " & Err.Number & ")"
Err.Clear ' エラー情報をクリア
Resume Cleanup ' エラー発生時も必ず後処理を実行して終了する
End Sub
コメント