迷惑メールに保存されているメールの差出人を受信拒否リストに追加するマクロ

コメントで以下のようなご要望をいただきました。

---

迷惑メールフォルダ内にたまったメールを手動にて「受信拒否リストに追加」して
おります。この操作をマクロにて実現可能でしょうか？

---

以下のようなマクロで可能です。なお、このマクロを実行した後、Outlook を再起動すると受信者拒否リストに追加されます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub AddSpammerToList()
    Const BLOCK_SENDERS_LIST = "c:\temp\blocksenders.txt"
    Const OFFICE_KEY = "HKCU\Software\Microsoft\Office\"
    Const OPTIONS_KEY = ".0\Outlook\Options\Mail\"
    Dim strOptionKey As String
    Dim fldSpam As Folder
    Dim objMail 'As MailItem
    Dim strSenders As String
    Dim objFSO
    Dim stmList
    ' 拒否リストを作成
    strSenders = ""
    Set fldSpam = Session.GetDefaultFolder(olFolderJunk)
    For Each objMail In fldSpam.Items
        If TypeName(objMail) = "MailItem" Then
            If InStr(strSenders, objMail.SenderEmailAddress) = 0 And _
               InStr(objMail.SenderEmailAddress, "@") > 0 Then
                strSenders = strSenders & objMail.SenderEmailAddress & vbCrLf
            End If
        End If
    Next
    ' 拒否リストをファイルに書き込み
    Open BLOCK_SENDERS_LIST For Output As #1
    Print #1, strSenders
    Close #1
    ' レジストリで拒否リストの読み込みを指定
    Set WshShell = CreateObject("WScript.Shell")
    strOptionKey = OFFICE_KEY & Left(Application.Version, 2) & OPTIONS_KEY
    WshShell.RegWrite strOptionKey & "JunkMailBlockedSendersFile", BLOCK_SENDERS_LIST, "REG_SZ"
    WshShell.RegWrite strOptionKey & "JunkMailImportLists", 1, "REG_DWORD"
    WshShell.RegWrite strOptionKey & "JunkMailImportAppend", 1, "REG_DWORD"
End Sub

マクロの登録方法やメニューへの追加について

広告