メールのスレッドを保持してExcelにエクスポートするマクロ (エイリアス バージョン)

メールのスレッドを保持してExcelにエクスポートするマクロのコメントにて以下のご要望をいただきました。


大変便利なマクロを披露していただき、ありがとうございます。
自分が使用している環境では、宛先、Cc、差出人がすべて「表示名」で表示され->Excelの表にも表示名で記入されます。
この表示名をエイリアスの表示に切り替えるにはどうすればよいでしょうか。

よろしくご教示ください


エイリアス、ということは Exchange サーバー環境でしょうか?
その場合、差出人や受信者のオブジェクトで GetExchangeUser などにより Exchange 情報を取得する必要があります。
マクロは以下のようになります。

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

Option Explicit
' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportToExcelWithThread()
    On Error Resume Next
    Dim appExcel 'As Excel.Application
    Dim objBook 'As Excel.Workbook
    Dim objSheet 'As Excel.Worksheet
    Dim bConvOK As Boolean
    Dim colItems As Items
    Dim objItem 'As MailItem
    Dim c As Integer
    '
    Set appExcel = CreateObject("Excel.Application")
    Set objBook = appExcel.Workbooks.Add()
    Set objSheet = objBook.Sheets(1)
    With objSheet
        .Cells(1, 1) = "スレッド情報"
        .Cells(1, 2) = "日付"
        .Cells(1, 3) = "宛先"
        .Cells(1, 4) = "Cc"
        .Cells(1, 5) = "差出人"
        .Cells(1, 6) = "件名"
        .Cells(1, 7) = "本文"
    '
        Set colItems = ActiveExplorer.CurrentFolder.Items
        colItems.Sort "送信日時"
        bConvOK = ActiveExplorer.CurrentFolder.Store.IsConversationEnabled
        For Each objItem In colItems
            If bConvOK Then
                ExportThreadByConversation objItem, objSheet
            Else
                ExportThreadByMessageId objItem, objSheet
            End If
        Next
        For c = 2 To .UsedRange.Columns.Count Step 6
            .Cells(1, c) = "日付"
            .Cells(1, c + 1) = "宛先"
            .Cells(1, c + 2) = "Cc"
            .Cells(1, c + 3) = "差出人"
            .Cells(1, c + 4) = "件名"
            .Cells(1, c + 5) = "本文"
        Next
    End With
    '
    appExcel.Visible = True
    objBook.Windows(1).Visible = True
End Sub
'
Private Sub ExportThreadByConversation(objItem, objSheet)
    Const PR_CONVERSATION_ID = "http://schemas.microsoft.com/mapi/proptag/0x30130102"
    Dim strConvID As String
    Dim r As Integer
    Dim c As Integer
    '
    With objItem.PropertyAccessor
        strConvID = .BinaryToString(.GetProperty(PR_CONVERSATION_ID))
    End With
    r = 2
    While objSheet.Cells(r, 1) <> ""
        If objSheet.Cells(r, 1) = strConvID Then
            Exit Sub
        End If
        r = r + 1
    Wend
    objSheet.Cells(r, 1) = strConvID
    c = 2
    EnumConversation objItem.GetConversation().GetRootItems, objSheet, r, c
End Sub
'
Private Sub EnumConversation(colItems As SimpleItems, objSheet, r As Integer, c As Integer)
    Dim objItem 'As MailItem
    Dim conv As Conversation
    Dim colSubItems As SimpleItems
    For Each objItem In colItems
        WriteCell objItem, objSheet, r, c
        c = c + 6
        Set conv = objItem.GetConversation()
        Set colSubItems = conv.GetChildren(objItem)
        If colSubItems.Count > 0 Then
            EnumConversation colSubItems, objSheet, r, c
        End If
    Next
