受信したメールを自動的に MSG ファイルとして保存するマクロ

受信したメールの添付ファイルを自動保存するマクロのコメントにて以下のご要望をいただきました。


お世話になります。

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

受信をトリガーとし、メール自体を.msgファイルとして保存する場合はどのようになるのでしょうか?


メール自体を保存する場合は、MailItem オブジェクトの SaveAs メソッドを使用します。
件名をファイル名にする場合、件名には \ や :、* などファイル名に使用できない文字が含まれる場合があるため、それを別の文字に置き換える必要があります。
以下のマクロでは受信時のイベントで SaveAsMsg というプロシージャを呼び出し、その中で条件判定をするようにしていますが、条件判定のための記述がよくわからないというようであれば、SaveAsMsg だけをマクロとして定義し、自動仕分けのルールのスクリプトとして SaveAsMsg を呼び出すようにすれば、条件判定をルールの設定でできるようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     On Error Resume Next
     Dim objItem As Object
     Dim objMsg As MailItem
     ' 受信アイテムを取得
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     ' アイテムがメールだったら保存処理
     If TypeName(objItem) = "MailItem" Then
         Set objMsg = objItem
         SaveAsMsg objMsg
     End If
End Sub
  '
  ' MSG ファイルとして保存するサブ プロシージャ
Public Sub SaveAsMsg(ByRef objMsg As MailItem)
     ' ファイルを保存するフォルダーを指定。最後に \ が必要
     Const SAVE_PATH = "C:\temp\"
     Dim objFSO As Object ' FileSystemObject
     Dim strSubject As String
     Dim strFileBase As String
     Dim strFileName As String
     Dim i As Integer
     Dim ch As String
     Dim c As Integer
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
'
' ここで条件指定
' 例えば、test という文字列を件名に含むものだけ保存する場合、
' 「test を件名に含まない場合に Exit Sub」というコードにする
'
'  If Not (objMsg.Subject Like "*test*") Then Exit Sub
'
     ' 件名をファイル名にする
     strSubject = objMsg.Subject
     ' 件名の前に受信日時をつける場合は以下を使用
     ' strSubject = objMsg.ReceivedTime & " " & objMsg.Subject
     ' 件名の前に差出人をつける場合は以下を使用
     ' strSubject = objMsg.SenderName & " " & objMsg.Subject
     ' ファイル名に使用できない文字を _ に置き換える
     strFileBase = ""
     For i = 1 To Len(strSubject)
         ch = Mid(strSubject, i, 1)
         If InStr("\/:*?""<>|", ch) > 0 Then
             ch = "_"
         End If
         strFileBase = strFileBase & ch
     Next
     '
     strFileName = SAVE_PATH & strFileBase & ".msg"
     '
     c = 1
     ' 同名のファイルが存在したら
     While objFSO.FileExists(strFileName)
         ' ファイル名に -連番 をつける
         strFileName = SAVE_PATH & strSubject & "-" & c & ".msg"
         c = c + 1
     Wend
     ' MSG ファイルとして保存する
     objMsg.SaveAs strFileName, olMSG
     Set objFSO = Nothing
End Sub

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

広告

返信・転送の際に引用部分の宛先とCCを削除するマクロ

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


コメント

Outlookでメールを返信・転送する際に,元のメッセージに

宛先・CCがズラリならんでいて生産性が悪いです。

返信・転送の際に元のメッセージを引用する場合に,

元のメッセージ中の宛先・CCを削除するマクロはありませんか。


返信や転送を行うメッセージの本文から宛先と Cc を削除するというのは意外と手間がかかる処理になります。
そのため、実際に返信や転送を行うメッセージとは別に、受信者情報を削除したアイテムから返信・転送メッセージを生成し、その本文をコピーしてしまえば、ヘッダーに宛先や Cc がない状態のメッセージが生成できます。
マクロにすると以下のようなものになります。
返信するときは ReplyWithoutHeader を、転送するときは ForwardWithoutHeader を実行してください。

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

' ヘッダーの宛先、CC を削除して返信するマクロ
Public Sub ReplyWithoutHeader()
     ReplyOrForwordWOHeader False
End Sub
' ヘッダーの宛先、CC を削除して転送するマクロ
Public Sub ForwardWithoutHeader()
     ReplyOrForwordWOHeader True
