件名・本文無しの迷惑メール対策

左下の「オプション」をクリック
「リボンのユーザー設定」をクリックし、画面右にあるメインタブの「開発」をクリックしチェックを入れる
「OK」をクリックすれば完了です

２．

Private WithEvents inboxItems As Items
Private WithEvents sentItems As Items

Private Sub Application_Startup()
    ' Outlookが起動したときに呼び出される
    Dim outlookApp As Object
    Dim accounts As Object
    Dim account As Object

    Set outlookApp = Outlook.Application
    Set accounts = outlookApp.Session.Accounts

    ' 各アカウントの受信トレイに対して処理を実行
    For Each account In accounts
        ' アカウントごとに受信トレイのフォルダIDを取得
        Dim inboxFolderId As String
        inboxFolderId = GetInboxFolderId(account)

        ' フォルダIDが取得できた場合のみ処理を実行
        If inboxFolderId <> "" Then
         ProcessFolders outlookApp.Session.GetFolderFromID(inboxFolderId)
        End If
    Next account

    ' 送信トレイのアイテムに対して処理を実行
    Set sentItems = outlookApp.Session.GetDefaultFolder(5).Items
    ' 5は送信トレイのフォルダID
    ProcessExistingItems sentItems
End Sub

Private Function GetInboxFolderId(ByVal account As Object) As String
    ' アカウントに対応する受信トレイのフォルダIDを取得する関数
    On Error Resume Next
    Dim inboxFolder As Object
    Set inboxFolder = account.DeliveryStore.GetDefaultFolder(6)
    ' 6は受信トレイのフォルダID
    On Error GoTo 0

    If Not inboxFolder Is Nothing Then
        GetInboxFolderId = inboxFolder.EntryID
    Else
        GetInboxFolderId = ""
    End If
End Function

Private Sub inboxItems_ItemAdd(ByVal Item As Object)
    ' 新しいアイテムが受信トレイに追加されたときに呼び出される
    ProcessItem Item
End Sub

Private Sub sentItems_ItemAdd(ByVal Item As Object)
    ' 新しいアイテムが送信トレイに追加されたときに呼び出される
    ProcessSentItem Item
End Sub

Private Sub ProcessFolders(ByVal parentFolder As Object)
    ' フォルダ内のメールに対して処理を実行
    Dim items As Items
    Set items = parentFolder.Items
    items.Sort "[ReceivedTime]", True ' 日付を降順にソート

    ProcessExistingItems items

    ' サブフォルダが存在する場合は、そのサブフォルダに対して再帰的に処理を実行
    Dim subfolder As Object
    For Each subfolder In parentFolder.Folders
        ' サブフォルダ内に1週間以内のメールが存在しない場合はスキップ
        If HasRecentMail(subfolder) Then
            ProcessFolders subfolder
        End If
    Next subfolder
End Sub

Private Function HasRecentMail(ByVal folder As Object) As Boolean
    ' フォルダ内に1週間以内のメールが存在するかどうかを確認する関数
    Dim items As Items
    Set items = folder.Items
    items.Sort "[ReceivedTime]", True ' 日付を降順にソート

    Dim oldestDate As Date
    oldestDate = DateValue(Now - 7) ' 一週間以前の日付

    On Error Resume Next
 HasRecentMail = (items.Count > 0) And (items(1).ReceivedTime >= oldestDate)
    On Error GoTo 0
End Function

Private Sub ProcessExistingItems(ByVal items As Items)
    ' 既に受信済みのメールに対して処理を実行
    Dim item As Object
    Dim oldestDate As Date
    oldestDate = Now - 7 ' 一週間以前の日付

    On Error Resume Next
    For Each item In items
        ' メールの日付が一週間以上前であれば処理を中断
        If item.ReceivedTime <= oldestDate Then
            Exit For
        End If

        ' メールのタイトルと本文が空であるかどうかを確認して処理を実行
        If Len(item.Subject) = 0 And Len(item.Body) = 0 Then
            Debug.Print "Processing item with no subject: " & item.Subject

            ' メールを既読にする
            item.UnRead = False

            ' メールを削除済みアイテムフォルダに移動する
            On Error Resume Next
      item.Move Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(3)
            ' 3は削除済みアイテムフォルダのフォルダID
            If Err.Number <> 0 Then
                Debug.Print "Error moving item: " & Err.Description
            End If
            On Error GoTo 0
        End If
    Next item
    On Error GoTo 0
