メールの宛先に指定したアドレスを連絡先の名前に置き換えるマクロ

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


はじめまして。
いつもサイトを拝見させていただき、大変お世話になっております。
Outlook2013で連絡先の閲覧ウインドウで、名前の下にある4つのアイコンの中から一番右のメールのアイコンからメールを作成しようとすると、宛先にはメールアドレスが表示されます。この時にメールアドレスでなく、連絡先に登録してある表示名を宛先に表示する設定とかあるのでしょうか。新しい電子メールから作成した時と、送信済みアイテムの宛先が異なる名前で残ってしまうのが困っています。
宜しくお願い致します。


残念ながら閲覧ウィンドウのボタンで宛先に表示名を付けて追加する設定はありませんが、宛先がアドレスとなっている状態で以下のマクロを実行することでアドレス帳の名前に置き換えることができます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ResolveWithContacts()
    Dim objMail As MailItem
    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
    Dim strEntryID As String
    '
    Set objMail = ActiveInspector.CurrentItem
    objMail.Save
    objMail.Recipients.ResolveAll
    cRecips = objMail.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 = objMail.Recipients.Item(i)
        colAddress(i) = objRecip.Address
        colName(i) = objRecip.Name
        colType(i) = objRecip.Type
        objMail.Recipients.Remove i
    Next
    '
    For i = 1 To cRecips
        bFound = False
        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 = objMail.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 = objMail.Recipients.Add(colName(i) & " <" & colAddress(i) & ">")
            Else
                Set objRecip = objMail.Recipients.Add(colAddress(i))
            End If
            objRecip.Type = colType(i)
            objRecip.Resolve
        End If
    Next
    objMail.Close olSave
    objMail.Display
End Sub

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

選択したメッセージをまとめて一つのテキストファイルに保存するマクロ

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


win10(32bit)、outlook2016を使用しています。以下の操作を手作業でやっていますが、マクロで行うことは出来ますでしょうか。
・サブフォルダにある複数のメールを選択。(サブフォルダ内の全てのメールでも構いません。)
・選択した状態で「ファイル」「名前を付けて保存」をクリック。
・任意のフォルダを指定、「ファイルの種類(テキスト)」を選択、ファイル名は例えば「123.txt」として保存する。
(結果的に、複数のメールの内容が並んだ1つのテキストファイルが作成されます。)


現在表示中のフォルダーの選択したメールをテキストに保存するマクロは以下のようになります。
フォルダーのすべてのメールを保存したい場合は ActiveExplorer.SelectionActiveExplorer.CurrentFolder.Items としてください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub SaveSelectedAsText()
    On Error Resume Next
    Const TEXT_FILE = "c:\temp\messages.txt" ' 保存するファイル名を指定
    Dim objMail As MailItem
    Dim objAttach As Attachment
    Dim strAttach As String
    '
    Open TEXT_FILE For Output As #1
    For Each objMail In ActiveExplorer.Selection
        With objMail
            Print #1, "差出人:" & vbTab & .SenderName
            Print #1, "送信日時:" & vbTab & .SentOn
            If .To <> "" Then
                Print #1, "宛先:" & vbTab & .To
            End If
            If .CC <> "" Then
                Print #1, "CC:" & vbTab & .CC
            End If
            Print #1, "件名:" & vbTab & .Subject
            If .Attachments.Count > 0 Then
                strAttach = ""
                For Each objAttach In .Attachments
                    strAttach = strAttach & objAttach.FileName & "; "
                Next
                strAttach = Left(strAttach, Len(strAttach) - 2)
                Print #1, "添付ファイル: " & vbTab & strAttach
            End If
            If .Importance <> olImportanceNormal And .Sensitivity <> olNormal Then
                Print #1, ""
            End If
            If .Importance = olImportanceHigh Then
                Print #1, "重要度:" & vbTab & "高"
            End If
            If .Importance = olImportanceHigh Then
                Print #1, "重要度:" & vbTab & "低"
            End If
            If .Sensitivity = olConfidential Then
                Print #1, "秘密度:" & vbTab & "社外秘"
            End If
            If .Sensitivity = olPersonal Then
                Print #1, "秘密度:" & vbTab & "個人用"
            End If
            If .Sensitivity = olPrivate Then
                Print #1, "秘密度:" & vbTab & "親展"
            End If
            If .Categories <> "" Then
                Print #1, ""
                Print #1, "分類項目:" & vbTab & .Categories
            End If
            Print #1, ""
            Print #1, .Body
            Print #1, ""
        End With
    Next
    Close #1
End Sub

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

予定の件名と場所の文字列を一括で置き換えるマクロ

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


別件(祝日追加)でマクロを利用させて頂き大変助かりました。
可能であればマクロ作成をご検討頂きたいのです。
OS:Windows 7 Professional(64bit)
Outlook2013
Outlook.comのアカウントの予定を個人の予定表として利用する為
アカウント登録し、Outlook2013側で
Outlook.comアカウントの予定を入力しております。
Outlook2013の予定表でも同様だとは思うのですが
予定の【件名】【場所】に入力した文字を検索は可能なのですが
置換をしたいのです。
よろしくお願い申し上げます。


現在表示している予定表フォルダーのアイテムの件名と場所を検索し、指定された文字列に置き換えるマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。        
Public Sub ReplaceTextInSubjectAndLocation()
    Dim strFind As String ' 検索する文字列
    Dim strReplace As String ' 置き換える文字列
    '
    Dim colItems As Items
    Dim apptItem As AppointmentItem
    Dim fDirty As Boolean
    '
    strFind = InputBox("検索文字列:")
    strReplace = InputBox("置換文字列:")
    Set colItems = ActiveExplorer.CurrentFolder.Items
    For Each apptItem In colItems
        fDirty = False
        With apptItem
            '
            If .Subject Like "*" & strFind & "*" Then
                .Subject = Replace(.Subject, strFind, strReplace)
                fDirty = True
            End If
            '
            If .Location Like "*" & strFind & "*" Then
                .Location = Replace(.Location, strFind, strReplace)
                fDirty = True
            End If
            '
            If fDirty Then
                .Save
            End If
        End With
    Next
End Sub

   

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

メールのスレッドを保持して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

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

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

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


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

現状 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

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

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

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


マクロ作成について、ご教示ください。
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

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