End Sub
' 返信・転送をする処理のメイン
Private Sub ReplyOrForwordWOHeader(bForward As Boolean)
     ' 元のアイテム
     Dim itmOrg As MailItem
     ' 返信、転送するアイテム
     Dim itmReFw As MailItem
     ' 宛先・CC を削除するアイテム
     Dim itmForBody As MailItem
     Dim i As Integer
     ' 現在表示中のウィンドウに応じてアイテムを取得
     If TypeName(ActiveWindow) = "Inspector" Then
         Set itmOrg = ActiveInspector.CurrentItem
     Else
         Set itmOrg = ActiveExplorer.Selection(1)
     End If
     ' 返信、転送アイテムを作成
     If bForward Then
         Set itmReFw = itmOrg.Forward
     Else
         Set itmReFw = itmOrg.ReplyAll
     End If
     ' 元のアイテムのすべての受信者を削除
     With itmOrg.Recipients
         For i = .Count To 1 Step -1
             .Remove i
         Next
     End With
     ' 受信者を削除してから本文取得用の返信・転送アイテムを生成
     If bForward Then
         Set itmForBody = itmOrg.Forward
     Else
         Set itmForBody = itmOrg.ReplyAll
     End If
     ' 受信者を削除したアイテムは編集を破棄
     itmOrg.Close olDiscard
     ' 本文形式に応じてヘッダーを削除した本文をコピー
     Select Case itmReFw.BodyFormat
         Case olFormatPlain
             itmReFw.Body = itmForBody.Body
         Case olFormatHTML
             itmReFw.HTMLBody = itmForBody.HTMLBody
         Case olFormatRichText
             itmReFw.RTFBody = itmForBody.RTFBody
     End Select
     ' 本文をコピーしたらアイテムは破棄
     itmForBody.Close olDiscard
     ' 返信、転送アイテムを表示
     itmReFw.Display
End Sub

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

Outlook 2016/2013/2010 の累積的な修正プログラム 2018 年 5 月分がリリース

5/1 に Outlook 2016、Outlook 2013 および Outlook 2010 の累積的な修正プログラムがリリースされました。
今回の Outlook 2016 と 2013 の修正には Large Address Aware への対応が含まれています。
これにより、64 ビット Windows 上の 32 ビットの Outlook でメモリが 4G まで使えるようになります。
Outlook で頻繁にメモリ不足が発生していたり、画面描画が乱れたりしているようであれば、この修正の適用で状態が改善される可能性があります。

以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

2018、5 月 1日が Outlook 2016 (KB4018372) の更新します。
11 件の不具合修正が行われています。

Office 2013

Outlook 2013 の修正

2018、5 月 1日は、Outlook 2013 (KB4018376) の更新します。
5 件の不具合修正が行われています。

h3>Office 2010

Outlook 2010 の修正

2018、5 月 1日は、Outlook 2010 (KB4022144) の更新します。
1 件の不具合修正が行われています。

件名や本文に特定の文字列を含む場合に送信を阻止するマクロ

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


いつも参考にさせていただいています。
Outlook2016を使用していますが、メールの送信についての質問です。

作成したメールで「件名、本文」に特定の文字が存在している時に送信しない( or エラーメッセージ)を出す方法を探しています。

やりたい事は以下のとおりです。
① メールのテンプレートで作成毎に変わる所を「○○○」とする(相手の名前、会社名、来訪日など)
② メールを書くときはテンプレートで新規作成をして日にちや相手に合わせて「○○○」の所を手動で変更する
③ 「○○○」が「件名、本文」に存在する時は、メール内容に不備があるとしてメールを送らない

とこんな感じです。

以前は前の文章をコピペしていましたが、見落としで会社名や人の名前、
日付が前のままになっていて大問題になってしまったので。

どうぞよろしくお願いします。