End Sub
'
Private Sub ExportThreadByMessageId(objItem, objSheet)
    Const PR_INTERNET_MESSAGE_ID = "http://schemas.microsoft.com/mapi/proptag/0x1035001e"
    Const PR_IN_REPLY_TO_ID = "http://schemas.microsoft.com/mapi/proptag/0x1042001e"
    Dim strMsgID As String
    Dim strRepID As String
    Dim r As Integer
    Dim c As Integer
    Dim bFound As Boolean
    '
    With objItem.PropertyAccessor
        strMsgID = .GetProperty(PR_INTERNET_MESSAGE_ID)
        strRepID = .GetProperty(PR_IN_REPLY_TO_ID)
    End With
    '
    With objSheet
        c = 2
        If strRepID = "" Then
            r = .UsedRange.Rows.Count + 1
        Else
            bFound = False
            r = 2
            While (Not bFound) And .Cells(r, 1) <> ""
                If InStr(.Cells(r, 1), strRepID) > 0 Then
                    While .Cells(r, c) <> ""
                        c = c + 6
                    Wend
                    bFound = True
                Else
                    r = r + 1
                End If
            Wend
        End If
        .Cells(r, 1) = .Cells(r, 1) & strMsgID
        WriteCell objItem, objSheet, r, c
    End With
End Sub
'
Private Sub WriteCell(objItem, objSheet, r As Integer, c As Integer)
    On Error Resume Next
    With objSheet
        .Cells(r, c) = objItem.SentOn
        .Cells(r, c + 1) = GetRecipAliases(objItem, olTo)
        .Cells(r, c + 2) = GetRecipAliases(objItem, olCC)
        .Cells(r, c + 3) = GetAlias(objItem.Sender)
        .Cells(r, c + 4) = objItem.Subject
        .Cells(r, c + 5) = objItem.Body
    End With
End Sub
'
Private Function GetRecipAliases(objItem, iType As OlMailRecipientType)
    Dim strAliases As String
    Dim objRecip As Recipient
    strAliases = ""
    For Each objRecip In objItem.Recipients
        If objRecip.Type = iType Then
            strAliases = strAliases & GetAlias(objRecip.AddressEntry) & ";"
        End If
    Next
    If strAliases <> "" Then
        strAliases = Left(strAliases, Len(strAliases) - 1)
    End If
    GetRecipAliases = strAliases
End Function
'
Private Function GetAlias(addrEntry As AddressEntry)
    On Error Resume Next
    Dim exchUser As ExchangeUser
    Dim exchDl As ExchangeDistributionList
    Dim strAlias As String
    Set exchUser = addrEntry.GetExchangeUser()
    Set exchDl = addrEntry.GetExchangeDistributionList()
    If Not exchUser Is Nothing Then
        strAlias = exchUser.Alias
    ElseIf Not exchDl Is Nothing Then
        strAlias = exchDl.Alias
    Else
        strAlias = addrEntry.Address
    End If
    GetAlias = strAlias
End Function

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

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

3/14 に Outlook 2016 および Outlook 2013 の累積的な修正プログラムがリリースされました。
第 2 火曜日のリリースですが Outlook についてはセキュリティ修正ではないようです。
以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

March 14, 2017, update for Outlook 2016 (KB3085429)
19 件の不具合修正が行われています。

Word 2016 のセキュリティ修正

MS17-014: Description of the security update for Word 2016: March 14, 2017
3 件の Outlook 2016 に関するセキュリティ関連ではない修正が行われています。

Office 2013

Outlook 2013 の修正

FMarch 14, 2017, update for Outlook 2013 (KB3115019)
2 件の不具合修正が行われています。

Word 2013 のセキュリティ修正

MS17-014: Description of the security update for Word 2013: March 14, 2017
2 件の Outlook 2013 に関するセキュリティ関連ではない修正が行われています。

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

March 7, 2017, update for Office 2013 (KB3162058)
1 件の Outlook 2013 に関する修正が行われています。

スレッドを保ったまま任意の文字列を件名のプレフィックスにつけて返信するマクロ

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


このマクロを使って、件名を追加してもスレッド表示することが出来る様になりました。
が、このメールに返信すると、追加した部分が削除されてしまいます。
下記のように使用したいため、返信の際に追加した件名を残したいです。
なにか方法はありますか?

現状 Aさん テスト送信
Bさん 【最終回答】: テスト送信(マクロ)
Cさん Re:テスト送信

理想 Aさん テスト送信
Bさん 【最終回答】: テスト送信(マクロ)
Cさん 【確認】【最終回答】: テスト送信


元のマクロで件名に追加した文字列は、Outlook では PR_SUBJECT_PREFIX というプロパティに格納されます。
そのため、追加した文字列にさらに別の文字列を追加する場合、元のメールの PR_SUBJECT_PREFIX を取得し、それに別の文字列を追加するという動作が必要になります。
これについては以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
' OK をつけるマクロ
Public Sub AppendLastPrefix()
    AppendPrefix "【最終回答】"
