Outlook のメール スレッドの管理方法

スレッドを保ったまま任意の文字列を件名のプレフィックスにつけて返信するマクロのコメントにて以下のご要望をいただきました。


こんにちは。
便利に使用させていただいております。
大変ありがとうございます。

さらに便利に使用するため、
下記を解決する方法はありませんでしょうか?

■現状
送信者 件名
Aさん :   テスト送信
私(マクロ使用):  【ABC】: テスト送信
Aさん 受信 : 【ABC】: テスト送信
Aさん 返信 : テスト送信
※Aさんが受信時は付加したテキスト【ABC】が表示されており、
スレッドも維持されているが、されにそのメールに返信しようとすると
私が付加したテキスト【ABC】は存在しない
⇒私がさらに返信する際、同じテキストをまた付加しないといけない

■理想
送信者 件名
Aさん :   テスト送信
私(マクロ使用):  【ABC】: テスト送信
Aさん 受信 : 【ABC】: テスト送信
Aさん 返信(マクロ不使用) :【ABC】: テスト送信
※一度付加されたテキスト【ABC】は、マクロを使用しなくても以降ずっと保持される

※私はOutlook 2016 MSO 16.0.8201.2193 32ビット です。

お手数ですがよろしくお願いいたします。


残念ながら、ご要望の動作はできません。
これは、Outlook のスレッド管理方法に起因しています。

Outlook では、メールのスレッドを管理するために PR_NORMALIZED_SUBJECT というプロパティが使われます。
このプロパティは、件名に含まれる “RE:” や “FW:” を取り除いた文字列を保持するもので、Outlook でスレッドが生成される場合は、PR_NORMALIZED_SUBJECT が同じメールをまとめるという動作になります。
(厳密にはこれ以外のプロパティも使用されます。)

一方、件名に含まれるものの PR_NORMALIZED_SUBJECT に含まれない “RE:” や “FW:” については、PR_SUBJECT_PREFIX という別のプロパティに格納され、スレッドを保ったまま任意の文字列を件名のプレフィックスにつけて返信するマクロではこちらのプロパティに任意の文字列を追加することで、スレッドの保持を実現しています。

マクロを使用せずに返信などを行ったときに文字列を維持する場合には、PR_NORMALIZED_SUBJECT の方に文字列を追加する必要がありますが、PR_NORMALIZED_SUBJECT を変更するとスレッドが維持できなくなり、当初の目的が果たせなくなります。
したがって、スレッドを維持する必要があるなら、マクロを使い続ける必要があるということになります。

広告

本文中に含まれる UNC のフォルダー内のファイルをすべて添付するマクロ

添付ファイルをディスクに保存し、そのファイルへのリンクをメッセージ本文に書き込むマクロのコメントにて以下のご要望をいただきました。


逆のことはできますか?
社内ネットワーク環境下で、メールに共有フォルダのリンクがはられたものが届きます、共有フォルダ内には複数のファイルがあるのですが、フォルダ共有されていない人にメール転送するのに、わずかながら手間がかかります。


メールの本文の共有フォルダーのリンク (UNC) に含まれるファイルをすべて添付する場合、以下の 2 つの作業が必要になります。

  • 本文中の UNC を取得する
  • UNC のフォルダーのファイルを添付する

本文からの UNC の取得には WordEditor プロパティとして取得できる Word の Document オブジェクトが使えるのですが、元のメールが HTML 形式の場合とテキスト形式の場合で取得方法が異なります。

まず、HTML 形式の場合、UNC がハイパーリンクになっているため、Document オブジェクトの Hyperlinks コレクションから Hyperlink オブジェクトとして取り出し、その Address プロパティにより UNC の文字列が取得可能です。

一方、テキスト形式の場合は、本文中の UNC がハイパーリンクになっていない場合があり、UNC の識別がマクロでは困難となるので、手作業で選択された文字列を取得するような処理が必要となります。
選択された文字列は WordEditor の Parent プロパティで取得できる Word の Application オブジェクトの Selection.Text で取得可能です。

UNC の文字列を取得した後は、VBA の Dir 関数でフォルダーに含まれるファイルの名前を取得し、MailItemAttachments コレクションの Add メソッドでそのファイルを添付します。

