特定の文字列で始まる件名のメールを受信した際に、その受信日時と本文中のデータを Excel ファイルに保存するマクロ

Outlook マクロ・スクリプト インデックスのコメントにて以下のご要望をいただきました。


はじめまして

Inbox直下のサブフォルダーに特定の形式、同じアドレスから入ってくるオーダーメールが日に150件ほど届きます。
タイトル「特定の文字列+オーダー番号」
  本文
オーダー番号:*****
  顧客名:******
  電話番号:******

このオーダーメールが届く度に随時所定のExcelファイルに受信日時を含めて情報を書き出すマクロを作りたいと思っています。
  受信日時:A列
  顧客名:B列
Customer Name: C列
  電話番号:D列
※上書きではなく空いている行に積みあがっていくように

以下の2つとにたような形式でできるのではないかと思いますが、どうもうまくいきません。

・「特定の文字列を件名に含むメールを受信した際にその送信者アドレスと受信日時をExcelファイルまたはCSVファイルに保存するマクロ
・「決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロ

お力添えを頂けましたら幸いです。


ご推察の通り、上記の二つのマクロを組み合わせることで、ご要望の動作をするマクロを作ることができます。
サンプルは以下の通りなのですが、Excel ファイルに書き出す内容としてオーダー番号がなく、顧客名と Customer Name は重複しているように思われたので、オーダー番号を B 列、顧客名を C 列に書き込むようにしました。

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

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     SaveToExcel EntryIDCollection
End Sub
'
Private Sub SaveToExcel(ByVal EntryIDCollection As String)
     Const AUTO_SAVE_TITLE = "特定の文字列" ' 自動処理するメールの件名
     Const EXCEL_FILE = "c:\orders\data.xlsx" ' データを保存する Excel ファイルの名前
     Dim i As Integer
     Dim arrEntryId
     Dim myMsg
     Dim stmCsv
     Set stmCsv = Nothing
     Set myMsg = Application.Session.GetItemFromID(EntryIDCollection)
     If myMsg.Subject Like AUTO_SAVE_TITLE & "*" Then
         Dim excBook As Object
         Dim excSheet As Object
         Dim iRow As Integer
         Dim strOrderNumber
         Dim strCustomerName
         Dim strTelephone
         ' Excel ファイルを取得
         Set excBook = GetObject(EXCEL_FILE)
         excBook.Windows(1).Activate
         ' 1 つ目のワークシートを取得
         Set excSheet = excBook.Worksheets(1)
         ' あいている行を検索
         iRow = 2
         While excSheet.Cells(iRow, 1) <> ""
             iRow = iRow + 1
         Wend
         ' 本文からデータを取得
         strOrderNumber = GetText("オーダー番号:", myMsg.Body)
         strCustomerName = GetText("顧客名:", myMsg.Body)
         strTelephone = GetText("電話番号:", myMsg.Body)
         ' あいている行に受信日時と取得したデータを書き込み
         excSheet.Cells(iRow, 1) = myMsg.ReceivedTime
         excSheet.Cells(iRow, 2) = strOrderNumber
         excSheet.Cells(iRow, 3) = strCustomerName
         excSheet.Cells(iRow, 4) = strTelephone
         excBook.Save
         excBook.Close
     End If
End Sub
' 本文からデータを取得する関数
Private Function GetText(strName As String, strBody As String) As String
     Dim ls As Long
     Dim le As Long
     ls = InStr(strBody, strName) ' 指定されたフィールド名を検索
     If ls > 0 Then
         ls = ls + Len(strName) ' フィールド名の次の文字から
         le = InStr(ls, strBody, vbCrLf) ' 改行コードまでを取得
         GetText = Trim(Mid(strBody, ls, le - ls)) ' 前後の空白を削除
     Else
         GetText = ""
     End If
End Function

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

広告

本文の選択した範囲を指定文字数で折り返すマクロ

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


