特定のフォーマットのメールを受信したら、件名と本文をそのまま転送するマクロ

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


コメント

いつも参考にさせて頂いております。

不躾ではございますが、案件対応上取り決められているメールを出したいのですが
送信タイミングが不定、且つ送信に使うPCは遠隔接続NGとの環境的条件がある為
とても困っております。

OutlookでのVBAはまだまだ経験値が足りず、以下の需要にご助言等頂きたく相談申し上げます。

▼参考として拝見中のコンテンツ
 転送時に差出人のアドレスを置き換えるマクロ https://outlooklab.wordpress.com/2014/01/11/%E8%BB%A2%E9%80%81%E6%99%82%E3%81%AB%E5%B7%AE%E5%87%BA%E4%BA%BA%E3%81%AE%E3%82%A2%E3%83%89%E3%83%AC%E3%82%B9%E3%82%92%E7%BD%AE%E3%81%8D%E6%8F%9B%E3%81%88%E3%82%8B%E3%83%9E%E3%82%AF%E3%83%AD/

 本文に特定の文面を含む場合に、そのメールとファイルを添付して転送するマクロ
https://outlooklab.wordpress.com/2012/01/21/%e6%9c%ac%e6%96%87%e3%81%ab%e7%89%b9%e5%ae%9a%e3%81%ae%e6%96%87%e9%9d%a2%e3%82%92%e5%90%ab%e3%82%80%e5%a0%b4%e5%90%88%e3%81%ab%e3%80%81%e3%81%9d%e3%81%ae%e3%83%a1%e3%83%bc%e3%83%ab%e3%81%a8%e3%83%95/

▼需要について
 ・最終的に実行したいこと
  - 社内デスクトップPC(社外からの遠隔操作NG)から、特定のメール3通を出させたい

  - 3通は案件で「関係者宛に送る」と取り決められているメール
    ※3通ともほぼ定型。送信先(TO、CC)は固定の面子。
    <対応開始時刻前時点>
      ①「当該案件の対応開始」告知
       ※件名は「yyyymmdd 固有文字列」。
       ※本文は、差出人苗字と責任者苗字以外定型。

    <作業完了後>
      ②対応内容の報告PDF添付メール ※報告PDF=要対応事項なしの際も必ず記載・添付。
       ※件名は「yyyymmdd 固有文字列」。
       ※本文は、差出人苗字以降は不定。報告書掲載内容のポイントに触れた文面2~3行等。

      ③(報告PDF添付メール送付も含めた) その日の「当該案件対応完了」告知
       ※件名は「yyyymmdd 固有文字列」。
       ※本文は、差出人苗字と責任者苗字以外定型。

 ・実現させたい使い方
  - 社外持ち出しPC(社内デスクトップPCや社内ネットワークへの遠隔接続NG)から
    社内デスクトップPCへメールを送る
    ※社内デスクトップPCとは別ドメインのメール
    ※社内デスクトップPCは完全に、社内ネットワーク専用。
     ただしメールやネット等の一般的な利用は可の為、外からメールを受けることはOK。

  - 受信したメールの件名ルールが合致するかを確認

  - 合致すれば、固定面子の送信先(TO、CC)を持つ新規メールに本文を転記

  - 添付があればそれも添付へ転用

▼得られる結果
 ・終了が大抵夜間~深夜に及ぶ為、現場から直帰が出来る為1~2時間早い帰宅が可能に。

こちらの都合に起因した相談の為誠に恐縮なのですが、運用のやりくり上でも手詰まりとなり
簡単に「こんな働きをするスクリプトたちを、上からこういう順に配置すれば良いのでは」等
構成配置などだけでも、ご助言を賜れれば幸いです。