マクロは以下のようになります。
HTML 形式のように UNC がハイパーリンクになっているなら AddFilesFromLink を実行し、リンクになっていなければ UNC の文字列を選択した後で AddFilesFromSelected を実行します。

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

' 本文中でハイパーリンクになっている UNC のファイルを添付するマクロ
Public Sub AddFilesFromLink()
     On Error Resume Next
     AddFilesInAFolder ActiveInspector.WordEditor.Hyperlinks(1).Address
End Sub
' 本文中で選択した UNC のファイルを添付するマクロ
Public Sub AddFilesFromSelected()
     On Error Resume Next
     AddFilesInAFolder ActiveInspector.WordEditor.Parent.Selection.Text
End Sub
' UNC のファイルを添付するサブプロシージャ
Private Sub AddFilesInAFolder(strFolder As String)
     Dim i As Integer
     Dim objItem As MailItem
     Dim strFileName As String
    ' 渡されたフォルダーが空文字列なら何もせず終了
     If strFolder = "" Then
         Exit Sub
     End If
     ' フォルダー名の最後に余分なスペースや改行があったら削除
     For i = Len(strFolder) To 1 Step -1
         Select Case Mid(strFolder, i, 1)
             Case vbCr, vbLf, vbTab, " "
                 strFolder = Left(strFolder, i - 1)
             Case Else
                 Exit For
         End Select
     Next
    ' 表示中のアイテムを取得
     Set objItem = ActiveInspector.CurrentItem
    ' Dir 関数によりフォルダー中のファイルを取得
     strFileName = Dir(strFolder & "\*.*")
    ' フォルダーのファイルをすべて添付するまで繰り返し
     While strFileName <> ""
        ' ファイルを添付
         objItem.Attachments.Add strFolder & "\" & strFileName
        ' 次のファイルを取得
         strFileName = Dir()
     Wend
End Sub

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

今月から 3 か月分の予定表を定期的に ics ファイルに保存し、自動で特定のアドレスに送信するマクロ

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


管理人様

2016年1月30日の「予定表を定期的に ics ファイルに保存し、自動で特定のアドレスに送信するマクロ」の記事についてのお願いです。

マクロは動作しましたが、過去数年間の予定表データが膨大で管理人様がおっしゃられている通りデータ抽出にとても時間がかかっています。

お願いですが、現在より1ヶ月先あるいは2ヶ月先のデータを抽出、自動メール送信するマクロを作成いただけませんでしょうか。

ご検討のほど、よろしくお願いいたします。

当方動作環境

windows7、outlook2010


予定表にあるアイテムを特定の範囲で制限したい場合、Items オブジェクトの Restrict メソッドを使用します。
日付範囲で Restrict メソッドの条件を指定する場合、以下のようなものになります。

    アイテムの開始日時 < 範囲の終了 AND アイテムの終了日時 >= 範囲の開始

ちょっとややこしいのが、開始日時と範囲の終了、終了日時と範囲の開始を比較するという点です。
これは、範囲の境をまたぐような予定も含めるためです。

また、指定された期間の予定でフィルターするとなると、[開始日] や [終了日] でのフィルターすると考えてしまいますが、これらのプロパティでは繰り返しの予定が正しく取得できません。
例えば、10/1 から 3 か月繰り返すという予定の場合、予定アイテム自体の [開始日] や [終了日] は 10/1 となるので、実際には繰り返しの予定の一部が 11/1 以降にあっても、11/1 以降に終了する予定という条件には合致しなくなってしまいます。
そこで、繰り返しの予定を考慮する場合、条件としては [繰り返し期間の開始] と [繰り返し期間の終了] を使用します。
なお、繰り返しではない予定については繰り返し期間の開始と終了にはそのアイテム自体の開始日と終了日が設定されます。

これらを考慮したマクロは以下の通りです。

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

