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

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


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

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

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

場所から自動的に会議室メールボックスを宛先に追加するマクロ

Exchange サーバー環境では会議室のためのメールボックスを作り、会議出席依頼で会議室の予約を行うことができます。
また、会議室のメールボックスをリソースとして宛先に追加すると、同時に会議アイテムの [場所] にその会議室が設定されます。
この機能は非常に便利なのですが、ちょっと厄介なのが [場所] の履歴に会議室が残るという点です。
[場所] フィールドの右にはドロップダウンがあり、過去に使用した場所を選択することができるのですが、以前送信した会議室のメールボックスを指定しても宛先には自動では含まれません。
そのため、[場所] で会議室を選択した後、改めて会議室をリソースとして宛先に追加しなおす必要があるのです。
この操作を忘れて会議室を予約し忘れるということが発生しがちなので、場所に設定した会議室を宛先に追加し忘れていた場合に、自動で設定するマクロを作ってみました。
以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If TypeName(Item) = "MeetingItem" Then
        ReplaceLocationToResource Item
    End If
End Sub
'
Private Sub ReplaceLocationToResource(ByVal meetItem As MeetingItem)
    Const PR_DISPLAY_TYPE_EX = "http://schemas.microsoft.com/mapi/proptag/0x39050003"
    Const DT_ROOM = 7
    Dim apptItem As AppointmentItem
    Dim resRecip As Recipient
    Dim bDelete As Boolean
    '
    Set apptItem = meetItem.GetAssociatedAppointment(False)
    If InStr(apptItem.Resources, apptItem.Location) > 0 Then
        Exit Sub    ' すでにリソースに登録済みなら終了
    End If
    Set resRecip = meetItem.Recipients.Add("=" & apptItem.Location)
    bDelete = True
    resRecip.Resolve
    If resRecip.Resolved Then
        If resRecip.AddressEntry.Type = "EX" Then
            If resRecip.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
                Dim exchUser As ExchangeUser
                Set exchUser = resRecip.AddressEntry.GetExchangeUser
                If exchUser.PropertyAccessor.GetProperty(PR_DISPLAY_TYPE_EX) = DT_ROOM Then
                    bDelete = False
                End If
            End If
        End If
    End If
    '
    If bDelete Then
        resRecip.Delete
    Else
        resRecip.Type = olResource
        Set resRecip = apptItem.Recipients.Add("=" & apptItem.Location)
        resRecip.Resolve
        resRecip.Type = olResource
        apptItem.Save
    End If
End Sub

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

決まった件名で終わるメッセージを受信したら、キーワードを含む 1 行を CSV ファイルに保存するマクロ

決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロのコメントにて以下のご要望をいただきました。


横から失礼します。
本件に近い操作をしたいと考えています。
1.一定の文言が含まれるメールが対象
2.対象としたメール本文から、対象となる文言が含まれる部分(1行)を抜き出し、CSV化
具体的には
1.件名:「~を入力しました。」 ※「~」は、都度 異なります。
2.本文:「●:●● ■■会議 予約済」 →この「予約済」を対象として、その1行を抜き出してCSV化で一覧にしたいと思っています。
このような操作は可能でしょうか?また、どのように設定すれば良いでしょうか?
ご教示、お願い致します。
※初心者につき、説明がわかりにくいようでしたら すみません。

12で質問させていただいた内容に追記させてください。
受信時間と件名もCSVに記載したいです。
まとめると・・・
1.件名の「~を入力しました」をKeyにして
2.件名(フル)と受信時間+本文の一部(●:●● ■■会議 予約済 ←「予約済」をKeyに1行を抜き出す)をCSV化
したいです。
ご教示、よろしくお願いします。


変更点は以下の 2 になります。

  • 件名の先頭部分は可変
  • キーワードを含む 1 行を抽出

件名の一部が一致するという条件を指定する場合は LIKE という演算子を使用します。
例えば、「~を入力しました。」の「~」が可変なのであれば、以下のような条件定義になります。
    If myMsg.Subject Like "*を入力しました。"  Then