ご要望のイメージとしては、外部の UserX から社内の UserA に特定フォーマットの件名のメールを送信すると、UserA の端末で実行されている Outlook からそのメールを送信したかのように転送するという処理でしょうか?
まず、「yyyymmdd 固有文字列」という件名かどうかの判断については、VBA の LIKE 演算子で “######## 固有文字列” という条件を指定します。
LIKE 演算子では “#” が 1 桁の数字に合致するという意味になるため、”########” で 8 桁の数字に合致するかどうかを確認できます。
送信するメールの作成については新規メールではなく、MailIItem オブジェクトの Forward メソッドにより転送メールを作成し、件名と本文を元のメールのものに置き換えることで、添付ファイルなども維持できます。
マクロは以下のようになります。

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

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objItem As Variant
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     If objItem.MessageClass = "IPM.Note" Then
         ForwardBySubject objItem
     End If
End Sub
'
'
Public Sub ForwardBySubject(ByVal objMail As MailItem)
     ' メールの宛先を指定
     Const TO_ADDRESS = "To User <to@example.com>"
     ' メールの CC を指定
     Const CC_ADDRESS = "Cc User <cc@example.com>"
     ' 処理すべきメールの差出人アドレスを指定
     Const SENDER_ADDRESS = "from@example.com"
     '
     Dim arrKeywords
     Dim strKeyword
     Dim objForward As MailItem
     '
     arrKeywords = Array("固有文字列1", "固有文字列2", "固有文字列3")
     '
     For Each strKeyword In arrKeywords
         ' 先頭の 8 文字が数字でスペースを入れて固有文字列が続く件名
         ' かつ特定の差出人からのメールのみ
         If objMail.Subject Like "######## " & strKeyword And _
            objMail.SenderEmailAddress = SENDER_ADDRESS Then
             ' メールの転送
             Set objForward = objMail.Forward
             objForward.To = TO_ADDRESS
             objForward.CC = CC_ADDRESS
             ' 転送メールの件名と本文は元のままを維持
             objForward.Subject = objMail.Subject
             If objForward.BodyFormat = olFormatPlain Then
                 objForward.Body = objMail.Body
             Else
                 objForward.HTMLBody = objMail.HTMLBody
             End If
             objForward.Send
         End If
     Next
End Sub

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

広告

Excel のデータを Outlook の本文に表としてコピーするマクロ

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


Office2016を利用しています。ExcelのVBAでOutlookメールを送信しようとしています。
リッチテキスト型の本文に、「表を挿入」する方法が分からず困っています。また、挿入した表の任意のセルに文字を代入する手順も知りたいです。(Excelシートの貼り付けではありません。)
よろしくお願いします。


Outlook のメールの本文に表を挿入するには、Inspector オブジェクトの WordEditor プロパティにより取得できる、Word の Document オブジェクトを使用します。
これにより、Word のマクロで文書を編集する場合と同様に Outlook の本文の編集ができます。
本文に表を挿入する場合、Document オブジェクトの Tables プロパティの Add メソッドを使用します。
Add メソッドで返される Table オブジェクトを使って表のスタイルなどを設定し、Cell プロパティで表のセルの値を変更します。
表のスタイルやセルの書式設定の方法などについては Word のマクロのサンプルなどを参考にしてください。

以下のマクロでは、COL_START や ROW_START  などで指定した範囲の Excel の表のデータを本文に挿入した表にコピーします。

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