メールの送信時に件名や本文などをチェックし、送信をキャンセルするには Application オブジェクトの ItemSend イベントを使用します。
ItemSend イベントの中で Cancel に True を設定すると、送信をキャンセルすることができます。
また、件名や本文に特定の文字列があるかどうかのチェックには InStr 関数を使用します。
InStr 関数は InStr( 検索対象, 検索文字列 ) のように指定すると、検索文字列が見つかった位置を返すもので、この関数が 0 より大きい値を返した場合は、検索文字列が含まれていると判断できます。
マクロは以下のようになります。

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

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     ' チェックする文字列を指定
     Const NG_WORD = "○○○"
     ' 件名か本文に問題の文字列が含まれるかを確認
     If InStr(Item.Subject, NG_WORD) > 0 Or InStr(Item.Body, NG_WORD) > 0 Then
         ' 含まれていたらエラーを表示
         MsgBox NG_WORD & "が残っています。"
         ' 送信をキャンセル
         Cancel = True
     End If
End Sub

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

予定表を Excel ファイルにエクスポートし、Excel ファイルの変更をインポートするマクロ

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


いつもお世話になります。
  会社でクライアント側(windows7 &Outlook2013) & Exchangeサーバー環境で使用しています。
貴サイトの「複数フォルダーに格納されている特定の件名のメールの情報を Excel ファイルにエクスポートするマクロ」, 「メールの内容を Excel ファイルにかき出すマクロ」
などで紹介されているマクロをアレンジし、カレンダーアイテムやToDoアイテムの情報をExcelに一覧表形式にして出力さるマクロを試作しました(出力させる情報にCoversation ID, Entry IDが含まれます)。

Excelに書き出させるだけなので、情報を修正するときはOutlookに戻る必要があります。
せめて、Message ID, Coversation ID, Entry IDなど、ユニークに割り当てられるIDでアイテムを検索して表示させたいのですが、簡単な方法はあるでしょうか(該当するアイテムがメールフォルダ、スケジュール、ToDoにあるのかわからない前提で)。

【追伸】
もしくは、Excelに書き出された情報(日時、内容、完了のステータス等)を修正したらそれをOutlook側に反映させることができればもっと良いです

よろしくご教示ください


Outlook オブジェクト モデルの GetItemFromID メソッドを使用すると、一意のエントリー ID からアイテムを取得することができます。
このメソッドはアイテムがどのフォルダーにあるのかは意識せずに取得できますので、Excel にエクスポートする際にエントリー ID もエクスポートし、インポートの際にはそれを使って変更を取り込むという方法で実現は可能でしょう。

ただし、該当するアイテムがメール フォルダーにある場合と予定表にある場合とではインポートできるプロパティなどに違いが生じるため、インポートされるアイテムの種類ごとにマクロを用意する必要があると思います。

参考までに予定表をエクスポート・インポートするマクロを作ってみました。
なお、編集したものを再び取り込むという処理を考えた場合、繰り返しのアイテムは正しく処理することが難しいため、繰り返しアイテムはエクスポートしません。
また、予定アイテムについてはマクロでは本文のテキスト データしか取得ができないため、文字に色を付けていたり画像を埋め込んでいたような場合には、それらが失われます。

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

' エクスポートする Excel ファイルの指定
Const EXCEL_FILE = "c:\temp\calendar.xlsx"
'
' エクスポートするマクロ
'
Public Sub ExportCalendarWithEID()
     Dim appExcel 'As Excel.Application
     Dim objBook 'As Excel.Workbook
     Dim objSheet 'As Excel.Worksheet
     Dim fldCalendar As Folder
     Dim apptItem As AppointmentItem
     Dim iRow As Integer
     ' Excel を起動
     Set appExcel = CreateObject("Excel.Application")
     ' ワークブックを追加
     Set objBook = appExcel.Workbooks.Add()
     ' ワークブックのワークシート 1 を取得
     Set objSheet = objBook.Sheets(1)
     ' 先頭行に項目名を追加
     With objSheet
         .Cells(1, 1) = "EntryID"
         .Cells(1, 2) = "件名"
         .Cells(1, 3) = "場所"
         .Cells(1, 4) = "開始日時"
         .Cells(1, 5) = "終了日時"
         .Cells(1, 6) = "分類項目"
         .Cells(1, 7) = "本文"
     End With
     ' データは 2 行目から
     iRow = 2
     ' 予定表フォルダーを取得
     Set fldCalendar = Session.GetDefaultFolder(olFolderCalendar)
     ' 予定表フォルダーのすべてのアイテムについて取得
     For Each apptItem In fldCalendar.Items
         ' 繰り返しの予定は除外する
         If Not apptItem.IsRecurring Then
             ' ワークシートに予定アイテムのプロパティをコピー
             With objSheet
                 .Cells(iRow, 1) = apptItem.EntryID
                 .Cells(iRow, 2) = apptItem.Subject
                 .Cells(iRow, 3) = apptItem.Location
                 .Cells(iRow, 4) = apptItem.Start
                 .Cells(iRow, 5) = apptItem.End
                 .Cells(iRow, 6) = apptItem.Categories
                 .Cells(iRow, 7) = apptItem.Body
             End With
             ' 次の行に移動
             iRow = iRow + 1
         End If
     Next
     ' ファイル名を付けて保存
     objBook.SaveAs EXCEL_FILE
     objBook.Close
     appExcel.Quit