End Sub
' NG をつけるマクロ
Public Sub AppendConfirmPrefix()
    AppendPrefix "【確認】"
End Sub
' 任意の文字列を入力して付与するマクロ
Public Sub AppendAnyPrefix()
    Dim strPrefix As String
    strPrefix = InputBox("付与する文字列:")
    If strPrefix <> "" Then
        AppendPrefix strPrefix
    End If
End Sub
' 文字列を件名のプレフィックスに追加するサブプロシージャ
Private Sub AppendPrefix(strPrefix As String)
    Const PR_SUBJECT_PREFIX = "http://schemas.microsoft.com/mapi/proptag/0x003d001f"
    Dim strOrgPrefix As String
    Dim objAction As Action
    Dim objItem As MailItem
    Dim objReply As MailItem
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        Set objItem = ActiveInspector.CurrentItem
    Else
        Set objItem = ActiveExplorer.Selection(1)
    End If
    ' 元のメールの件名のプレフィックスを取得
    strOrgPrefix = objItem.PropertyAccessor.GetProperty(PR_SUBJECT_PREFIX)
    ' プレフィックスについている : を削除
    If Right(strOrgPrefix, 2) = ": " Then
        strOrgPrefix = Left(strOrgPrefix, Len(strOrgPrefix) - 2)
    End If
    Set objAction = objItem.Actions.Add
    objAction.Name = strPrefix & strOrgPrefix
    objAction.Prefix = strPrefix & strOrgPrefix
    objAction.ReplyStyle = olUserPreference
    objAction.ShowOn = olDontShow
    Set objReply = objAction.Execute
    objReply.Display
    objItem.Save
End Sub

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

メールの本文で選択されたキーワードを Web で検索するマクロ

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


メールの本文など、あるキーワードを選択した状態で、

右クリック->Google検索(マクロ)->ブラウザが起動(googleサイトで検索)

となるようなマクロは作成できませんでしょうか?


マクロで本文の右クリックで表示されるメニュー (コンテキスト メニュー) を追加するのは困難なので、本文で選択した文字列を検索するマクロにしました。

' ここをトリプルクリックでマクロ全体を選択できます。
' Google 検索を行うマクロ
Public Sub GoogleSearch()
    WebSearch "https://www.google.co.jp/search?q="
End Sub
' Bing 検索を行うマクロ
Public Sub BingSearch()
    WebSearch "https://www.bing.com/search?q="
End Sub
' Wikipedia 検索を行うマクロ
Public Sub WikipediaSearch()
    WebSearch "https://ja.wikipedia.org/wiki/"
End Sub
' 検索を実行する共通マクロ
Private Sub WebSearch(strCmd As String)
    Dim objDoc As Object ' Word.Document
    Dim strKey As String
    Dim objShell As Object
    ' 選択された文字列を取得
    Set objDoc = ActiveInspector.WordEditor
    strKey = Trim(objDoc.Application.Selection.Text)
    strKey = Replace(strKey, " ", "%20")
    ' 取得した文字列を引数に追加して実行
    Set objShell = CreateObject("WScript.Shell")
    objShell.Run strCmd & strKey
End Sub

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

PST のパスワードとセキュリティ

Outlook には、PST にパスワードをかける機能があります。
昨今の情報漏洩問題などに備え、セキュリティを高めるという意味ですべての PST にパスワードをかけて運用されているという方もいると思います。

しかし、残念ながら、PST のパスワードでセキュリティはほとんど強化されません。
これについては、マイクロソフトの技術情報でも以下の通り明記されています。

4.2 Strength of PST Password

The PST Password, which is stored as a property value in the message store, is a superficial mechanism that requires the client implementation to enforce the stored password. Because the password itself is not used as a key to the encoding and decoding cipher algorithms, it does not provide any security benefit to preventing the PST data to be read by unauthorized parties.

Moreover, the password is stored as a CRC-32 hash of the original password string, which is prone to collisions and is relatively weak against a brute-force approach.

https://msdn.microsoft.com/en-us/library/ff387042(v=office.12).aspx より

セキュリティに役立たない理由は二つあります。

一つ目は、パスワード自体が PST の暗号化に関わっていないということです。
一般にパスワードがかかったファイルは、そのパスワードをキーとした暗号化が行われており、パスワードがなければファイルのデータを読み取ることができないようになっています。
しかし、PST の場合、そもそも一般的な意味での暗号化 (※1) はされていません。
そのため、パスワードがわからなかったとしても、PST のデータ フォーマット (※2) を理解していれば、データの解読ができます。

