件名の先頭の [SPAM] を削除するマクロ

コメントにて以下のご要望をいただきました。


はじめまして bantian と申します。いつも質の高い情報の提供、ありがとうございます。

早速ですが [SPAM] に関する処理について質問させていただきます。

Outlook2013にて、件名の先頭に “[SPAM] “(””は除く)と言う文字列があるメールを受信した時、件名の先頭の “[SPAM] ” を自動的に削除するマクロをご教示願います。削除は先頭だけで構いません。 “[SPAM] ” が2つ以上ある場合でも先頭の1つだけの削除で構いません。

また、現在開いている Outlookのフォルダ内の全てのメールの件名から “[SPAM] ” と言う文字列を削除するマクロについてもご教示願います。こちらの場合は “[SPAM] ” が複数あればそれら全ての削除です。自動処理ではなく手動起動させたいと思います。

色々と書きましたが、よろしくお願い致します。


件名は Subject というプロパティに保存されていますが、先頭に特定の文字列がある場合という条件には Left 関数を使用します。
そして、先頭の文字列を削除するということは、削除する文字列の次の文字からの値を新たに設定するということになり、Mid 関数を使用します。
一方、特定の文字列が含まれている場合という条件には Instr 関数を使用し、特定の文字列をすべて削除する場合には Replace 関数を使用します。
これらをまとめると、以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objMail As Object
     ' 受信したメールを取得
     Set objMail = Session.GetItemFromID(EntryIDCollection)
     ' 件名の先頭が "[SPAM]" なら削除
     If Left(objMail.Subject, 6) = "[SPAM]" Then
         objMail.Subject = Mid(objMail.Subject, 7)
         objMail.Save
     End If
End Sub
'
Public Sub DeleteSpamPrefixInCurrentFolder()
     Dim objMail As Object
     ' 現在のフォルダーのアイテムすべてをチェック
     For Each objMail In ActiveExplorer.CurrentFolder.Items
         ' 件名に "[SPAM]" が含まれる場合はすべて削除
         If InStr(objMail.Subject, "[SPAM]") > 0 Then
             objMail.Subject = Replace(objMail.Subject, "[SPAM]", "")
             objMail.Save
         End If
     Next
End Sub

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

広告

Exchange 環境で受信したメールの差出人を連絡先の表示名に置き換えるマクロ

コメントにて以下のご要望をいただきました。


いつも勉強させていただいてます。
ありがとうございます。
受信したメールの差出人を連絡先
から検索するを使用していますが、
outlookを起動してない時に受信した
メールはvbaが反映されません。
対応可能でしょうか?
ぜひご教示いただければ幸いです。
よろしくお願いいたします。

連続ですいません。
過去のコメント等拝見して
exchangeの場合ルールに
スクリプトを追加するれば
良いとのことを理解したのですが、
どのマクロを登録したら
良いのでしょうか??


ルールでマクロを実行する場合、Public Sub プロシージャ名(ByRef メール変数 As MailItem) として処理を行うプロシージャを定義し、ルールのスクリプトを実行するアクションとして指定します。
ただし、2017 年 5 月以降にリリースされた修正プログラムを適用すると、スクリプトのアクションが新規に作成できなくなり、既存のものもエラーとなります。
そのため、これを回避するにはこちらの記事で紹介しているレジストリ設定を行う必要があります。
レジストリ設定を行った後、「連絡先をマクロで活用する」で紹介した「受信したメールの差出人を連絡先から検索する」マクロをルールで実行できるように書き換えると以下のようになります。
なお、FindContactByAddress 関数は前述の記事で紹介したものに含まれていますので、既に登録済みであれば RewriteSenderAction のみをコピーしてください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 差出人の名前を置き換えるサブプロシージャ
Public Sub RewriteSenderAction(ByRef objMail As MailItem)
     On Error Resume Next
     Dim objContact As ContactItem
     Dim strSenderAddress As String
     '
     strSenderAddress = objMail.SenderEmailAddress
     Set objContact = FindContactByAddress(strSenderAddress)
     If Not objContact Is Nothing Then
         objMail.SentOnBehalfOfName = objContact.FileAs
         objMail.Save
     End If
End Sub
' 差出人のアドレスで連絡先を検索する関数 (既に登録済みならコピー不要)
Private Function FindContactByAddress(strAddress As String)
     Dim objContacts 'As Folder
     Dim objContact As ContactItem
     '
     Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)
     Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
         & "' or [Email2Address] = '" & strAddress _
         & "' or [Email3Address] = '" & strAddress & "'")
     Set FindContactByAddress = objContact