Public Sub CopyTableToMail()
     ' 転記する Excel ファイルの列の開始位置
     Const COL_START = 1
     ' 転記する Excel ファイルの列の数
     Const NUM_COLS = 5
     ' 転記する Excel ファイルの行の開始位置
     Const ROW_START = 1
     ' 転記する Excel ファイルの行の数
     Const NUM_ROWS = 10
     ' Outlook の定数
     Const olMailItem = 0
     Const olFormatRichText = 3
     '
     Dim appOlk As Object ' Outlook.Application
     Dim objItem As Object ' Outlook.MailItem
     Dim wrdEditor As Object ' Word.Document
     Dim wrdTable As Object ' Word.Table
     Dim wrdRange As Object ' Word.Range
     Dim iCol As Integer
     Dim iRow As Integer
     ' Outlook の Application オブジェクトを取得
     Set appOlk = CreateObject("Outlook.Application")
     ' 新規アイテムを作成
     Set objItem = appOlk.CreateItem(olMailItem)
     '
     objItem.BodyFormat = olFormatRichText
     ' 新規アイテムの WordEditor オブジェクトを取得
     Set wrdEditor = objItem.GetInspector().WordEditor
     ' WordEditor にフォーカス設定
     wrdEditor.Activate
     ' 表の挿入位置を取得
     Set wrdRange = wrdEditor.Application.Selection.Range
     ' 本文に表を挿入
     Set wrdTable = wrdEditor.Tables.Add(wrdRange, NUM_ROWS, NUM_COLS)
     '
     With wrdTable
         ' 表のスタイルを指定
         .Style = "表 (格子)"
         ' 表の [タイトル行] をオン
         .ApplyStyleHeadingRows = True
         ' 表の [集計行] をオン
         .ApplyStyleLastRow = False
         ' 表の [最初の列] をオン
         .ApplyStyleFirstColumn = True
         ' 表の [最後の列] をオン
         .ApplyStyleLastColumn = False
         ' 表の [縞模様 (行)] をオン
         .ApplyStyleRowBands = True
         ' 表の [縞模様 (列)] をオフ
         .ApplyStyleColumnBands = False
         ' Excel の表のデータを本文のテーブルに転記
         For iCol = 1 To NUM_COLS
             For iRow = 1 To NUM_ROWS
                 ' .Cell は本文の表のセル
                 ' Cells は Excel の表のセル
                 .Cell(iRow, iCol).Range.Text = _
                     Cells(ROW_START + iRow - 1, COL_START + iCol - 1).Value
             Next
         Next
     End With
     ' 表を挿入したアイテムを表示
     objItem.Display
End Sub

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

連絡先のデータを一括で書き換えるマクロ

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


お世話になります。
  個人用の連絡先に既にある連絡先の内容をマクロの実行で一括変更するマクロを作成したいと考えております。
お力添えをいただけると助かります。

◆環境
Win10、Outlook2016

◆実施したいこと
選択した既にある連絡先をマクロの実行で一括変更したい
(例として架空の設定を使用しますが書式は全て同じです)

==変更前==
姓:YAMADA
名:TARO
勤務先:○○社
部署:Engineering Div. (エンジニア部 第三係)
役職:Team Leader (班長)
表題:YAMADA, TARO
電子メール:taro.yamada@example
表示名:Taro Yamada (山田 太郎) (taro.yamada@example)
国:Japan
その他:空白

==変更後==
姓:山田
名:太郎
フリガナ姓:YAMADA
フリガナ名:TARO
勤務先:○○社
部署:エンジニア部 第三係
役職:班長
表題:山田, 太郎
電子メール:taro.yamada@example
表示名:山田 太郎
国:Japan
その他:空白

上記のように英語部を省くようにするのと、名前を表示名の漢字から参照したいです。
  (フリガナはあってもなくてもどちらでも構いません)

何卒、よろしくお願い致します。


電子メールの表示名は ContactItem オブジェクトの Email1DisplayName プロパティになります。
取得した表示名の括弧内の文字列を取得するには、InStr 関数で ( と ) の位置を検索し、その間の文字列を Mid 関数で取得します。
括弧内の文字列取得は部署や役職の設定でも使用するので関数化しました。
後は取得した文字列を ContactItem オブジェクトの以下のそれぞれのプロパティに設定していきます。

姓: LastName
名: FirstName
フリガナ姓: YomiLastName
フリガナ名: YomiFirstName
部署: Department
役職: JobTitle
表題: FileAs

マクロは以下のようになります。

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