' 定期実行のためのタスクの件名
Const CALSEND_ITEM = "予定表自動送信タスク"
' iCal を送信するメールの件名
Const MSG_SUBJECT = "予定表送信"
' iCal を送信するメールの本文
Const MSG_BODY = "予定表を送信します"
' iCal を送信するメールの宛先
Const MSG_TO = "user1@example.com"
' iCal のローカル保存用ファイル名
Const ATT_FILE = "c:\temp\予定表.ics"
' iCal 作成の作業ファイル名
Const TEMP_FILE = "c:\temp\~temp~.ics"
'
' 起動時に自動実行されるルーチン
Private Sub Application_Startup()
     Dim fldTask As Folder
     Dim objTask As TaskItem
     Set fldTask = Session.GetDefaultFolder(olFolderTasks)
     ' 自動送信タスクの検索
     Set objTask = fldTask.Items.Find("[件名]='" & CALSEND_ITEM & "'")
     If objTask Is Nothing Then
         ' 自動送信タスクが存在しなければ作成
         Set objTask = fldTask.Items.Add
         objTask.Subject = CALSEND_ITEM
     End If
     ' 自動送信タスクのアラームを 1 日後に設定
     objTask.ReminderTime = DateAdd("d", 1, Now)
     objTask.ReminderSet = True
     objTask.Save
     ' iCal 送信
     SendMyCalendar
End Sub
'
' アラーム表示で実行されるルーチン
Private Sub Application_Reminder(ByVal Item As Object)
     ' 自動送信タスクだったら
     If Item.Subject = CALSEND_ITEM Then
         ' 一時的にアラームをオフ
         Item.ReminderSet = False
         Item.Save
         ' 自動送信タスクのアラームを 1 日後に設定
         Item.ReminderTime = DateAdd("d", 1, Now)
         Item.ReminderSet = True
         Item.Save
         ' iCal 送信
         SendMyCalendar
     End If
End Sub
'
' 予定表を iCal で送信するルーチン
Public Sub SendMyCalendar()
     On Error Resume Next
     ' ADO の定数設定
     Const adTypeText = 2
     Const adTypeBinary = 1
     Const adSaveCreateOverWrite = 2
     ' 送信する月の数を設定
     Const MONTH_SPAN = 3
     '
     Dim fldCalendar As Folder
     Dim strStart As String
     Dim strEnd As String
     Dim colAppts As Items
     Dim oneAppt As AppointmentItem
     Dim stmWrite 'As ADODB.Stream
     Dim stmRead 'As ADODB.Stream
     Dim strText As String
     Dim binIcs As Variant
     Dim msgSend As MailItem
     ' UTF-8 で iCal ファイルを作成するためのストリーム作成
     Set stmWrite = CreateObject("ADODB.Stream")
     With stmWrite
         .Type = adTypeText
         .Charset = "UTF-8"
         .Open
         ' iCal のヘッダーを書き込み
         .WriteText "BEGIN:VCALENDAR" & vbCrLf
         .WriteText "PRODID:-//Microsoft Corporation//Outlook 12.0 MIMEDIR//EN" & vbCrLf
         .WriteText "VERSION:2.0" & vbCrLf
         .WriteText "METHOD:PUBLISH" & vbCrLf
         .WriteText "X-WR-CALNAME:" & Session.CurrentUser & vbCrLf
     End With
     ' 既定の予定表を取得
     Set fldCalendar = Session.GetDefaultFolder(olFolderCalendar)
     ' 今日の日付から MONTH_SPAN で設定された範囲を設定
     strStart = Format(Now, "yyyy/mm/01 0:00")
     strEnd = Format(DateAdd("m", MONTH_SPAN, strStart), "yyyy/mm/01 0:00")
     ' アイテムをフィルターする
     Set colAppts = fldCalendar.Items.Restrict("[繰り返し期間の開始] < '" & strEnd & "' AND [繰り返し期間の終了] > '" & strStart & "'")
     ' フィルターした予定アイテムを処理
     For Each oneAppt In colAppts
         Err.Clear
         ' 単一のアイテムを iCal として保存
         oneAppt.SaveAs TEMP_FILE, olICal
         If Err.Number = 0 Then
             ' iCal ファイルを UTF-8 として読み込む
             Set stmRead = CreateObject("ADODB.Stream")
             With stmRead
                 .Type = adTypeText
                 .Charset = "UTF-8"
                 .Open
                 .LoadFromFile TEMP_FILE
                 strText = .ReadText
                 .Close
             End With
             ' iCal データのうち VEVENT の部分だけ抜きとり
             strText = Mid(strText, InStr(strText, "BEGIN:VEVENT"))
             strText = Left(strText, InStr(strText, "END:VCALENDAR") - 1)
             ' 送信用 iCal ファイルへ書き込み
             stmWrite.WriteText strText ' adWriteChar
         End If
         DoEvents
     Next
     '
     With stmWrite
         ' iCal ファイルの終わりを書き込み
         .WriteText "END:VCALENDAR" & vbCrLf
         ' iCal ファイルの保存
         .SaveToFile ATT_FILE, adSaveCreateOverWrite
         .Close
     End With
     ' iCal ファイルを添付してメールを送信
     Set msgSend = CreateItem(olMailItem)
     msgSend.Subject = MSG_SUBJECT
     msgSend.Body = MSG_BODY
     msgSend.To = MSG_TO
     msgSend.Attachments.Add ATT_FILE
     msgSend.Send