End Function

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

一定時間内に同じ件名のメールを複数受信したらメールを送信するマクロ

コメントにて以下のご要望をいただきました。


はじめまして。
Windows10+Outlook2013で、一定時間内に同じ件名のメールを受信したら指定のメールアドレスに定型文のメールを送信したいのですが可能でしょうか?
例えば、10分間に同じ件名のメールを10件受信したら指定アドレスにメールを送る。10分間隔でメールをチェックする仕掛けになるイメージになるのでしょうか。


例えば、10分間に10件受信したかどうかという判断は、メールを受信した際にその時間の10分前以降に受信した同じ件名のメールの数をカウントして10件以上あれば、という条件に置き換えられると思います。
Items コレクションの Restriction メソッドで件名と受信日時によりフィルタリングし、その数が一定数を超えたらメールを送信するというロジックにすればご要望は実現できるでしょう。
このロジックの場合、11件目を受信した際にどうするかという問題があるのですが、これについては通知メールを送信したタイミングをフィルタリングの開始時刻にするという方法で、新たに10件受信した場合に通知するようにしています。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Dim g_strLastSent As String
'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objItem As Object ' MailItem
     '
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     '
     If objItem.MessageClass = "IPM.Note" Then
         FindSameSubject objItem.Subject
     End If
End Sub
'
Private Sub FindSameSubject(strSubject As String)
     Const NOTIFY_TO = "test@example.com"
     ' 通知メールの件名
     Const MAIL_SUBJECT = "メール通知"
     ' 通知メールの本文
     Const MAIL_BODY = "メールを 10 分以内に 10 件受信しました。"
     ' 監視する時間 (分単位)
     Const INTERVAL_MIN = 10
     ' 通知するメール数の閾値
     Const MAX_MAILS = 10
     Dim fldInbox As Folder
     Dim colInbox As Items
     Dim dtStart As Date
     Dim strStart As String
     ' 受信トレイを取得
     Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
     Set colInbox = fldInbox.Items
     ' 監視の開始時間を算出
     dtStart = DateAdd("n", -INTERVAL_MIN, Now)
     strStart = FormatDateTime(dtStart, vbShortDate) & " " & _
         FormatDateTime(dtStart, vbShortTime)
     ' 一度通知メールを送信したら、カウンタをクリアするための記述
     If g_strLastSent = "" Then
         g_strLastSent = strStart
     ElseIf g_strLastSent > strStart Then
         strStart = g_strLastSent
     End If
     ' 開始時間以降に受信した同一件名のメールの検索
     Set colInbox = colInbox.Restrict("[件名] = '" & strSubject & "' AND " & _
         "[受信日時] > '" & strStart & "'")
     ' 監視時間中に閾値を超えるメールを受信したら通知メール送信
     If colInbox.Count >= MAX_MAILS Then
         Dim mailNotify As MailItem
         Set mailNotify = Application.CreateItem(olMailItem)
         mailNotify.Subject = MAIL_SUBJECT
         mailNotify.Body = MAIL_BODY
         mailNotify.To = NOTIFY_TO
         mailNotify.Send
         ' メール送信時間を次の監視の開始時間とするロジック
         g_strLastSent = FormatDateTime(Now, vbShortDate) & " " & _
             FormatDateTime(Now, vbShortTime)
     End If
End Sub

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

送信済みアイテムのメールについて期間を指定して特定の文字列を件名に含むメールにテンプレートで返信するマクロ

コメントにて以下のご要望をいただきました。


はじめまして、はせがわと申します。
Outlookのマクロを作りたいとネットを検索していて貴サイトを拝見し、ご質問させていただきたく思いました。

やりたいこと
社員向けに500件くらいのメールをAccessから自動送信しています。
  本メールには社内試験の結果等をパスワードを付したファイルをメールに添付して受験者に送信しました。
パスワードを知らせるメールを受験生全員に上記メールに返信する形です送付したいと考えています。

具体的には、特定のメール(タイトルと日付)を探し出し、本メールへの返信メールを作成し、パスワードを連絡するメールを送信したい。
  1.送信トレイの中から、期間指定(YYYYMMD-YYYYMMDD)およびメールタイトル(キーワード部分一致:”結果送付のお知らせ”)で対象メールを特定する。
  2.対象メールにReplyAllで返信する形でメールを作成する。
  3.本文にパスワードを伝えるテンプレートを加える
4.送信

※知りたいところ、
  1.特定のフォルダからのメールの検索方法
  2.ReplyAllの返信メールを作成する方法