また、1 行を抜き出すというのは、言い換えると「キーワードの前後の改行を検索し、その間の文字列を取得する」ということになります。

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

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

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    SaveLineToCsv EntryIDCollection
End Sub
'
Private Sub SaveLineToCsv(ByVal EntryIDCollection As String)
    Const AUTO_SAVE_TITLE_SUFFIX = "を入力しました。" ' 自動処理するメールの件名の終わりの文字
    Const CSV_FILE = "c:\temp\data.csv" ' データを保存する CSV ファイルの名前
    Const SEARCH_KEY = "予約済み" ' 本文で検索するキーワード
    Dim i As Integer
    Dim arrEntryId
    Dim myMsg
    Dim stmCsv
    Set stmCsv = Nothing
    arrEntryId = Split(EntryIDCollection, ",")
    For i = LBound(arrEntryId) To UBound(arrEntryId)
        Set myMsg = Application.Session.GetItemFromID(arrEntryId(i))
        If myMsg.Subject Like "*" & AUTO_SAVE_TITLE_SUFFIX Then
            Dim s As Integer
            Dim e As Integer
            Dim strLine As String
            If stmCsv Is Nothing Then
                Dim objFSO
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                Set stmCsv = objFSO.OpenTextFile(CSV_FILE, 8, True, 0)
            End If
            ' キーワードを本文から検索
            e = InStr(myMsg.Body, SEARCY_KEY)
            If e > 0 Then ' キーワードを含む場合だけ処理
                ' キーワードを含む行の最初 (=直前の行の改行) を検索
                s = InStrRev(myMsg.Body, vbLf, e)
                If s = 0 Then
                    s = 1 ' 改行がなければ本文の先頭から
                End If
                e = InStr(e, myMsg.Body, vbCr)
                'キーワードを含む行の終わりを取得
                If e = 0 Then
                    e = Len(myMsg.Body)
                End If
                ' キーワードを含む行を取得
                strLine = Mid(myMsg.Body, s, e - s)
                strLine = Replace(strLine, vbCr, "")
                strLine = Replace(strLine, vbLf, "")
                stmCsv.WriteLine myMsg.Subject & "," & myMsg.ReceivedTime & "," & strLine
            End If
        End If
    Next
    If Not stmCsv Is Nothing Then
        stmCsv.Close
    End If
End Sub

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

本文から取得したデータを項目別に Excel のシートに書き出すマクロ

メールの内容を Excel ファイルにかき出すマクロ のコメントにて以下のご要望をいただきました。


はじめまして。
横からの質問で申し訳ありません。
どうしても自分では解決できずなんとかお力をお借りしたいと思います。

メールの本文中、

【 ご予定日 】 12月
【 日 】 31日
【 泊数 】 1泊
【 名前 】 山田 太郎
【 郵便番号 】 4562215
【 ご住所 】 愛知県豊明市西町5丁目111-111
【 マンション名等 】豊明マンション101
【 Email 】 taroyamada@yahoo.co.jp
【 tel1 】 0902200000
【 ご予約人数 】 2人
【 小学生以下人数 】 1人

のように項目ごとのフォーム送信がある場合、エクセルの2行目以降のセルに

(A1) (B1) …
ご予定日 日 泊数 名前 郵便番号 …
(A2) (B2) …
12 31 1 山田 太郎 4562215 …

のように①、メール本文内の項目の後の文字列を抽出し、エクセルの対象項目に対して個別にエクスポートすることは可能なのでしょうか?
またその折②、日にち、泊数などは数字のみ抽出できればうれしいです。
outlookのエクスポート機能はwordの差し込みフィールドのように使えて便利そうなのですが2003以降のバージョンには対応していないようですし、本文中の項目までは当然読み込めませんのでなんとかマクロで解決できればと思っております。
ただ、マクロはネットで引っ張りながらさわるぐらいしかできません。
こういった投稿、コメントに不慣れで甚だ不躾ではございますが是非ご教示頂ければ幸いです。
宜しくお願い申し上げます。

