指定した期間に受信したメールの情報を 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

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

広告

Outlook 2016/2013/2010 のセキュリティ修正プログラム 2019 年 8 月分がリリース

8/14 に Outlook 2016、Outlook 2013 および Outlook 2010 のセキュリティ修正プログラムがリリースされました。 以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

Outlook 2016 のセキュリティ更新プログラムについて2019 年 8 月 14 日 1 件のセキュリティ修正と 6 件のセキュリティ以外の修正が行われています。

Exchange アドインの修正

2019 年 8 月 6日更新プログラム Office 2016 (KB4464535) 1 件のセキュリティ修正と 6 件のセキュリティ以外の修正が行われています。

Word 2016 の修正

2016 の Word のセキュリティ更新プログラムの説明: 2019 年 8 月 13日 1 件の Outlook にも影響があるセキュリティ修正が行われています。

Office 2016 共通コンポーネントの修正

2019 年 8 月 6日更新プログラム Office 2016 (KB4464588) 1 件の Outlook に関する修正が行われています。

Office 2013

Outlook 2013 の修正

Outlook 2010 用のセキュリティ更新プログラムの説明: 2019 年 8 月 13日 1 件のセキュリティ修正が行われています。

Word 2013 の修正

Word 2013 のセキュリティ更新プログラムの説明: 2019 年 8 月 13日 1 件の Outlook にも影響があるセキュリティ修正が行われています。

Office 2010

Outlook 2010 の修正

Outlook 2010 のセキュリティ更新プログラムについて2018 年 12 月 12 日 1 件のセキュリティ修正が行われています。

Word 2010 の修正

Word 2010 用のセキュリティ更新プログラムの説明: 2019 年 8 月 13日 Outlook にも影響があるセキュリティ修正とセキュリティ以外の修正が 1 件ずつ行われています。

Office 2016 共通コンポーネントの修正

Office 2010 用のセキュリティ更新プログラムの説明: 2019 年 8 月 13日 Outlook にも影響があるセキュリティ修正とセキュリティ以外の修正が 1 件ずつ行われています。

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

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


お世話になります。

返信、転送時
  宛先: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

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

返信、転送時の本文に含まれるヘッダーのメールアドレスを削除する方法

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


お世話になります。

サーバー更新により、受信したメールから返信・転送メールを作成する際に、
  本文中の宛先、CCの名前の後ろにアドレスが表示されるようになってしまいました。
この症状は、受信メールの閲覧のみでは発生せず、返信メール作成すると発生します。

以前         現在
  「宛先:田島太郎」→「宛先:田島太郎 (メールアドレス)」

アドレスを削除するためのマクロはなんとか作成できましたが、
  削除のタイミングが思い通りになりません。

特定文字列の削除のタイミングは
「転送(Ctrl+R)」「返信(Ctr+Shift+R)」「全員へ返信(Ctrl+F)」
ボタン押下または右クリックにより、返信等メール本文が
表示される同時にマクロが動くのが希望です。
  (返信メール本文が表示された際には、既に削除されている)

最初、受信メールを開いた際にマクロが動くようにしたのですが、
  閲覧だけだと、特定文字列の削除の必要はないのに、
  変更版を保存しますかと聞かれるので、上記のタイミングで
削除するようにトライしているのですが、うまくいきません。

また、送信時に件名に文字を入れたりするため、
  送信ボタンのあるフォームを作成しているので、
  送信ボタンに組み込んだら、うまく動いたのですが、
  作成者が目視でアドレスが削除されたことを確認したいとの
要望があり、上記希望のタイミングでの動作について
四苦八苦しているところです。

助言よろしくお願いいたします


返信や転送の際の本文に含まれるヘッダーの表示名の横にメールアドレスが表示されるのは、Outlook 2013 の 15.0.4737.1000 以降の新機能です。
この動作を以前のものに戻したい場合は、以下のレジストリ設定を行います。

キー: HKEY_CURRENT_USER\Software\Microsoft\Office\<ver>\Outlook\Options
名前: DisableEmailAddressesInReplyHeaders
種類: REG_DWORD
値: 1

なお、<ver> は Outlook 2013 なら 15.0、Outlook 2016 以降なら 16.0 になります。

参考リンク: Outlook 2013 でメール ヘッダーが、受信者がその電子メール アドレスではなくの表示名にのみが表示されます。

閲覧ウィンドウで表示されているメールの 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

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

アイテムを PDF としてデスクトップに保存するマクロ

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


outlookの仕事の効率化に悩んでおり、教えてください。
PC環境は、win10、outlook2016を使用しております。

選択中のメールをPDF保存(保存先はデスクトップ)をしたいと思っており、クイックアクセスツールバーかマクロで1クリック/ショートカットキー操作でできるようにしたいと思っています。
ちなみに、簡単なExcelマクロは記録機能を改良して作る程度はできますが、Outlookマクロは初心者です。

簡単なやり方だとありがたいです。よろしくお願いします!


以前、表示中のフォルダーのメールを PDF でエクスポートするマクロで、メールを RTF として保存し、それを Word で PDF にエクスポートするという方法を紹介しました。
それを応用することで表示中のメールを PDF として保存することが可能です。
マクロは以下のようになりますので、このマクロをクイック アクセス ツールバーに登録してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub SaveAsPDF()
     Const wdExportFormatPDF = 17
     Dim strFileBase As String
     Dim strFileRTF As String
     Dim strFilePDF As String
     Dim strExportFolder As String
     Dim objFSO As Object 'Scripting.FileSystemObject
     Dim appWord As Object 'Word.Application
     Dim objMail As Object 'MailItem
     Dim docRTF As Object 'Word.document
     Dim c As Integer
     strFileBase = Environ("TEMP") & "\msg"
     strExportFolder = Environ("USERPROFILE") & "\desktop"
     ' Word Application オブジェクトの生成
     Set appWord = CreateObject("Word.Application")
     ' 表示中のアイテムを取得
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objMail = ActiveInspector.CurrentItem
     Else
         Set objMail = ActiveExplorer.Selection(1)
     End If
     ' アイテムがメールだった場合のみ PDF で保存
     If objMail.MessageClass = "IPM.Note" Then
         ' 一時ファイルのファイル名の作成
         strFileRTF = strFileBase & ".rtf"
         ' 保存先 PDF ファイル名の生成
         strFilePDF = strExportFolder & "\msg" & Right("0000" & c, 4) & ".pdf"
         ' ファイルが既に存在する場合は連番を増加
         Set objFSO = CreateObject("Scripting.FileSystemObject")
         While objFSO.FileExists(strFilePDF)
             c = c + 1
             strFilePDF = strExportFolder & "\msg" & Right("0000" & c, 4) & ".pdf"
         Wend
         ' メールを RTF ファイルとして保存
         objMail.SaveAs strFileRTF, olRTF
         ' 保存した RTF ファイルを Word で開く
         Set docRTF = appWord.Documents.Open(strFileRTF)
         ' Word で PDF として保存
         docRTF.ExportAsFixedFormat strFilePDF, wdExportFormatPDF
         docRTF.Close
         Set docRTF = Nothing
         ' RTF ファイルの削除
         Kill strFileRTF
     End If
     ' Word を終了
     appWord.Quit
End Sub

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