以上、よろしくお願いたします。


送信トレイの中から、とありますが、これは送信済みアイテムと考えてよいでしょうか?
アイテムを送信日時でフィルターするには Items オブジェクトの Find メソッドが使用できます。
また、メールの件名のキーワードの部分一致は Instr 関数を使用します。
下記のマクロでは C:\temp\password.oft として保存したテンプレート メールの本文で返信メールの本文を置き換え、送信しています。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub SendPasswordByReply()
     Const KEY_WORD = "結果送付のお知らせ"
     Const TEMPLATE_FILE = "c:\temp\password.oft"
     Dim strStart As String
     Dim strEnd As String
     Dim fldSent As Folder
     Dim colSent As Items
     Dim tmpMail As MailItem
     Dim orgMail As MailItem
     Dim repMail As MailItem
     ' 検索期間の開始と終了を入力
     strStart = InputBox("検索期間の開始日(YYYYMMDD)")
     strEnd = InputBox("検索期間の終了日(YYYYMMDD)")
     strStart = Left(strStart, 4) & "/" & Mid(strStart, 5, 2) & "/" & Right(strStart, 2)
     strEnd = Left(strEnd, 4) & "/" & Mid(strEnd, 5, 2) & "/" & Right(strEnd, 2)
     strEnd = DateAdd("d", 1, CDate(strEnd))
     ' テンプレートを取得
     Set tmpMail = Application.CreateItemFromTemplate(TEMPLATE_FILE)
     ' 送信済みアイテムフォルダーを取得
     Set fldSent = Session.GetDefaultFolder(olFolderSentMail)
     Set colSent = fldSent.Items
     ' 指定された期間に送信されたアイテムを検索
     Set orgMail = colSent.Find("[送信日時]>='" & strStart & "' And [送信日時]<'" & strEnd & "'")
     While Not orgMail Is Nothing
         ' 件名にキーワードを含むメールについて処理
         If InStr(orgMail.Subject, KEY_WORD) > 0 Then
             ' 全員に返信
             Set repMail = orgMail.ReplyAll
             ' テンプレートの本文を返信メールの本文と置き換え
             repMail.Body = tmpMail.Body
             ' テンプレートの本文を返信メールの先頭に入れる場合は以下のようにする
             ' repMail.Body = tmpMail.Body & repMail.Body
             ' メールを送信
             repMail.Send
         End If
         Set orgMail = colSent.FindNext
     Wend
End Sub

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

Exchange 環境下で組織外のアドレスに送信する際に警告を表示するマクロ

コメントにて以下のご要望をいただきました。


Windows7/ExchangeServer/Outlook2013の環境です。マクロについて教えて下さい。

複数のドメインが混在していた時に警告を表示するマクロ、を部内で共有させていただいておりますが、単一ドメインが自社ドメインに混在していた時にも警告を表示することは可能でしょうか。

例:社内向けの案内だったにもかかわらず、間違えて社外の人を1名入れてしまった。

(送信時に宛先に含まれるドメインの数で異なる警告メッセージを表示するマクロ、はうまく機能しませんでした。自分のドメインを認識してくれていないようすです)

よろしくお願いいたします。


Exchange サーバーを使用している環境で、組織外へのメール送信で警告を表示するというようなマクロは需要があるはずなのですが、意外とこれまで取り上げていませんでしたね。
Exchange 環境では組織内のアドレスは基本的に X.500 形式のものが使用されていますが、組織外のユーザーをメール連絡先として Active Directory に追加すると、組織外でも X.500 アドレスとなってしまいます。
また、組織内のユーザーを Outlook の連絡先に登録したり、組織内の差出人であっても認証しない SMTP セッションで送信したメールに返信したような場合には、想定外のアドレス形式になっていたりもします。
そのため、組織内であっても SMTP アドレスを取得し、そのアドレスのドメインで組織内かどうかを判断する必要があります。
これらの条件を考慮したマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     Const MY_DOMAIN = "*@example.com" ' 自組織のドメイン名を指定。@ の前に * を付ける
     Dim objRec As Recipient
     Dim strSMTPAddr As String
     Dim bOut As Boolean
     Dim bExternal As Boolean
     Dim strOut As String
     Dim iRet As Integer
     ' 組織外の受信者が複数存在するかどうかの確認
     bExternal = False
     strOut = ""
     For Each objRec In Item.Recipients
         strSMTPAddr = GetSMTPAddr(objRec)
         If Not strSMTPAddr Like MY_DOMAIN Then
             strOut = strOut & strSMTPAddr & ";"
             bExternal = True
         End If
     Next
     ' 組織外の受信者が複数含まれていた場合の処理
     If bExternal Then
         iRet = MsgBox("あて先に組織外のドメインのメールアドレスが含まれています。送信しますか?" & _
             vbCrLf & "外部ドメイン宛: " & strOut, vbYesNo, "送信確認")
         Select Case iRet
             Case vbYes
                 ' 送信日時を 1 分後に設定
                 Item.DeferredDeliveryTime = DateAdd("n", 1, Now)
                 Cancel = False ' 念のため
             Case vbNo
                 Cancel = True
         End Select
     End If