End Sub
'
' インポートするマクロ
'
Public Sub ImportCalendarWithEID()
     On Error Resume Next
     Dim objBook 'As Excel.Workbook
     Dim objSheet 'As Excel.Worksheet
     Dim iRow As Integer
     Dim strEID As String
     Dim apptItem As AppointmentItem
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     ' ワークシート 1 を取得
     Set objSheet = objBook.Sheets(1)
     ' データは 2 行目から
     iRow = 2
     '
     With objSheet
         ' 1 列目が空白でない限り繰り返し
         While .Cells(iRow, 1) <> ""
             ' 1 列目をエントリー ID として取得
             strEID = .Cells(iRow, 1)
             ' エントリー ID でアイテムを取得
             Set apptItem = Session.GetItemFromID(strEID)
             ' エラーが発生していなければセルの値をプロパティにコピー
             If Err.Number = 0 Then
                 apptItem.Subject = .Cells(iRow, 2)
                 apptItem.Location = .Cells(iRow, 3)
                 ' 変更後の開始が変更前の終了より後なら終了を先に設定
                 If apptItem.End < .Cells(iRow, 4) Then
                     apptItem.End = .Cells(iRow, 5)
                     apptItem.Start = .Cells(iRow, 4)
                 Else
                     apptItem.Start = .Cells(iRow, 4)
                     apptItem.End = .Cells(iRow, 5)
                 End If
                 apptItem.Categories = .Cells(iRow, 6)
                 apptItem.Body = .Cells(iRow, 7)
                 apptItem.Save
             Else
                 Err.Clear
             End If
             ' 次の行に移動
             iRow = iRow + 1
         Wend
     End With
     objBook.Application.Quit
End Sub

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

マクロやアドインで送信トレイにあるメールの送信がキャンセルされる

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


はじめて投稿させていただきます。
どうぞ、よろしくお願いいたします。

ThinkPad X230
  Intel Core i7-3520M CPU 2.90 GHz
  RAM 4.00 GB
  Windows 7 SP1 (32 bit)

Outlook 2013

といった環境です。

メールの返信、全員への返信、転送、のときに、
  本文を Plain Text で編集送信できるよう、
  見様見真似で下のようなコードを書きました。

概ねうまく動いているのですが、
1. メール編集
2. 送信ボタン
3. 送信トレイで内容確認
4. 送信ボタン

と、やったときに、送信トレイ内のメール一覧のところで

日付: なし

となり、「送受信」の操作を行っても
  メールが送信されなくなってしまいます。

((各々のメールで送信ボタンを押しても、
すぐにはメールが送信されない設定にして
  あります))

どうも、下のコードの

Private Sub oExpl_SelectionChange()

に、問題があるらしく、

Set oItem = oExpl.Selection.Item(1)
にブレークポイントを入れて、止めておいた状態で

「送受信」の操作

を行うと、メールが送信されます。

ここに、何か条件分岐のコードを入れれば良いように思うのですが、
  見様見真似でありますため、どうすれば良いのか、
さっぱりわかりません。

どうか、ご教示のほど、よろしくお願いいたします。

<<コード省略>>


Private Sub oExpl_SelectionChange() ‘☆どうもここが問題らしいです☆

On Error Resume Next

If oExpl.CurrentFolder.Name = “送信トレイ” Then ‘挿入
Exit Sub ‘挿入
End If ‘挿入

Set oItem = oExpl.Selection.Item(1)

End Sub

で、とりあえず使っております。

上手くいっているようですが、これで、いいんでしょうか。


はい。この対応で問題ありません。