二つ目は、パスワード自体の暗号化が弱いということです。
PST のパスワードは、元のパスワードをもとに CRC-32 というアルゴリズムで生成したハッシュコードを PST に格納し、ユーザーが入力したパスワードのハッシュと照合して認証するという仕組みになっています。
しかし、CRC-32 では正しい文字列以外でも同じハッシュ コードになる文字データの組み合わせが存在し、総当たり攻撃という手法で簡単に突破できるものです。
PST の仕様が定められた 20 年前にはこの方法でもセキュリティはある程度保てていたのかもしれませんが、現在のコンピュータ環境では数秒で正しいパスワードと認識されてしまう文字列が生成可能であり、実際にサードパーティからは PST のパスワードを解読するツールがリリースされています。

したがって、例えば家庭内で子供がアクセスするのを防ぎたいというような程度のセキュリティには使用できると思いますが、企業において情報漏洩を防ぐためという目的では全く無力なものあり、そのような目的には Windows の暗号化ファイル システム (EFS) や BitLocker を使うべきでしょう。

※1: ユーザーデータについては一定のアルゴリズムで暗号化されています。しかし、キーなしの暗号化方式であり、暗号化のアルゴリズムがわかってしまえば解読できるものであるため、暗号化というより難読化と呼ぶべきものです。これについての詳細は https://msdn.microsoft.com/en-us/library/ff386520(v=office.12).aspx で説明されています。
※2: PST のデータ フォーマットは https://msdn.microsoft.com/en-us/library/ff385210(v=office.12).aspx で公開されています。

前の月に受信したメールのうち、特定のキーワードを含むメールをカウントするマクロ

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


マクロ作成について、ご教示ください。
outlook2013を使用しています。
ある特定の期間に受信したメールのうち、
件名に特定のキーワードが入っているメールをカウントし、
件数とその件名を抽出したいと思っています。
また、今日を基準に、先月を自動算出し、
先月分の条件に該当するメールをカウントするなどは可能でしょうか。
よろしくお願いします。


以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub FindMailByKeywordLastMonth()
    On Error Resume Next
    ' 検索するキーワードを指定
    Const SEARCH_KEY = "test"
    ' レポートを作成するファイルのフルパスを指定
    Const REPORT_FILE = "c:\temp\report.txt"
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim colItems As Items
    Dim objItem As Object
    Dim cntItems As Integer
    Dim strReport As String
    ' 前月を表す日付範囲を算出
    dtEnd = Year(Now) & "/" & Month(Now) & "/1"
    dtStart = DateAdd("m", -1, dtEnd)
    ' 日付範囲でフィルタリング
    Set colItems = Session.GetDefaultFolder(olFolderInbox).Items
    colItems.Restrict "[受信日時] >= #" & dtStart & "# AND " & _
        "[受信日時] <  #" & dtEnd & "#"
    cntItems = 0
    strReport = ""
    ' フィルタリングしたメールを確認
    For Each objItem In colItems
        ' 件名にキーワードを含む場合はカウンタとレポート追加
        If InStr(objItem.Subject, SEARCH_KEY) > 0 Then
            cntItems = cntItems + 1
            strReport = strReport & objItem.ReceivedTime & vbTab & objItem.Subject & vbCrLf
        End If
    Next
    ' レポート作成
    Open REPORT_FILE For Output As #1
    Print #1, SEARCH_KEY & "を含むメールの件数:", cntItems
    Print #1, strReport
    Close #1
    ' レポートをメモ帳で表示
    Shell "notepad.exe " & REPORT_FILE
End Sub

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

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

2/7 に Office 2016 および Office 2013 の累積的な修正プログラムがリリースされました。
以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

February 7, 2017, update for Outlook 2016 (KB3141511)
1 件の機能追加と 16 件の不具合修正が行われています。

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

February 7, 2017, update for Office 2016 (KB3128052)
1 件の Outlook 2016 に関する機能追加が行われています。

Office 2013

Outlook 2013 の修正

February 7, 2017, update for Outlook 2013 (KB3141495)
10 件の不具合修正が行われています。

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

February 7, 2017, update for Office 2013 (KB3141491)
1 件の Outlook 2013 に関する修正が行われています。