End Sub

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

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

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

Office 2016

Outlook 2016 の修正

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

Office 2013

Outlook 2013 の修正

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

Office 2010

Outlook 2010 の修正

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

VBA マクロにおける Application オブジェクト

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


いつも大変に参考にさせて頂いております。
Outlookからメールを作成し、その際ファイルを選択するダイアログボックスを表示させ、選択したファイルをメールに添付させるマクロを考えております。
同様のマクロはExcelから作成できていたのですが、そのマクロをOutlook側で使用しようとしたところ、ファイルを選択するところで使用している以下のコードでエラーとなってしまいました。
OpenFileName = Application.GetOpenFilename(“Microsoft Excelブック,*.xlsx”)

捕捉しますと処理の流れは
①メール作成
②Application.GetOpenFilenameでファイル選択
③メールに添付
というのが大まかな流れです。

OutlookのマクロではApplication.GetOpenFilenameが利用できないのかなと勝手に推測しているのですが、代替コードなどありましたらご教示頂けますと幸いです。
宜しくお願い致します。


VBA で Application オブジェクトはそのマクロを実行しているプログラムを意味します。

そのため、Excel 上でマクロを実行しているときの Application は Excel ですが、Outlook 上では Application は Outlook となり、Outlook の Application オブジェクトには GetOpenFilename というメソッドがないためエラーになります。

Outlook で Excel の Application の機能を呼び出したいときには、以下のようにします。


Set appExcel = CreateObject("Excel.Application")
OpenFileName = appExcel.GetOpenFilename("Microsoft Excel ブック,*.xlsx")

テキスト ファイルに記載された深い階層のフォルダーを一度に作成するマクロ

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


お世話になっております。以前に “https://outlooklab.wordpress.com/2016/10/22/深い階層のフォルダーを一度に作成するマクロ/” で質問させていただきました。

前回質問させていただいた内容を応用し、フォルダー A のサブフォルダーとして作成したサブフォルダー B に対し、サブフォルダー B の配下にサブフォルダー B1 とか B2 など、並列した複数のサブフォルダーを一括作成したいと考えています。
また、同様に、フォルダー A のサブフォルダーとしてサブフォルダー C を作成し、さらに、サブフォルダー C の配下にサブフォルダー C1 とか C2 を作成したいと考えています。

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


複数のフォルダーを一括作成ということとなると、そのフォルダーをまとめて指定する必要があります。
今回はテキストファイルに以下のように記述しておき、現在選択しているフォルダーの下にサブフォルダーを作成するマクロにしてみました。

A\B\B1
A\B\B2
A\C\C1
A\C\C2