Public Sub ReplaceNamesInContacts()
     Dim fldContacts As Folder
     Dim colContacts As Items
     Dim i As Integer
     Dim contItem As ContactItem
     Dim strFullName As String
     Dim arrName As Variant
     Dim strDept As String
     Dim strTitle As String
     ' 既定の連絡先フォルダーを取得
     Set fldContacts = Session.GetDefaultFolder(olFolderContacts)
     ' 連絡先アイテムのみを取得
     Set colContacts = fldContacts.Items.Restrict("[MessageClass] = 'IPM.Contact'")
     ' すべての連絡先について処理
     For Each contItem In colContacts
         With contItem
             ' 表示名から括弧内の文字列を取得
             strFullName = GetTextInParenthesis(.Email1DisplayName)
             If InStr(strFullName, " ") > 0 Then
                 ' 表示名を空白で分割
                 arrName = Split(strFullName, " ")
                 ' 英語の名前をフリガナに移動
                 .YomiFirstName = .FirstName
                 .YomiLastName = .LastName
                 ' 漢字の名前を設定
                 .FirstName = arrName(1)
                 .LastName = arrName(0)
                 .Email1DisplayName = strFullName
                 .FileAs = .LastName & ", " & .FirstName
             End If
             ' 部署名からカッコ内の文字列を取得
             strDept = GetTextInParenthesis(.Department)
             If strDept <> "" Then
                 .Department = strDept
             End If
             ' 役職からカッコ内の文字列を取得
             strTitle = GetTextInParenthesis(.JobTitle)
             If strTitle <> "" Then
                 .JobTitle = strTitle
             End If
             ' 変更後のアイテムを保存
             .Save
         End With
     Next
End Sub
' () 内の文字列を取り出す関数
Private Function GetTextInParenthesis(strText As String)
     Dim s As Long
     Dim e As Long
     s = InStr(strText, "(")
     e = InStr(strText, ")")
     If s > 0 And e > s Then
         GetTextInParenthesis = Mid(strText, s + 1, e - s - 1)
     Else
         GetTextInParenthesis = ""
     End If
End Function

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

指定した期間に受信したメールの情報を Excel ファイルに書き出し、さらに MSG ファイルとして保存するマクロ

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


お世話になります。

知見が全くない中Outlookマクロを作成を緊急で迫られており、
お力添えいただけると大変助かります。

■VBAで実行したいこと
1)特定フォルダの特定期間(マクロ実行時に指定)のメールをmsgファイルでエクスポート
2)同時に出力されるmsgファイルをエクセルで一覧化(項目:件名/送信者/受信日時/分類項目)

■環境
OS:windows 10
  Outlook:Office 365 MSO

何卒、よろしくお願いいたします。


特定のフォルダーのすべてのメールを msg ファイルとして保存し、Excel に一覧化するマクロは、「フォルダー内のすべてのメールの内容を Excel ファイルに書き出し、さらに MSG ファイルとして保存するマクロ」として公開しています。
今回はこのマクロに期間を指定するコードを追加しました。
マクロの実行時に期間を指定するには InputBox 関数により日付を入力します。
そして、その期間のアイテムだけを取得するには Items オブジェクトの Restrict メソッドを使用します。
マクロは以下のようになります。

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

Public Sub ExportToExcelAndMSGLimited()
     On Error Resume Next
     Const EXCEL_FILE = "c:\temp\リスト.xlsx"
     Const MSG_FILE_BASE = "c:\temp\メール No."
     Dim dtStart As Date
     Dim dtEnd As Date
     Dim strStart As String
     Dim strEnd As String
     Dim strFilter As String
     Dim fldCurrent As Folder
     Dim colItems As Items
     Dim objItem 'As MailItem
     Dim objBook 'As Excel.Workbook
     Dim objSheet 'As Excel.Worksheet
     Dim r As Integer
     Dim c As Integer
     ' エクスポート範囲を指定
     dtStart = CDate(InputBox("開始日:", "メールのエクスポート"))
     dtEnd = CDate(InputBox("終了日:", "メールのエクスポート"))
     strStart = FormatDateTime(dtStart, vbShortDate)
     strEnd = FormatDateTime(dtEnd, vbShortDate)
     strFilter = "[受信日時] >= '" & strStart & _
                 "' AND [受信日時] <= '" & strEnd & " 23:59'"
     ' 現在開いているフォルダーを取得
     Set fldCurrent = ActiveExplorer.CurrentFolder
     ' 指定された範囲でフィルタリング
     Set colItems = fldCurrent.Items.Restrict(strFilter)
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     objBook.Windows(1).Activate
     Set objSheet = objBook.Sheets(1)
     ' データがない行まで移動
     r = 2
     While objSheet.cells(r, 1) <> ""
         r = r + 1
     Wend
     c = 1
     ' メールの情報を Excel ファイルに追記
     For Each objItem In colItems
         With objSheet
             .cells(r, 1) = objItem.Subject
             .cells(r, 2) = objItem.SenderName
             .cells(r, 3) = objItem.To
             .cells(r, 4) = objItem.CC
             .cells(r, 5) = objItem.Categories
             .cells(r, 6) = MSG_FILE_BASE & c & ".msg"
         End With
         objItem.SaveAs MSG_FILE_BASE & c & ".msg", olMSGUnicode
         r = r + 1
         c = c + 1
     Next
     ' Excel ファイルを閉じる
     objBook.Close True
     MsgBox fldCurrent.Name & "のアイテムを保存しました。"