End Sub
' SMTP アドレス取得関数
Private Function GetSMTPAddr(objRec As Recipient)
     Const PR_ORIGINAL_DISPLAY_NAME = "http:" & "//schemas.microsoft.com/mapi/proptag/0x3a13001e"
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39fe001e"
     Dim strSMTPAddr As String
     If objRec.AddressEntry.Type = "SMTP" Then
         strSMTPAddr = objRec.Address
     Else ' Exchange 対応
         If objRec.AddressEntry.AddressEntryUserType = olOutlookContactAddressEntry Then
             strSMTPAddr = objRec.AddressEntry.PropertyAccessor.GetProperty(PR_ORIGINAL_DISPLAY_NAME)
         Else
             strSMTPAddr = objRec.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
         End If
     End If
     GetSMTPAddr = strSMTPAddr
End Function

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

受信者のドメインに応じた署名を追加するマクロ

コメントにて以下のご要望をいただきました。


いつも勉強させていただいてます。
ありがとうございます。

新規メールの作成時、メールの返信時において、
  署名をメールの宛先のドメインに合わせて変更することは可能でしょうか。
ぜひご教示いただければ幸いです。
よろしくお願いいたします。

操作環境
Windows 7
  Outlook 2013


以下のマクロは特定のドメインへの署名をドメイン名で作成しておき、受信者のドメインに応じた署名を追加するというものです。
例えば、example.com への返信に使用したい署名はあらかじめ “example.com” という名前で署名を作成しておく必要があります。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub ChangeSignatureByRecipients()
     Dim curItem As MailItem
     Dim strSigFolder As String
     Dim objFSO As Object ' FileSystemObject
     Dim objRec As Recipient
     Dim strRecDomain As String
     ' 表示中のアイテムを取得
     Set curItem = ActiveInspector.CurrentItem
     curItem.Display
     ' 署名が保存されているフォルダーを取得
     strSigFolder = Environ("APPDATA") & "\Microsoft\Signatures\"
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     For Each objRec In curItem.Recipients
         ' 受信者のドメインを取得
         strRecDomain = objRec.Address
         strRecDomain = Mid(strRecDomain, InStr(strRecDomain, "@") + 1)
         ' ドメイン名の署名が存在した場合に署名を挿入
         If objFSO.FileExists(strSigFolder & strRecDomain & ".txt") Then
             Dim stmFile As Object ' TextStream
             ' 署名ファイルを開く
             Set stmFile = objFSO.OpenTextFile(strSigFolder & strRecDomain & ".txt", 1, False, -1)
             Dim docBody As Object ' Document
             Dim strText As String
             Set docBody = curItem.GetInspector.WordEditor
             ' 本文の先頭に署名を追加
             docBody.Parent.Selection.MoveDown
             docBody.Parent.Selection.TypeText stmFile.ReadAll()
             docBody.Parent.Selection.MoveUp 5, 99
             stmFile.Close
             ' 署名を挿入したらループを終了
             Exit For
         End If
     Next
End Sub

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

表示中のフォルダーのビューを変更するマクロ

コメントにて以下のご要望をいただきました。


いつも参考にさせて頂いております。
ところで定義されたビューをユーザ設定したタブに登録したいと考えております。
VBAでビューを呼び出すことが出来るのでしょうか。
以前にビューをインポートするマクロがあり、それを参考に作成してみましたが、ビューの呼び出しがうまくいきません。
アドバイスを御願いします。


現在表示しているフォルダーのビューを変更したい場合、ActiveExplorer.CurrentView にそのビューの名前を設定します。
例えば、”未読メール” という名前のビューを定義しており、そのビューに変更したい場合は以下のようなマクロで実現できますので、このマクロをリボンのカスタマイズでリボンに追加してください。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub SetViewUnread()
     ActiveExplorer.CurrentView = "未読メール"
End Sub

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