特定の件名のメールを受信するたびに特定の 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

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

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

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

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

Office 2016

Outlook 2016 の修正

Outlook 2016 (KB4462147) の更新プログラムを 2019 年 2 月 5日
8 件の不具合修正が行われています。

Word 2016 の修正

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

Office 2013

Outlook 2013 の修正

Outlook 2013 (KB4462141) の更新プログラムを 2019 年 2 月 5日
1 件の不具合修正が行われています。

Office 2010

Outlook 2010 の修正

2019 年 2 月 5日は、Outlook 2010 (KB4462182) の更新します。
1 件の不具合修正が行われています。

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

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


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


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

連番を自動で発番するとなると、発番済みの番号を管理する必要が出てきます。
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

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

共有メールボックスの受信トレイに追加されたメールの添付ファイルを保存するマクロ

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


いつもこちらのサイトで勉強させて頂いております。

以下のマクロ(受信したメールの添付ファイルを自動保存するマクロ)を、共有メールフォルダーに対しても受信をトリガーに実行したいのですが、どのようにスクリプトを書けば良いでしょうか。

https://outlooklab.wordpress.com/2007/03/10/%E5%8F%97%E4%BF%A1%E3%81%97%E3%81%9F%E3%83%A1%E3%83%BC%E3%83%AB%E3%81%AE%E6%B7%BB%E4%BB%98%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E8%87%AA%E5%8B%95%E4%BF%9D%E5%AD%98%E3%81%99%E3%82%8B%E3%83%9E

なお、outlook 2010を使用しています。

どうぞよろしくお願い致します。


自分自身のメールボックスの受信トレイに受信したメールについては NewMailEx イベントを使用しますが、それ以外のフォルダーに関しては、そのフォルダーの Items プロパティの ItemAdd イベントを使用します。
ただ、このイベントを使用するためには、イベントが発生するフォルダーの Items を WithEvents 句付きでグローバル変数として定義し、Application_StartUp でそのグローバル変数に該当する Items オブジェクトを格納する必要があります。

マクロは以下のようになります。

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

' 共有フォルダーのイベントを取得するためのオブジェクト
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 SAVE_PATH = "C:\temp\"
     Dim objFSO As Object ' FileSystemObject
     Dim objAttach As Attachment
     Dim strFileName As String
     Dim c As Integer: c = 1
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     '
     ' 必要に応じてここで条件指定
     '
     For Each objAttach In Item.Attachments
         With objAttach
             strFileName = SAVE_PATH & objAttach.FileName
             While objFSO.FileExists(strFileName)
                 strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _
                     & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                 c = c + 1
             Wend
             .SaveAsFile strFileName
         End With
     Next
     Set objMsg = Nothing
     Set objFSO = Nothing
End Sub

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