End Sub

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

固定アドレスを追加して返信、転送をするマクロ

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


お世話になります。

返信、転送時
  宛先:Aさん、CC:Bさん、BCC:Cさんとするマクロをお願いできないでしょうか?
・宛先:Aさんは送信元の場合が多い
  ・CC:Bさん、BCC:Cさんは毎回固定

返信メッセージで表示名をアドレス帳のものに置き換えるマクロ
  こちらを先に実行し、次にCC:Bさん、BCC:Cさんを別のマクロ
  もしくは、全てを同時に可能なマクロ

環境
OS:Windows10 64bit
  Office365

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


まず、Outlook 自体の返信や転送の際に自動的に追加するようなマクロを作ろうとするとイベント処理が複雑になるので、返信や転送を行うマクロを作ってもともとの返信や転送の代わりに使用するようにします。
宛先や Cc などを追加するのであれば MailItem オブジェクトの Recipients プロパティの Add メソッドで受信者の表示名とアドレスを追加した後、そのメソッドで返される Recipient オブジェクトの Type に宛先や Cc の種別を設定します。
ただ、単に追加するだけだと、元の受信者や送信者のアドレスが重複する可能性があるので、すでに存在する場合は追加しないというロジックが必要になります。
なお、返信メッセージで表示名をアドレス帳のものに置き換えるマクロについては以前こちらで公開していますが、返信時に同時に実行するように組み込んでいます。

マクロは以下のようになります。
AddFixedAddress の中の TO_NAME や TO_ADDRESS などを宛先などで指定する受信者の表示名やアドレスに置き換えてください。
また、返信を行うときには ReplyWithFixedAddress、転送を行うときには ForwardWithFixedAddress を実行してください。

' ここをトリプルクリックでマクロ全体を選択できます。
'
' 固定アドレスを追加して返信するマクロ
Public Sub ReplyWithFixedAddress()
     Dim objReply As MailItem
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set objReply = ActiveInspector.CurrentItem.ReplyAll
     Else
         Set objReply = ActiveExplorer.Selection(1).ReplyAll
     End If
     ' 元のメールの受信者の表示名の置き換え
     ReplaceDisplayName objReply
     ' 固定アドレスの追加
     AddFixedAddress objReply
     objReply.Display
End Sub
'
' 固定アドレスを追加して転送するマクロ
Public Sub ForwardWithFixedAddress()
     Dim objForward As MailItem
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set objForward = ActiveInspector.CurrentItem.Forward
     Else
         Set objForward = ActiveExplorer.Selection(1).Forward
     End If
     ' 固定アドレスの追加
     AddFixedAddress objForward
     objForward.Display
End Sub
'
' 固定アドレスを追加するマクロ
Private Sub AddFixedAddress(objReFw As MailItem)
     Const TO_NAME = "UserTO"
     Const TO_ADDRESS = "userto@example.com"
     Const CC_NAME = "UserCC"
     Const CC_ADDRESS = "usercc@example.com"
     Const BCC_NAME = "UserBCC"
     Const BCC_ADDRESS = "userbcc@example.com"
     '
     AddIfNotExist objReFw, TO_NAME, TO_ADDRESS, olTo
     AddIfNotExist objReFw, CC_NAME, CC_ADDRESS, olCC
     AddIfNotExist objReFw, BCC_NAME, BCC_ADDRESS, olBCC
     objReFw.Recipients.ResolveAll