メール本文画面上で選択範囲のみを綺麗に改行したく、本HPの「テキスト形式のメールを指定文字数で折り返すマクロ
を参考に以下のとおり活用しているのですが、①選択範囲のみではなく全体に適用されてしまう点、②半角文字があると
そこで改行されてしまう点に悩んでいます。修正をお願いできますでしょうか。
よろしくお願いします。


メール本文の選択範囲のみを対象とする場合、Inspector オブジェクトの WordEditor プロパティで取得できる Word のコンポーネントの機能を使用します。
WordEditor プロパティにより本文を編集しているコンポーネントが Word の Document オブジェクトとして取得でき、Document の Application.Selection により選択範囲を表す Selection オブジェクトにより、選択範囲の本文について様々な操作が可能となります。
本文の折り返しをするのであれば、Selection オブジェクトの Text プロパティとして選択範囲の文字列を取得し、折り返した後の文字列を Text プロパティに設定します。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub WrapLines()
     Const LINE_MAX = 70 ' 折り返しの文字数を指定します
     Dim wrdEditor As Object
     Dim objSel As Object
     Dim strBody As String
     Dim strNewBody As String
     Dim c As String
     Dim pCur As Long
     Dim pLf As Long
     Dim iLen As Long
     ' Word Editor オブジェクトを取得
     Set wrdEditor = ActiveInspector.WordEditor
     ' Selection オブジェクトを取得
     Set objSel = wrdEditor.Application.Selection
     ' 選択範囲の文字列を取得
     strBody = objSel.Text
     ' 改行後の本文の初期化
     strNewBody = ""
     ' 処理済みの本文がなくなるまで繰り返し
     While Len(strBody) > 0
         ' 改行位置と 1 行の文字数を初期化
         pLf = 0
         iLen = 0
         ' 選択した本文の最後まで
         For pCur = 1 To Len(strBody)
             ' 本文から 1 文字取得
             c = Mid(strBody, pCur, 1)
             If c = vbCr Then
                 ' 改行ならループ終了
                 Exit For
             ElseIf Asc(c) < 0 Or &H7F < Asc(c) Then
                 ' 全角文字なら文字数は 2
                 iLen = iLen + 2
                 ' 文字数が制限を超えてなければ改行位置更新
                 If iLen < LINE_MAX Then
                     pLf = pCur
                 End If
             ElseIf ("0" <= c And c <= "9") _
                 Or ("a" <= c And c <= "z") _
                 Or ("A" <= c And c <= "Z") _
                 Or InStr("""()[]<>!?.,://@", c) Then
                 ' 半角英数と一部の記号は改行位置を更新しない
                 iLen = iLen + 1
             Else
                 ' 半角記号は改行位置を更新
                 iLen = iLen + 1
                 pLf = pCur
             End If
             ' 1 行の文字数が制限以上になったらループ終了
             If iLen >= LINE_MAX Then
                 Exit For
             End If
         Next
         ' 改行位置が更新されていなければ、ループ終了時の位置で改行
         If pLf = 0 Then
             pLf = pCur
         End If
         ' 改行位置までの文字列を新本文に追記
         strNewBody = strNewBody & Left(strBody, pLf) & vbCr
         ' 新本文に追加した文字列は旧本文から削除
         If pLf <= Len(strBody) Then
             If Mid(strBody, pLf + 1, 1) = vbCr Then
                 pLf = pLf + 1
             End If
             strBody = Mid(strBody, pLf + 1)
         Else
             strBody = ""
         End If
     Wend
     ' 改行後の文字列を選択範囲のテキストに設定
     objSel.Text = strNewBody
End Sub

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

特定の件名のメールを受信するたびに特定の Web ページを開くマクロ

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


はじめまして。

outlook2010で、特定の「件名」でメールを受信した時、指定したURLを開くマクロはできるでしょうか?
例えば、1日に同じ「件名」のメール10件を受信したら、指定したURLを10回開く、のような感じです。

アドワーズのコンバージョン計測において、タグが貼れない楽天等からの注文を計測するのに利用したいです。
よろしくお願いします。


たびたびこのブログで登場していますが、メールを受信した際に何かを実行する場合は、Application オブジェクトの NewMailEx イベントを使用します。
また、特定の URL を開く方法はいくつかあるのですが、今回は WshShell オブジェクトの Run メソッドを使います。
マクロは以下の通りです。

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

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Const CHECK_SUBJECT = "URL を開く件名"
     Const OPEN_URL = "特定の件名のメールを受信した際に開く URL"
     Dim objItem As Object
     ' 受信したアイテムの取得
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     ' アイテムがメールであり、件名が一致する場合
     If TypeName(objItem) = "MailItem" And objItem.Subject = CHECK_SUBJECT Then
         Dim wshShell As Object
         ' Windows Scripting Host の WshShell オブジェクトを生成
         Set wshShell = CreateObject("WScript.Shell")
         ' URL を開く
         wshShell.Run OPEN_URL
     End If
End Sub

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

特定のキーワードを含むメールを受信したら添付 Excel ファイルを印刷してフォルダーに移動するマクロ

受信した Excel ファイルを印刷するマクロのコメントにて以下のご要望をいただきました。


件名に特定の”依頼票””予約”が入っていてかつ、添付ファイルがEXCELの場合のみ添付ファイルを自動的に印刷して、”印刷済”フォルダへ移動するマクロを教えてご教示願えませんでしょうか?
よろしくお願い致します。


もともとのマクロはルールから呼び出すことを想定していましたが、「依頼票」と「予約」という二つのキーワードを含むというルールは作成ができないため、受信時に発生する NewMailEx イベントで条件をチェックし、条件に合致する場合に印刷するマクロを呼び出す必要があります。
以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
' 以下はソースの先頭に記載する必要があります。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                 (ByVal hwnd As Long, ByVal lpszOp As String, _
                  ByVal lpszFile As String, ByVal lpszParams As String, _
                  ByVal LpszDir As String, ByVal FsShowCmd As Long) _
                  As Long
'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objItem As Object
     ' 受信したアイテムの取得
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     ' アイテムがメールであり、件名に「依頼票」と「予約」を含む場合
     If TypeName(objItem) = "MailItem" And objItem.Subject Like "*依頼票*予約*" Then
         Dim objMail As MailItem
         Dim fldInbox As Folder
         Dim fldPrinted As Folder
         ' メールアイテムに変換
         Set objMail = objItem
         ' Excel の添付ファイルを印刷
         PrintExcelAttach objMail
         ' 受信トレイを取得
         Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
         ' 受信トレイの下の「印刷済」フォルダーを取得
         Set fldPrinted = fldInbox.Folders("印刷済")
         ' 受信トレイと同じ階層の「印刷済」フォルダーの場合は以下の記述を使用
         'Set fldPrinted = fldInbox.Parent.Folders("印刷済")
         ' 「印刷済」フォルダーにメールを移動
         objMail.Move fldPrinted
     End If
End Sub
'
Public Sub PrintExcelAttach(ByRef objItem As MailItem)
     On Error Resume Next
     Const ATTACH_PATH = "c:\temp\" ' 添付ファイルを保存するフォルダー
     Dim objAttach As Attachment
     Dim strFileName As String
     Dim c As Integer
     ' 添付ファイルの印刷
     Dim objFSO 'As FileSystemObject
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     For Each objAttach In objItem.Attachments
         If objAttach.FileName Like "*.xls*" Then
             ' ファイルが Excel の場合のみ保存して印刷
             c = 1
             With objAttach
                 strFileName = .FileName
                 While objFSO.FileExists(ATTACH_PATH & strFileName)
                     strFileName = Left(.FileName, InStrRev(.FileName, ".") - 1) _
                         & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                     c = c + 1
                 Wend
                 .SaveAsFile ATTACH_PATH & strFileName
             End With
             '    保存したファイルを印刷する
             ShellExecute 0, "print", ATTACH_PATH & strFileName, 0, ATTACH_PATH, 0
         End If
     Next
End Sub

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

選択した予定表フォルダーの特定の日に時間固定の予定を作成するマクロ

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


はじめまして。予定表において、時間帯と件名が決まっている予定(例AM9:00~12:00、件名:会議)を自動で入力できるマクロを作成しましたが、どうしても自分の予定表にしか登録されません。他人の予定や会議室などをクリックした状態でそのマクロを実行すると、クリックしているユーザーに対して予定が作成されるようなマクロを作成したいです。可能でしょうか。アドバイスを頂けると幸甚です。(ちなみに他のユーザーや会議室のアクセスは自由に書き込める設定となっています。バージョンは2010です)


予定表に新規で予定アイテムを作成するという場合、通常は CreateItem メソッドに olAppointmentItem を指定してアイテムを作成します。
しかし、この方法だと既定の予定表、つまり自分自身の予定表にアイテムが生成される動作となります。

現在選択している予定表にアイテムを追加するには、ActiveExplorer メソッドで取得した Explorer オブジェクトの CurrentFolder により選択しているフォルダーを取得し、その Items プロパティの Add メソッドでアイテムを追加します。
また、選択している日に時間帯を固定でアイテムを作成する場合は、ActiveExplorer の CurrentView プロパティで取得できる CalendarView オブジェクトの SelectedStartTime プロパティで選択範囲の開始日時を取得し、その日付をもとに開始日時と終了日時を設定します。

まとめると以下のようなマクロになります。

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

Public Sub AddAppointmentToSelected()
     ' 作成する予定の件名を指定
     Const APPT_SUBJECT = "会議"
     ' 作成する予定の開始時刻
     Const APPT_START_TIME = "9:00"
     ' 作成する予定の終了時刻
     Const APPT_END_TIME = "12:00"
     Dim fldCalendar As Folder
     Dim apptItem As AppointmentItem
     Dim strSelDate As String
     ' 現在選択しているフォルダーを取得
     Set fldCalendar = ActiveExplorer.CurrentFolder
     ' フォルダーの種類が予定表だった場合だけ追加
     If fldCalendar.DefaultItemType = olAppointmentItem Then
         ' 選択されている時間の開始日時を取得
         strSelDate = ActiveExplorer.CurrentView.SelectedStartTime
         ' 日付だけを取得
         strSelDate = FormatDateTime(strSelDate, vbShortDate)
         ' 選択されたフォルダーにアイテムを追加
         Set apptItem = fldCalendar.Items.Add()
         ' 件名、開始日時、終了日時を指定
         apptItem.Subject = APPT_SUBJECT
         apptItem.Start = strSelDate & " " & APPT_START_TIME
         apptItem.End = strSelDate & " " & APPT_END_TIME
         ' アイテムを保存
         apptItem.Save
     End If
End Sub

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

共有メールボックスに受信したメールの件名に連番を付与するマクロ

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


共有メールボックスに受信される「指定のメールボックス」に、受信したメールの件名に連番を自動で発番していくマクロはありますでしょうか。 そもそも、共有メールボックスにマクロを入れるのは不可能なのでしょうか。


共有メールボックスに受信したメールについてマクロを実行する方法については「共有メールボックスの受信トレイに追加されたメールの添付ファイルを保存するマクロ」で解説した通りです。

連番を自動で発番するとなると、発番済みの番号を管理する必要が出てきます。
VBA では SaveSetting ステートメントで VBA 固有のレジストリ キーに設定を保存し、GetSetting 関数で設定した値を読み込むことができます。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
' 共有フォルダーのイベントを取得するためのオブジェクト
Dim WithEvents sharedInboxItems As Items
'
Private Sub Application_Startup()
     ' 共有メールボックスの SMTP アドレスを指定
     Const SHARED_USER = "shareduser@example.com"
     Dim recShared As Recipient
     Dim fldSharedInbox As Folder
     ' 共有メールボックスのユーザー情報を取得
     Set recShared = Session.CreateRecipient(SHARED_USER)
     recShared.Resolve
     ' 共有メールボックスの受信トレイを取得
     Set fldSharedInbox = Session.GetSharedDefaultFolder(recShared, olFolderInbox)
     Set sharedInboxItems = fldSharedInbox.Items
End Sub
'
' 共有フォルダーの受信トレイにアイテムが追加された際に発生するイベント
Private Sub sharedInboxItems_ItemAdd(ByVal Item As Object)
     '
     Const APP_NAME = "OutlookLab"
     Const SEC_NAME = "SharedInboxCount"
     Const KEY_NAME = "LastCount"
     Dim iSeq As Integer
     Dim strPrefix As String
     '
     ' 必要に応じてここで条件指定
     '
     ' レジストリから連番を取得
     iSeq = CInt(GetSetting(APP_NAME, SEC_NAME, KEY_NAME, "0"))
     iSeq = iSeq + 1
     ' 件名に追加する文字列を生成
     strPrefix = "[" & iSeq & "] "
     ' 生成した文字列を懸命に追加
     Item.Subject = strPrefix & Item.Subject
     ' アイテムを保存
     Item.Save
     ' レジストリに連番を保存
     SaveSetting APP_NAME, SEC_NAME, KEY_NAME, iSeq
End Sub

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

選択されている複数のメールのメールヘッダー情報を Excel ファイルにエクスポートするマクロ

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


お世話になります。
  複数のメールのメールヘッダー情報をExcelへ一覧として出力する方法はありますでしょうか?

現在、一度に50件~100件のメールのメールヘッダー情報を手動で確認するという業務がありまして、
  1つ1つクリックしてヘッダー情報を確認するということが非常に手間でありますので、
なんとかこれを自動化したいと思い、Outlookマクロの勉強をはじめたのですが、
ネット上を探してもマクロでメールヘッダーを取り扱う際の情報があまりなく、
もしご存知でしたら、ご教示いただけないでしょうか?

お力添えいただけますと幸いです。


インターネットのメールヘッダーの情報は MAPI の PidTagTransportMessageHeaders というプロパティで取得が可能です。
このプロパティにアクセスするには、MailItem オブジェクトの PropertyAccessor プロパティの GetProperty メソッドに、PidTagTransportMessageHeaders を意味する “http:​//schemas.microsoft.com/mapi/proptag/0x007d001f” という文字列を渡します。
なお、この文字列は URL のように見えますが、実際にはこのような URL は存在せず、Outlook がこの URL にアクセスするようなこともありません。

これを使って、現在表示しているフォルダーで選択した複数のメールのメールヘッダーをまとめて Excel ファイルにエクスポートするマクロは以下のようになります。
なお、エクスポートする Excel ファイルはあらかじめ作成しておいてください。

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

Public Sub ExportInternetHeaders()
     Const PidTagTransportMessageHeaders = "http:" & _
         "//schemas.microsoft.com/mapi/proptag/0x007d001f"
     ' Excel のファイル名を指定
     Const EXCEL_FILE = "c:\temp\headers.xlsx"
     Dim objBook As Object 'Excel.Workbook
     Dim objSheet As Object 'Excel.Worksheet
     Dim iRow As Integer
     Dim objMail As MailItem
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     objBook.Windows(1).Activate
     ' シート 1 を取得
     Set objSheet = objBook.Worksheets(1)
     ' データが入っていない行を検索
     iRow = 1
     While objSheet.Cells(iRow, 1) <> ""
         iRow = iRow + 1
     Wend
     ' 現在のフォルダーで選択されているアイテムについて実行
     For Each objMail In ActiveExplorer.Selection
         With objMail
             ' 差出人を 1 列目にコピー
             objSheet.Cells(iRow, 1) = .SenderName
             ' 件名を 2 列目にコピー
             objSheet.Cells(iRow, 2) = .Subject
             ' 受信日時を 3 列目にコピー
             objSheet.Cells(iRow, 3) = .ReceivedTime
             ' ヘッダーを 4 列目にコピー
             objSheet.Cells(iRow, 4) = _
                 .PropertyAccessor.GetProperty(PidTagTransportMessageHeaders)
         End With
         ' 次の行に移動
         iRow = iRow + 1
     Next
     ' Excel ファイルを保存
     objBook.Close True
End Sub

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