テキストファイルのファイル名はマクロ冒頭の FOLDER_PATH_FILE で指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub CreateDeepSubFolderInFile()
     On Error Resume Next
     Const FOLDER_PATH_FILE = "c:\temp\folderpath.txt"
     Dim fldRoot As Folder
     Dim fldSub As Folder
     Dim strPath As String
     Dim astrFolders As Variant
     Dim strSub As Variant
     '
     Open FOLDER_PATH_FILE For Input As #1
     While Not EOF(1)
         Line Input #1, strPath
         If strPath <> "" Then
             astrFolders = Split(strPath, "\")
             Set fldRoot = ActiveExplorer.CurrentFolder
             For Each strSub In astrFolders
                 Set fldSub = Nothing
                 Set fldSub = fldRoot.Folders(strSub)
                 If fldSub Is Nothing Then
                     Set fldSub = fldRoot.Folders.Add(strSub)
                 End If
                 Set fldRoot = fldSub
             Next
         End If
     Wend
     Close #1
End Sub

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

メールに含まれる URL のファイルをマイ ドキュメントに保存するマクロ

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


いつもご教授いただき、ありがとうございます。

紙面上の内容をイントラ にアップするための作業を
outlook VBAで対処できるか教えてください。

具体的な作業としては、
①スキャナー(URL送信)で紙面上の内容を取り込む 
②メールを開いて、本中のURLを開き、PDFをマイドキュに保存
しています。

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


上記の 1 についてはスキャナーから自動的に URL が記載されたメールが送信されてくるということでしょうか?
となると、VBA で実装するのは 2 だけになりますね。
メール本文から URL を取得するには MailItem オブジェクトの Body プロパティを使用します。
このプロパティについて InStr 関数により URL の先頭となる http:// という文字列を検索し、URL の終わりとなるような文字までを取得します。
こうして取得した URL をダウンロードしてファイルに保存するには、Windows の URLDownloadFileA という API が使用できます。
マクロとして現在表示中のメールの URL をダウンロードする DownloadFileInBody と表示中のフォルダー内のすべてのメールの URL を一括ダウンロードする DownloadFileInCurrentFolder を作ってみました。

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

'   URL のファイルをダウンロードする API
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
     "URLDownloadToFileA" ( _
     ByVal pCaller As Long, _
     ByVal szURL As String, _
     ByVal szFileName As String, _
     ByVal dwReserved As Long, _
     ByVal lpfnCB As Long) As Long
'   表示中のメールの URL をダウンロードするプロシージャ
Public Sub DownloadFileInBody()
     Dim objMail As mailItem
     ' 表示しているウィンドウによりメールを判断
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set objMail = ActiveInspector.CurrentItem
     Else
         Set objMail = ActiveExplorer.Selection(1)
     End If
     ' 表示しているメールのダウンロード
     DownloadFileInBodyCore objMail
End Sub
'   表示中のフォルダー内のメールの URL を一括ダウンロード
Public Sub DownloadFileInCurrentFolder()
     Dim fldCurrent As Folder
     Dim objMail As mailItem
     ' 表示中のフォルダーを取得
     Set fldCurrent = ActiveExplorer.CurrentFolder
     ' フォルダー内のメールすべてについて処理
     For Each objMail In fldCurrent.Items
         ' 一つのメールのダウンロード
         DownloadFileInBodyCore objMail
     Next
End Sub
'   メール内の URL を取得してダウンロードするプロシージャ
Private Sub DownloadFileInBodyCore(ByVal objMail As mailItem)
     Dim strBody As String
     Dim iStart As Integer
     Dim iEnd As Integer
     Dim strUrl As String
     Dim strFile As String
     Dim wshShell As Variant
     Dim strMyDoc As String
     ' 本文を取得
     strBody = objMail.Body
     ' URL の検索
     iStart = InStr(strBody, "http" & "://")
     ' URL が見つかったら
     If iStart > 0 Then
         ' URL の終わりを検索
         For iEnd = iStart To Len(strBody)
             Select Case Mid(strBody, iEnd, 1)
                 ' スペース、タブ、改行 " > を URL の終端とする
                 Case " ", vbTab, vbCr, """", ">"
                     Exit For
             End Select
         Next
         ' 本文から URL を取得
         strUrl = Mid(strBody, iStart, iEnd - iStart)
         ' URL からファイル名を取得
         strFile = Mid(strUrl, InStrRev(strUrl, "/") + 1)
         ' ファイル名に ? が含まれていたら _ に置換
         strFile = Replace(strFile, "?", "_")
         ' マイ ドキュメント フォルダーを取得
         Set wshShell = CreateObject("WScript.Shell")
         strMyDoc = wshShell.SpecialFolders("MyDocuments")
         ' URL のファイルをダウンロード
         URLDownloadToFile 0, strUrl, strMyDoc & "\" & strFile, 0, 0
     End If
End Sub

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