ご質問の動作は、Outlook オブジェクト モデルにより送信トレイにあるアイテムを参照すると、送信処理がキャンセルされるという仕様により発生します。
特定のプロパティにアクセスしたらというようなことではなく、Outlook オブジェクト モデルを使用してアイテムのオブジェクトを取得するという処理をしただけで、送信がキャンセルされます。(ただし、送信トレイのアイテムが送信処理の最中であれば、キャンセルされるのではなくアイテムの取得に失敗します。)

そのため、送信トレイのアイテムは不用意にアクセスしないようにする必要があります。
例えば、アイテムのプレビューなどでも送信がキャンセルされることになるので、送信トレイでは閲覧ウィンドウがオンにできないようになっています。

すでに実装されている「フォルダー名が “送信トレイ” の場合にはアイテムへのアクセスを行わない」という条件分岐でも対応可能ですが、例えば PST にある “送信トレイ” フォルダーではアイテムにアクセスさせたいというような要件があるなら、以下の条件分岐の方が確実でしょう。

If oExpl.CurrentFolder.EntryID = Session.GetDefaultFolder(olFolderOutbox).EntryId Then

選択した範囲を引用して返信するマクロ

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


はじめまして。

OUTLOOKのメールにおいて
返信時に
受信メール内の特定テキストを
選択
  別位置にペースト
文頭に特定に頭文字(>等)追加
  文字の色を変更
  貼付け
  ということをしています。
※元の文章を引用したいが区別したいため

マクロで
選択部分のテキストを選択した状態で
右Clickメニューからマクロを選択すると
文頭に特定に頭文字(>等)追加
  文字の色を変更
クリップボードに保存
を実現する事はできますでしょうか?

返信コマンド時に受信分全部を
文頭に特定に頭文字(>等)追加
  文字の色を変更
も考えられると思うのですが
過去のやり取りが同じ文字となってしまうので
上記の様な方法が可能であればうれしいのですが


Inspector オブジェクトの WordEditor プロパティを使うと、Outlook が本文の編集に使用している Word のオブジェクトを取得できます。
そして、この Word のオブジェクトを使用すれば、選択された範囲の文字列を取得したり、クリップボードなどを使わずに返信メールに文字列を挿入したりといったことが可能になります。
残念ながら選択範囲を右クリックでマクロを実行することはできませんが、文字列を選択した後でクイックアクセス ツール バーなどに登録した下記のマクロを実行することで、ご要望の動作は実現可能と思われます。

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

Public Sub ReplyWithQuotingSelected()
     ' 引用記号の指定
     Const QUOTE_SYM = "> "
     ' 引用する文字列の色 (https://msdn.microsoft.com/ja-jp/vba/word-vba/articles/wdcolor-enumeration-word 参照)
     Const QUOTE_COLOR = 16711680 ' wdColorBlue
     Dim docBody As Object ' Word.Document
     Dim strSel As String
     Dim msgReply As MailItem
     Dim docReply As Object ' Word.Document
     ' 表示しているメールの WordEditor を取得
     Set docBody = ActiveInspector.WordEditor
     ' 選択範囲の文字列を取得
     strSel = QUOTE_SYM & docBody.Application.Selection.Text
     ' 選択範囲の行の頭に引用記号を追加
     strSel = Replace(strSel, vbCr, vbCr & QUOTE_SYM)
     ' 選択範囲の最後が改行の場合は最後の引用記号を削除
     If strSel Like "*" & QUOTE_SYM Then
         strSel = Left(strSel, Len(strSel) - Len(QUOTE_SYM))
     End If
     ' 返信メールを作成
     Set msgReply = ActiveInspector.CurrentItem.ReplyAll
     ' 色を付けるため HTML 形式を設定
     msgReply.BodyFormat = olFormatHTML
     ' メールを表示
     msgReply.Display
     ' 返信メールの WordEditor を取得
     Set docReply = msgReply.GetInspector.WordEditor
     ' 返信メール本文の先頭に移動
     docReply.Range(0, 0).Select
     With docReply.Application.Selection
         ' 引用部分の前に 1 行あける
         .MoveDown
         ' 引用部分の色を指定
         .Font.Color = QUOTE_COLOR
         ' 引用文字列を挿入
         .Text = strSel
     End With
End Sub

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