End Sub
'
' 受信者に含まれない場合だけ追加するマクロ
Private Sub AddIfNotExist(objReFw As MailItem, strName As String, strAddr As String, iType As OlMailRecipientType)
     Dim objRecip As Recipient
     ' メールの受信者すべてのアドレスをチェック
     For Each objRecip In objReFw.Recipients
         If objRecip.Address = strAddr Then
             ' 見つかったら追加せずに終了
             Exit Sub
         End If
     Next
     ' 見つからなければ受信者として追加
     Set objRecip = objReFw.Recipients.Add("""" & strName & """ <" & strAddr & ">")
     objRecip.Type = iType
End Sub
'
' 受信者の表示名をアドレス帳のもので置き換えるマクロ
Private Sub ReplaceDisplayName(objReply As MailItem)
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39FE001E"
     '
     Dim objRecip As Recipient
     Dim objContact As ContactItem
     Dim objAddrList As AddressList
     Dim i As Integer
     Dim objAddrEntry As AddressEntry
     Dim bFound As Boolean
     Dim cRecips As Integer
     Dim colAddress() As String
     Dim colName() As String
     Dim colType() As Integer
     '
     cRecips = objReply.Recipients.Count
     ReDim colAddress(cRecips) As String
     ReDim colName(cRecips) As String
     ReDim colType(cRecips) As Integer
     ' 受信者の情報を取得し、いったん削除
     For i = cRecips To 1 Step -1
         Set objRecip = objReply.Recipients.Item(i)
         With objRecip.AddressEntry
             If .Type = "SMTP" Then
                 colAddress(i) = objRecip.Address
             Else
                 colAddress(i) = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
             End If
         End With
         colName(i) = objRecip.Name
         colType(i) = objRecip.Type
         objReply.Recipients.Remove i
     Next
     ' 取得した受信者情報についてアドレス帳から表示名を検索し置き換え
     For i = 1 To cRecips
         Set objRecip = Nothing
         For Each objAddrList In Session.AddressLists
             If objAddrList.AddressListType = olOutlookAddressList Then
                 For Each objAddrEntry In objAddrList.AddressEntries
                     If objAddrEntry.Address = colAddress(i) Then
                         Set objRecip = objReply.Recipients.Add(colAddress(i))
                         Set objRecip.AddressEntry = objAddrEntry
                         objRecip.Type = colType(i)
                         Exit For
                     End If
                 Next
                 If Not objRecip Is Nothing Then
                     Exit For
                 End If
             End If
         Next
         ' アドレス帳で見つからなかった受信者については元の表示名で追加
         If objRecip Is Nothing Then
             If colName(i) <> colAddress(i) Then
                 Set objRecip = objReply.Recipients.Add(colName(i) & " <" & colAddress(i) & ">")
              Else
                 Set objRecip = objReply.Recipients.Add(colAddress(i))
             End If
             objRecip.Type = colType(i)
         End If
     Next
     '
     objReply.Recipients.ResolveAll
  End Sub
 

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

件名に含まれるキーワードにより送信警告の表示を制御するマクロ(複数ドメイン バージョン)

件名に含まれるキーワードにより送信警告の表示を制御するマクロのコメントにて以下のご要望をいただきました。


いつも参考にさせていただいております。

上記マクロ内の「Const MyDomain 」を複数設定することは可能でしょうか。
いくつか検索してみましたが、該当のページが見つけられなかったため、問い合わせした次第です。

お手数おかけいたしますが、よろしくお願いいたします。


ドメインを複数設定する必要がある場合、宛先アドレスのドメインチェックの際に For 文でドメイン文字列とのマッチングを行う必要があります。
元のマクロを複数ドメインに対応するよう修正したものは以下の通りです。
なお、このマクロが正常に動作するには、件名に含まれるキーワードにより送信警告の表示を制御するマクロで説明しているフォルダー設定などが必要になります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     Cancel = CheckRecipients(Item)
End Sub
'
Private Function CheckRecipients(Item As Object) As Boolean
     ' 社内扱いするドメインを ; で区切って指定
     Const MyDomain = "@us.example.com;@jp.example.com"
     ' SMTP アドレスを格納する MAPI プロパティの TAG です。URL ではありません。
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39FE001E"
     Dim arrMyDomain As Variant
     Dim i As Integer
     Dim j As Integer
     Dim strAddress As String
     Dim strExtAddr As String
     Dim bExternal As Boolean
     ' ; でドメイン文字列を分割し配列に格納
     arrMyDomain = Split(MyDomain, ";")
     '
     If Item.MessageClass Like "IPM.TaskRequest*" Then
         Set Item = Item.GetAssociatedTask(False)
     End If
     ' Phase 1 - 社外のアドレスのみを抽出
     strExtAddr = ""
     For i = 1 To Item.Recipients.Count
         With Item.Recipients.Item(i)
             strAddress = .Address
             If LCase(strAddress) Like "/o=*" Then
                 ' アドレスが Exchange アドレスなら、SMTP アドレスを取得
                 strAddress = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
             End If
             ' 自ドメインのアドレスでない場合は bExternal は True
             bExternal = True
             For j = LBound(arrMyDomain) To UBound(arrMyDomain)
                 ' 自ドメインのアドレスであれ場合は bExternal は True
                 If strAddress Like "*" & arrMyDomain(j) Then
                     bExternal = False
                     Exit For
                 End If
             Next
             ' bExternal が True なら社外アドレス
             If bExternal Then
                 strExtAddr = strExtAddr & strAddress & ";"
             End If
         End With
     Next
     ' 社外アドレスが存在する場合のみの処理
     If strExtAddr <> "" Then
         Dim arrAddress
         Dim arrPattern
         Dim fldDomainList 'As Folder
         Dim itmDomain 'As PostItem
         Dim strPrompt As String
         Dim objContacts 'As Folder
         Dim objContact 'As ContactItem
         ' アドレスが ' でくくられていたら削除
         If strExtAddr Like "'*'" Then
             strExtAddr = Mid(strExtAddr, 2, Len(strExtAddr) - 2)
         End If
         ' 社外アドレスを配列に格納
         arrAddress = Split(strExtAddr, ";")
         strExtAddr = ";" & strExtAddr
         ' Phase 2 - ドメイン リストのチェック
         ' DomainList フォルダを取得
         Set fldDomainList = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("DomainList")
         For Each itmDomain In fldDomainList.Items
             ' DomainList のアイテムの件名がメッセージの件名に含まれていた場合
             If InStr(Item.Subject, itmDomain.Subject) > 0 Then
                 ' アイテムの本文を改行で分割し、アドレス パターンを取得
                 itmDomain.BodyFormat = olFormatPlain
                 arrPattern = Split(itmDomain.Body, vbCrLf)
                 ' 受信者のアドレスとアドレス パターンの照合
                 For i = 0 To UBound(arrAddress) - 1
                     For j = 0 To UBound(arrPattern)
                         ' アドレス パターンと一致するアドレスは社外アドレスから除外
                         If arrAddress(i) Like arrPattern(j) Then
                             strExtAddr = Replace(strExtAddr, ";" & arrAddress(i) & ";", ";")
                             Exit For
                         End If
                     Next
                 Next
                 ' アドレス パターンに一致しないアドレスが存在した場合
                 If strExtAddr <> ";;" Then
                     strPrompt = String(54, "*") & vbLf & "このメッセージの件名には「" & itmDomain.Subject _
                         & "」が含まれていますが、このキーワードでは以下のアドレスは許可されていません。[OK] をクリックすると送信します。" _
                         & Replace(strExtAddr, ";", vbLf) & String(54, "*")
                     If MsgBox(strPrompt, vbOKCancel + vbExclamation) = vbCancel Then
                         CheckRecipients = True ' 送信しない
                     Else
                         CheckRecipients = False ' 送信する
                     End If
                 Else
                     CheckRecipients = False ' 送信する
                 End If
                 ' ドメイン リストが合致したら以降の処理は行なわない
                 Exit Function
             End If
         Next
         ' Phase 3 - 受信者ごとの分類項目チェック
         ' 連絡先フォルダを取得
         Set objContacts = Session.GetDefaultFolder(olFolderContacts)
         For i = 0 To UBound(arrAddress) - 1
             ' 受信者のアドレスを連絡先から検索
             Set objContact = objContacts.Items.Find("[Email1Address] = '" & arrAddress(i) _
                 & "' or [Email2Address] = '" & arrAddress(i) _
                 & "' or [Email3Address] = '" & arrAddress(i) & "'")
             If Not objContact Is Nothing Then
                 ' 連絡先アイテムが存在したら、分類項目をチェック
                 If objContact.Categories <> "" Then
                     ' 分類項目を配列に格納
                     arrPattern = Split(objContact.Categories, ", ")
                     For j = 0 To UBound(arrPattern)
                         ' 分類項目を件名に含む場合は社外アドレスから除外
                         If InStr(Item.Subject, arrPattern(j)) > 0 Then
                             strExtAddr = Replace(strExtAddr, ";" & arrAddress(i) & ";", ";")
                             Exit For
                         End If
                     Next
                 End If
             End If
         Next
         ' 連絡先がない、もしくは分類項目の文字列が件名にないアドレスが存在した場合
         If strExtAddr <> ";;" Then
             strPrompt = "このメッセージには以下の社外アドレスが含まれています。[OK] をクリックすると送信します。" & Replace(strExtAddr, ";", vbLf)
             If MsgBox(strPrompt, vbOKCancel + vbExclamation) = vbCancel Then
                 CheckRecipients = True ' 送信しない
                 Exit Function
             End If
         End If
     End If
     CheckRecipients = False ' 送信する
End Function

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

閲覧ウィンドウで表示されているメールの WordEditor を取得する方法

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


いつも参考にさせて頂いております。ありがとうございます。

メール本文の選択した範囲のみをエクセルへ吐き出すマクロを作りたいと考えております。

こちらのサイトを参考にさせて頂き、メールウィンドウを開いた時にはできるようになりましたが、閲覧ウィンドウで実施しようとするとWordEditorが上手く指定できません。(下記★部)

閲覧ウィンドウでのWordEditorの設定方法もしくは代替え案があればご教示頂けませんでしょうか。

<中略>

‘ Word Editor オブジェクトを取得
★’Set wrdEditor = ActiveInspector.WordEditor オブジェクト変数が設定されていませんと怒られる


ActiveInspector は現在表示されている Inspector ウィンドウ (アイテムごとのウィンドウ) を操作するためのものです。
したがって、アイテムをダブルクリックして表示していない場合は ActiveInspector に対する処理は失敗しますし、アイテムを表示している場合はそのアイテムに対する操作となります。
閲覧ウィンドウが表示されているウィンドウは Explorer、このオブジェクトでは ActiveInlineResponseWordEditor  で WordEditor オブジェクトの取得ができますが、こちらはインライン返信を行っている際の返信アイテムのみで使用可能です。
受信したメールを閲覧ウィンドウで表示している状態で、このメールの選択部分の取得などのために WordEditor にアクセスする場合は、以下のような手順となります。

  1. ActiveExplorer.Selection(1) により、選択しているアイテムのオブジェクトを取得する
  2. 取得したアイテムの GetInspector プロパティにより、Inspector オブジェクトを取得する
  3. 取得した Inspector の WordEditor プロパティにより、WordEditor オブジェクトを取得する

例えば、現在表示しているウィンドウで選択している本文の文字列を取得する関数は以下のようになります。

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

Private Function GetSelectedText() As String
     Dim objInspector As Inspector
     Dim wrdEditor
     ' メールをどのように開いているか確認
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set objInspector = ActiveInspector
     Else
         Dim objItem
         Set objItem = ActiveExplorer.Selection(1)
         Set objInspector = objItem.GetInspector
     End If
     '
     Set wrdEditor = objInspector.WordEditor
     GetSelectedText = wrdEditor.Application.Selection
  End Function

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