追記です。
出来れば既存のエクセルデータsheet内のセルに挿入できればと考えています。


本文から項目を取り出すというような便利な関数は Outlook には用意されていませんが、VBA の文字列検索関数を使って実現することはできます。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportBodyToExcel()
    ' エクスポートする Excel ファイルのファイル名を指定
    Const EXCEL_FILE = "c:\temp\book1.xlsx" 
    Dim objBook As Object
    Dim objSheet As Object
    Dim r As Integer
    Dim strBody As String
    ' Excel ファイルを開く
    Set objBook = GetObject(EXCEL_FILE)
    objBook.Windows(1).Activate
    Set objSheet = objBook.Worksheets(1)
    ' 空行を探す
    r = 1
    While objSheet.Cells(r, 1) <> ""
        r = r + 1
    Wend
    ' メールをどのように開いているか確認
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        strBody = ActiveInspector.CurrentItem.Body
    Else
        strBody = ActiveExplorer.Selection(1).Body
    End If
    ' セルに本文から取得したデータを格納
    objSheet.Cells(r, 1) = GetValueByToken(strBody, "ご予定日", True)
    objSheet.Cells(r, 2) = GetValueByToken(strBody, "日", True)
    objSheet.Cells(r, 3) = GetValueByToken(strBody, "泊数", True)
    objSheet.Cells(r, 4) = GetValueByToken(strBody, "名前", False)
    ' 郵便番号は文字列として保存
    objSheet.Cells(r, 5) = "'" & GetValueByToken(strBody, "郵便番号", False)
    objSheet.Cells(r, 6) = GetValueByToken(strBody, "ご住所", False)
    objSheet.Cells(r, 7) = GetValueByToken(strBody, "マンション名等", False)
    objSheet.Cells(r, 8) = GetValueByToken(strBody, "Email", False) 
    ' 電話番号は文字列として保存
    objSheet.Cells(r, 9) = "'" & GetValueByToken(strBody, "tel1", False)
    objSheet.Cells(r, 10) = GetValueByToken(strBody, "ご予約人数", True)
    objSheet.Cells(r, 11) = GetValueByToken(strBody, "小学生以下人数", True)
    ' 項目を追加したければ以下のフォーマットで追加 
    ' objSheet.Cells(r, 列番号) = GetValueByToken(strBody,"項目名", True) '数字のみ取り出す場合 
    ' objSheet.Cells(r, 列番号) = GetValueByToken(strBody,"項目名", False) '文字列として取り出す場合
    ' 変更したファイルを保存
    objBook.Save
    objBook.Close
    MsgBox "保存しました。"
End Sub
'
'  本文から指定された項目のデータを取得する関数
'
Private Function GetValueByToken(strBody As String, strToken As String, bNumOnly As Boolean)
    Dim i As Integer
    Dim strLine As String
    Dim strValue As String
    Dim c As String
    i = InStr(strBody, "【 " & strToken & " 】")
    If i > 0 Then
        strValue = ""
        strLine = Mid(strBody, i + Len(strToken) + 4)
        i = InStr(strLine & vbCrLf, vbCrLf)
        ' 余計な空白を削除
        strValue = Trim(Left(strLine, i - 1))
        If bNumOnly Then  ' 数字のみが指定された場合
            For i = 1 To Len(strValue)
                c = Mid(strValue, i, 1)
                If c < "0" Or "9" < c Then
                    strValue = Left(strValue, i - 1)
                    Exit For
                End If
            Next
        End If
        GetValueByToken = strValue
    Else
        GetValueByToken = ""
    End If
End Function

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

メール本文中のハイパーリンクを置き換えるマクロ

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


