特定の文字列で始まる件名のメールを受信した際に、その受信日時と本文中のデータを 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

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

広告

Outlook 2010 以降で Word から差し込み印刷によりメールを送信する際に表示される警告ダイアログを表示させないようにする方法

Word から差し込み印刷によりメールを送信する際に表示される警告ダイアログを表示させないようにする方法のコメントにて以下のご質問をいただきました。


いつも参考させていただき、大変助かっております。ありがとうございます。
Outlook 2013(windows7)を使用しているのですが、同じ操作をしても大丈夫でしょうか?

Word2010、Outlook2010を使っていて、書式なしで送信しているのですが、アドバイスの通りの対処をしても相変わらず警告が出ます。何かお知恵はありますか。


リンク先の記事では Outlook 2007 に関してのみ記載していましたが、Outlook 2010 以降でも同様のセキュリティ強化が行われており、レジストリ設定をしなければダイアログが表示されます。
回避策はレジストリ設定となるのですが、Outlook のバージョンにより設定すべきキーが異なります。
手順は以下の通りとなります。

  1. スタート メニューの [ファイル名を指定して実行] で “Regedit.exe” と入力し、[OK] をクリックします。
  2. 以下のレジストリ キーを左ペインで探し、クリックします。なければキーを作成します。
    • Outlook 2010 の場合
      HKEY_CURRENT_USER\Software\Policies\Microsoft\Office\14.0\Outlook\Security
    • Outlook 2013 の場合
      HKEY_CURRENT_USER\Software\Policies\Microsoft\Office\15.0\Outlook\Security
    • Outlook 2016/2019 の場合
      HKEY_CURRENT_USER\Software\Policies\Microsoft\Office\16.0\Outlook\Security
  3. [編集]-[新規]-[DWORD 値] をクリックします。
  4. 名前に “PromptSimpleMAPINameResolve” と入力します。
  5. [PromptSimpleMAPINameResolve] を右クリックし、[修正] をクリックします。
  6. [値のデータ] に 2 と入力して [OK] をクリックします。(元に戻すには 1 を入力します。)
  7. [編集]-[新規]-[DWORD 値] をクリックします。
  8. 名前に “PromptSimpleMAPISend” と入力します。
  9. [PromptSimpleMAPISend] を右クリックし、[修正] をクリックします。
  10. [値のデータ] に 2 と入力して [OK] をクリックします。(元に戻すには 1 を入力します。)
  11. レジストリ エディタを終了します。

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

3/5 に Outlook 2016/2013/2010 の累積的な修正プログラムがリリースされました。

以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

2019 年 3 月 5日更新プログラム Outlook 2016 (KB4462196)
2 件の機能追加と 6 件の不具合修正が行われています。

Word 2016 の修正

Word 2016 (KB4462193) の更新プログラムを 2019 年 3 月 5日
1 件の Outlook に関する不具合の修正が行われています。

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

2019 年 3 月 5日更新プログラム Office 2016 Language Interface Pack (KB4462194)

2019 年 3 月 5日更新プログラム Office 2016 (KB4462214)
それぞれ 1 件ずつ Outlook に関する不具合の修正が行われています。

Office 2013

Outlook 2013 の修正

2019 年 3 月 5日更新プログラム Outlook 2013 (KB4462206)
1 件の機能追加 (ただし、64 ビット版のみ) と 1 件の不具合修正が行われています。

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

2019 年 3 月 5日更新プログラム Office 2013 (KB4092455)

2019 年 3 月 5日更新プログラム Office 2013 (KB4462201)
それぞれ 1 件ずつ Outlook に関する不具合の修正が行われています。

Office 2010

Outlook 2010 の修正

2019 年 3 月 5日は、Outlook 2010 (KB4462229) の更新します。
1 件の機能追加が行われています。

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

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


メール本文画面上で選択範囲のみを綺麗に改行したく、本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

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