End Sub

Private Sub ProcessItem(ByVal Item As Object)
    ' 受信したメールの日付が一週間以上で、かつ件名が空である場合
    If Len(Item.Subject) = 0 Then
        ' メールを既読にする
        Item.UnRead = False
        ' メールを次のフォルダに移動する（ここでは"処理済み"フォルダに移動）
     Item.Move Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(4)
        ' 4は処理済みフォルダのフォルダID
    End If
End Sub

Private Sub ProcessSentItem(ByVal Item As Object)
    ' 送信トレイのメールに対して処理を実行
    If Len(Item.Subject) = 0 Then
        ' メールを削除する
        Item.Delete
    End If
End Sub

SELFCERTの実行

スタートメニューの「ピン留め済み」または「すべてのアプリ」を表示させ「Outlook」を右クリック
表示されたメニューの「詳細」（ピン留め済みの場合は出ません）から「ファイルの場所を開く」をクリック

Outlookのショートカットアイコンが表示されたら、アイコンをキーボードの「Shift」キーを押しながら右クリック

表示されたメニューの「ファイルの場所を開く」をクリック

２．

VBAへデジタル署名の登録

「VBAコードの追加」の要領でVBAの画面を表示させます
メニューの「ツール」から「デジタル署名」をクリックします
「選択」ボタンをクリックし、デジタル証明書の作成で作った証明書を選択します

このように表示されれば「OK」で閉じます

証明書が表示されない場合は、証明書の作成がうまくできていないと思いますので、再度作成をしてください

３．

VBAの手動保存

証明書の登録が完了したら、必ず行ってください
メニューの「ファイル」から「VbaProject.OTMの上書き保存」をクリックし、手動で保存します
保存できたらVBAの画面は閉じてOKです
閉じるときに保存を聞いてきた場合、保存をしてください

「マクロの設定」を選択し、上から2番目の「デジタル署名されたマクロに対して・・・云々」がマークされているのを確認し、「OK」で閉じます
（違う項目が選択されていたら変更してください）

ここまでできたら一旦、Outlookを終了させます

再度Outlookを起動すると警告が表示されます
「ThisOutlookSession」と表示されているのを確認し、左の「この発行者のドキュメントをすべて信頼する」をクリックします
数秒の迷惑メールの処理後、Outlookが起動します
警告は「この発行者のドキュメントをすべて信頼する」を選択すれば最初の1回だけ聞いてきます
「マクロを有効にする」を間違ってクリックした場合は、一旦Outlookを閉じて再度起動時に「この発行者のドキュメントをすべて信頼する」を選択してください

本ツールの内容
◆チェック・判断の条件
１．タイトルと本文が空であること（タイトルだけ無しにする方もいますので、両方が空であること）
２．Outlook起動時と受信済み（1週間以内）のメールも対象にする
３．複数のメールアカウントに対応
４．受信フォルダ以下のサブフォルダ（複数階層）もチェックする

◆処理内容
１．該当したメールは「既読」にし、「削除済みアイテム」フォルダに移動する
２．念のために受信フォルダの該当メールの削除処理をする
３．テスト段階で該当メールが送信フォルダに移動していたことがあったため、送信フォルダの該当メールも削除する
※即削除でもいいのですが、必要なメールだったということもあるかもしれないと思い、削除済みアイテムに移動させています

◆問題点
複数アカウントの場合、該当メールは1番目のアカウントの「削除済みアイテム」フォルダに移動しています
アカウント毎のフォルダに移動させようとしましたが、うまくいかなかったのと別に問題はないと判断したのでそのままにしています