お世話になります。
仕事でOutlook2010をOffice365サーバー環境で使用しています。
Outlookメール本文中のハイパーリンクを変更したい件でご相談させてください。
今回、会社の組織変更で、Windowsファイルサーバーの格納先パスを変更する必要が出てきました。
従来、
\\Fsrv02\913-ABC\01グループ公開\50役立つ資料」のパスを
\\Fsrv02\602-XYZ\001グループ公開\50役立つ資料」に変更する必要がある状況です。
その際、メール本文中にあるハイパーリンクを置き換えしたいのです。
メールには、
テキスト形式
HTML形式
リッチテキスト形式が混在しています。
メールは複数あり、フォルダー内すべてのメール本文を対象に検索して置き換えたい状況です。
できれば、テキストファイルに、変更前パスと、変更後パスを指定して、汎用性がもたせたら尚うれしいです。
弊サイトの情報も見させていただいたのですが、私の探し方が未熟なため、サンプルプログラムとして使わせていただけそうなものが見つかりませんでした。
どうか、宜しくお願い申し上げます。


以下のようなマクロで実現できます。 REPLACE_FILE で指定したファイル名のテキストファイルに、変更前のパスと変更後のパスを 1 行ずつタブで区切って格納してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ReplaceLinksInFolder()
    Const REPLACE_FILE = "c:\temp\replacelinks.txt"
    Dim objFSO As Object
    Dim stmFile As Object
    Dim strReplace As String
    Dim arrLine As Variant
    Dim arrOld() As String
    Dim arrNew() As String
    Dim i As Integer
    ' パスの変換情報をファイルから読み込み
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set stmFile = objFSO.OpenTextFile(REPLACE_FILE)
    strReplace = stmFile.ReadAll()
    stmFile.Close
    arrLine = Split(strReplace, vbCrLf)
    ReDim arrOld(UBound(arrLine))
    ReDim arrNew(UBound(arrLine))
    For i = LBound(arrLine) To UBound(arrLine)
        Dim arrField As Variant
        If InStr(arrLine(i), vbTab) = 0 Then
            ReDim Preserve arrOld(i)
            ReDim Preserve arrNew(i)
            Exit For
        End If
        arrField = Split(arrLine(i), vbTab)
        arrOld(i) = arrField(0)
        arrNew(i) = arrField(1)
    Next
    ' アイテムごとにパスの変換を行う
    Dim objItem As MailItem
    For Each objItem In ActiveExplorer.CurrentFolder.Items
        If objItem.BodyFormat = olFormatPlain Then
            ' テキスト形式なら単純なテキスト置き換え
            Dim strNewBody As String
            strNewBody = objItem.Body
            For i = LBound(arrOld) To UBound(arrOld)
                strNewBody = Replace(strNewBody, arrOld(i), arrNew(i))
            Next
            If strNewBody <> objItem.Body Then
                objItem.Body = strNewBody
                objItem.Save
            End If
        Else
            ' HTML または RTF の場合は Word コンポーネントを使用して置き換え
            Dim objInsp As Inspector
            Dim objWord As Object ' Word.Document
            Dim objLink As Object ' Word.Hyperlink
            Dim bFound As Boolean
            Set objInsp = objItem.GetInspector()
            Set objWord = objInsp.WordEditor
            ' テキスト置き換えを可能にするため、[メッセージの編集] を実行
            objInsp.Display
            objInsp.CommandBars.ExecuteMso "EditMessage"
            bFound = False
            For Each objLink In objWord.Hyperlinks
                For i = LBound(arrOld) To UBound(arrOld)
                    ' リンクアドレスが置き換え前の文字列で始まる場合は置き換え
                    If objLink.Address Like arrOld(i) & "*" Then
                        bFound = True
                        objLink.Address = Replace(objLink.Address, arrOld(i), arrNew(i))
                        If objLink.TextToDisplay Like arrOld(i) & "*" Then
                            objLink.TextToDisplay = Replace(objLink.TextToDisplay, arrOld(i), arrNew(i))
                        End If
                    End If
                Next
            Next
            If bFound Then
                objItem.Save
            End If
            objInsp.Close olDiscard
        End If
    Next
End Sub

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