受信したメールの件名でフォルダーをデスクトップ上に作成し、添付ファイルを保存するマクロ

受信したメールの添付ファイルを自動保存するマクロのコメントにて以下のご要望をいただきました。


お世話になっております。

自動保存マクロを利用させていただいており、たいへん助かっております。

質問なのですが、メールの件名のフォルダをデスクトップ上に作成し添付の保存をメール毎繰り返す。ということは可能でしょうか?
もし可能であればご教示頂けたらと思います。
よろしくお願い致します


デスクトップのフォルダー名を取得するには Environ 関数で取得した USERPROFILE という環境変数の値に \Desktop を追加します。
その下にメールの件名のフォルダーを作成する際に、件名には \ や :、* などファイル名に使用できない文字が含まれる場合があるため、それを別の文字に置き換える必要があります。
あとは受信したメールの添付ファイルの自動保存のマクロとほぼ同様ですが、件名は比較的長いものになる場合があるため、ファイルのパスの長さの制限を超えないようなロジックを加えてあります。
マクロは以下のようになります。

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

' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim i As Integer
    Dim c As Integer
    Dim colID As Variant
    '
     SaveAttachments EntryIDCollection
End Sub
'
' 添付ファイルの保存を行うサブ プロシージャ
Private Sub SaveAttachments(ByVal strEntryID As String)
    Const MAX_FOLDER_PATH = 130
    Const MAX_PATH = 260
    Dim strSaveRoot As String
    Dim strSaveFolder As String
    Dim objFSO As Object ' FileSystemObject
    Dim objMsg As Object
    Dim objAttach As Attachment
    Dim strFileBase As String
    Dim strExt As String
    Dim strFileName As String
    Dim c As Integer: c = 1
    '
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objMsg = Application.Session.GetItemFromID(strEntryID)
    ' デスクトップの下にフォルダーを作成
    strSaveRoot = Environ("USERPROFILE") & "\Desktop\"
'
' ここで条件指定
'
    ' 添付ファイルがなければ終了
    If objMsg.Attachments.Count = 0 Then
        Exit Sub
    End If
    ' 件名から保存するフォルダーのパスを生成
    strSaveFolder = strSaveRoot & ReplaceSpecialChar(objMsg.Subject)
    strSaveFolder = Left(strSaveFolder, MAX_FOLDER_PATH)
    ' フォルダーが存在しなければ作成
    If Not objFSO.FolderExists(strSaveFolder) Then
        objFSO.CreateFolder strSaveFolder
    End If
    '
    For Each objAttach In objMsg.Attachments
        With objAttach
            If InStr(.FileName, ".") > 0 Then
                ' ファイル名と拡張子を分離
                strFileBase = strSaveFolder & "\" & Left(.FileName, InStrRev(.FileName, ".") - 1)
                strExt = Mid(.FileName, InStrRev(.FileName, "."))
            Else
                strFileBase = strSaveFolder & "\" & .FileName
                strExt = ""
            End If
            strFileBase = Left(strFileBase, MAX_PATH - Len(strExt) - 4)
            '
            strFileName = strFileBase & strExt
            While objFSO.FileExists(strFileName)
                strFileName = strFileBase & "-" & c & strExt
                c = c + 1
            Wend
            .SaveAsFile strFileName
        End With
    Next
    Set objMsg = Nothing
    Set objFSO = Nothing
End Sub
' 件名から特殊文字を取り除く関数
Private Function ReplaceSpecialChar(strSubject As String) As String
    ReplaceSpecialChar = ""
    For i = 1 To Len(strSubject)
        ch = Mid(strSubject, i, 1)
        If InStr("\/:*?""|", ch) > 0 Then
            ch = "_"
        End If
        ReplaceSpecialChar = ReplaceSpecialChar & ch
    Next
End Function

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

固定の出席者や場所などを設定した会議出席依頼のテンプレートを作成する方法

テンプレートに自動で今日の日付を設定するマクロのコメントにて以下のご要望をいただきました。


突然すみません。

会議案内の日時をその時に任意で指定したい場合どうマクロを組むのでしょうか?
  送信相手と会議場所は毎回固定です。

ご教授頂けますよう、よろしくお願い致します。


会議出席依頼の出席者や場所などに固定の値を設定するのであれば、マクロを使う必要はありません。
Outlook のカスタム フォームにより実現が可能です。

  1. 予定表を開きます。
  2. [新しい会議] をクリックします。
  3. あらかじめ指定しておきたい出席者と場所などを設定します。
  4. [開発] リボンの [発行]-[フォームの発行] をクリックします。
    ([開発] リボンが表示されない場合はリボンのカスタマイズをして [開発] リボンを表示させてください。)
  5. [フォルダーの場所] で [Outlook フォルダー] を選択します。
  6. 表示名に適切な名前を入力し、[発行] をクリックします。
  7. 作成中のアイテムを破棄します。

このようにして発行したフォームは以下のようにして使用できます。

  1. 予定表で会議を設定したい時間帯を選択します。
  2. [新しいアイテム]-[ユーザー設定フォーム]-[上記で入力した名前] をクリックします。

選択したメールの差出人からのメールを特定のフォルダーに移動するルールを作成して実行するマクロ

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


仕分けルール設定のされていない宣伝メールについてご相談したく質問させていただきました。

毎回、都度新しい仕分けルールで
①受信トレイの中のメールを選択
②ルール → 仕分けメールの作成
③「差出人が次の場合」をチェック
④「アイテムをフォルダーに移動する」 ※ここで受信トレイの下位に「広告メール」というフォルダを事前に準備していますので、このフォルダを選択します。
⑤ルール作成後に、「現在のフォルダーにあるメッセージにこの仕分けルールを今すぐ実行する」をチェックし、OKをクリック
⑥ルール仕分け作成およびメールの移動が完了

都度やっているのですが、マクロ化は可能でしょうか?

大変恐れ入りますがOutlookのマクロの知識に乏しくご教示いただけると幸甚に存じます。
  何卒宜しくお願いいたします。


マクロでルールを作成するには、まず、Session オブジェクトの DefaultStore プロパティの GetRules を使用して、既定のストアのルール一覧を Rules コレクションとして取得します。
次に、Rules の Create メソッドで受信時のルールを意味する olRuleReceive を指定して新規ルールを作成します。

作成したルールに条件を追加するには、取得した Rule オブジェクトの Conditions コレクションから  From プロパティを使用して ToOrFromRuleCondition オブジェクトを取得します。
そして、このオブジェクトの Enabled プロパティを True にして有効化し、Recipients プロパティの Add メソッドでメールの差出人のアドレスと表示名を追加した後で ResolveAll メソッドにより名前解決を行います。

また、ルールにアクションを追加するには、同じ Rule オブジェクトの Actions コレクションから MoveToFolder プロパティを使用してMoveOrCopyRuleAction オブジェクトを取得します。
そして、このオブジェクトの Enabled プロパティを True にして有効化し、Folder プロパティに移動先のフォルダーを設定します。

最後に、Rules オブジェクトの Save メソッドにより新しいルールを保存し、Rule オブジェクトの Execute メソッドで作成したルールを実行します。

実装すると以下のようなマクロになります。CreateRuleAndMove “フォルダー名” を実行するマクロを作成することで、他のフォルダーに移動するマクロも簡単に追加できます。

' ここをトリプルクリックでマクロ全体を選択できます。
' メールを選択して呼び出すマクロ
Public Sub MoveToKoukoku()
     ' フォルダー名を指定して実行
     CreateRuleAndMove "広告"
End Sub
' ルールを作成して実行するサブプロシージャ
Private Sub CreateRuleAndMove(strFolder As String)
     Dim objItem As MailItem
     Dim fldTarget As Folder
     Dim colRules As Rules
     Dim ruleNew As Rule
     Dim condFrom As ToOrFromRuleCondition
     Dim actMove As MoveOrCopyRuleAction
     ' メール一覧で選択されているメールを取得
     Set objItem = ActiveExplorer.Selection(1)
     ' ストアからルール一覧を取得
     Set colRules = Session.DefaultStore.GetRules()
     ' 差出人の名前でルールを作成
     Set ruleNew = colRules.Create(objItem.SenderName, olRuleReceive)
     ' 差出人の条件を作成
     Set condFrom = ruleNew.Conditions.From
     With condFrom
         ' 条件を有効化
         .Enabled = True
         ' 差出人のアドレスを条件に追加
         If objItem.SenderName = objItem.SenderEmailAddress Then
             .Recipients.Add objItem.SenderEmailAddress
         Else
             .Recipients.Add objItem.SenderName & _
                 " <" & objItem.SenderEmailAddress & ">"
         End If
         ' 差出人のアドレスを解決
         .Recipients.ResolveAll
     End With
     ' 移動先フォルダーを取得
     Set fldTarget = Session.GetDefaultFolder(olFolderInbox).Folders(strFolder)
     ' 移動のアクションを作成
     Set actMove = ruleNew.Actions.MoveToFolder
     With actMove
         ' アクションを有効化
         .Enabled = True
         ' 移動先フォルダーを指定
         .Folder = fldTarget
     End With
     ' ルールを保存
     colRules.Save
     ' 作成したルールを実行
     ruleNew.Execute True
End Sub

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

送信済みアイテム フォルダーのメールの情報を Excel ファイルにエクスポートするマクロ

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


お世話になっております。
outlookでマクロが使えることをはじめて知り、本サイトを参考に試させているのですが、うまくいかずヘルプをお願いしした次第です。
本サイトや他のサイトでも、受信トレイやサブフォルダーのデータをエクセルへエクスポートする方法の記述はあるのですが、送信済みトレイのエクスポート方法が見当たりません。
やりたいことは以下の通りです。

・エクスポートしたい送信期間を設定する
・ターゲットは「送信済みトレイ」
・エクスポートしたい情報は「送信日時」「送信先」「件名」

それほど難しいことではないと思いますが知識が乏しく、お手数をお掛けいたしますが、ご教示いただけると大変助かります。
よろしくお願いします。


まず、マクロでユーザーからの入力を受け付けるには InputBox を使用します。
また、送信済みアイテム フォルダーは Session の GetDefaultFolder メソッドで olFolderSentMail を指定して取得します。
そして、送信期間のアイテムだけを抽出するには Items オブジェクトの Restrict メソッドを使用します。
あとは、Restrict で返された Items に含まれるメールの情報を Excel のセルに転記するという処理になります。
マクロは以下のようになります。

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

Public Sub ExportSentItemsToExcel()
     On Error Resume Next
     Dim strSaveFileName As String
     Dim dtStart As Date
     Dim dtEnd As Date
     Dim xlApp
     Dim xlBook
     Dim xlSheet
     Dim r As Integer
     Dim fldSent As Folder
     Dim strFilter As String
     Dim colItems As Items
     Dim objMail As Object
     ' Excel ファイル名、開始日時、終了日時の入力
     strSaveFileName = InputBox("Excel ファイル名", "Excel へエクスポート")
     dtStart = CDate(InputBox("開始日時", "Excel へエクスポート"))
     dtEnd = CDate(InputBox("終了日時", "Excel へエクスポート"))
     If dtEnd < dtStart Then
         Dim dtTemp As Date
         dtTemp = dtStart
         dtStart = dtEnd
         dtEnd = dtTemp
     End If
     ' Excel の Application オブジェクトを生成
     Set xlApp = CreateObject("Excel.Application")
     ' 新規ワークブックを作成
     Set xlBook = xlApp.Workbooks.Add
     xlBook.Windows(1).Activate
     Set xlSheet = xlBook.Sheets(1)
     ' 1 行目はタイトルとして使用
     With xlSheet
         .Cells(1, 1) = "送信日時"
         .Cells(1, 2) = "宛先"
         .Cells(1, 3) = "Cc"
         .Cells(1, 4) = "Bcc"
         .Cells(1, 5) = "件名"
     End With
     ' 2 行目からデータ
     r = 2
     ' 送信済みフォルダーを取得
     Set fldSent = Session.GetDefaultFolder(olFolderSentMail)
     ' 開始日時と終了日時のアイテムを取得
     strFilter = "[送信日時] >= '" & FormatDateTime(dtStart, vbShortDate) _
         & " " & Format(dtStart, "HH:MM") & "' and [送信日時] < '" _
         & FormatDateTime(dtEnd, vbShortDate) & " " & Format(dtEnd, "HH:MM") & "'"
     Set colItems = fldSent.Items.Restrict(strFilter)
     ' フォルダー内のすべてのアイテムについて処理
     For Each objMail In colItems
         With xlSheet
             ' 送信日時を A 列にコピー
             .Cells(r, 1) = objMail.SentOn
             ' 宛先を B 列にコピー
             .Cells(r, 2) = objMail.To
             ' CC を C 列にコピー
             .Cells(r, 3) = objMail.CC
             ' Bcc を D 列にコピー
             .Cells(r, 4) = objMail.BCC
             ' 件名を E 列にコピー
             .Cells(r, 5) = objMail.Subject
         End With
         r = r + 1
     Next
     ' Excel ファイルに名前を付けて保存
     xlBook.SaveAs strSaveFileName
     xlBook.Close
     ' Excel を終了
     xlApp.Quit
End Sub

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

複数のアドレスごとに決まったパターンの複数のファイルを添付してメールを送信するマクロ

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


現在、複数のアドレスに、それぞれ異なるPDFファイル(ファイルの名前は全部違う、数字①_日付け_数字②で次のような形、000000_20190929_00)を添付して、メールを送っています。アドレスが600件、添付ファイルは2,000個位を毎月手作業で毎回添付してから送信しています。

数字①が同じものは、同じ人に送信するので、自動でPDFファイルをメールアドレスに添付できるマクロを作成できればと考えています。ファイル名の一部だけ同じものを自動で添付できるのか?
人によって添付ファイルは3個だったり10個だったり、毎月決まっていません。

マクロでこのような作業はできるでしょうか?
マクロの作り方を、教えていただけたら、大変たすかります。
outlook2010、windows7を使っています。


ご質問の作業をマクロで実施する場合、以下のような流れになると考えられます。

  1. あらかじめ、宛先アドレスと数字①のペアをテキスト ファイルに記載しておく
  2. 添付する PDF ファイルは同じフォルダーにまとめて格納しておく
  3. 1. のファイルを読み込み 2. のファイルを条件に応じて添付して送信するマクロを実行する

まず、宛先アドレスと数字① (プレフィックス) については、以下のような書式でテキスト ファイルに書き込みます。

user1@example.com,0000000
user2@example.com,0000001
user3@example.com,0000002

このファイルをマクロで読み込むには、Open ステートメントでファイルを開き、Input ステートメントで 1 行ずつ文字列を取り込みます。
特定のフォルダーからプレフィックスの文字列で始まるファイルを取得するには、Dir 関数を使用します。
Dir 関数の引数として “c:\temp\000000*.pdf” というような文字列を指定すると、c:\temp フォルダーに含まれる 000000 から始まる PDF ファイルのファイル名が取得できます。

マクロは以下のようになります。
LIST_FILE にはアドレスとプレフィックスを格納したテキスト ファイル名、ATT_FOLDER には添付する PDF ファイルを保存するフォルダー、SUBJECT_TEXT には送信するメールの件名、BODY_TEXT には送信するメールの本文を記載してください。

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

Public Sub SendBulkMailWithAttachment()
     Const LIST_FILE = "c:\temp\list.txt"
     Const ATT_FOLDER = "c:\temp"
     Const SUBJECT_TEXT = "添付ファイル送付"
     Const BODY_TEXT = "添付ファイルを送信します。"
     Dim strAddr As String
     Dim strPrefix As String
     Dim objMail As MailItem
     Dim strFile As String
     ' アドレスとプレフィックスのリストを開く
     Open LIST_FILE For Input As #1
     ' リスト ファイルの終わりまで繰り返し
     While Not EOF(1)
         ' ファイルの内容を 1 行読み込み
         Input #1, strAddr, strPrefix
         ' 新規メール作成
         Set objMail = CreateItem(olMailItem)
         ' あて先を設定
         objMail.To = strAddr
         ' 件名と本文を設定
         objMail.Subject = SUBJECT_TEXT
         objMail.Body = BODY_TEXT
         ' 添付ファイルを格納しているフォルダーからプレフィックスで始まるファイル一覧の取得
         strFile = Dir(ATT_FOLDER & "\" & strPrefix & "*.pdf")
         While strFile <> ""
             ' ファイルを添付
             objMail.Attachments.Add ATT_FOLDER & "\" & strFile
             ' 次のファイル名を取得
             strFile = Dir()
         Wend
         ' メールを送信
         objMail.Send
     Wend
     ' リスト ファイルを閉じる
     Close #1
End Sub

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

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

11/5 に Outlook 2016 の累積的な修正プログラムがリリースされました。 以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

Outlook 2016 (KB4484139) の 2019 年 11 月 5 日更新 5 件の修正が行われています。

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

Office 2016 (KB4484145) の 2019 年 11 月 5 日更新 1 件の Outlook に関する修正が行われています。

Exchange/Office 365/Outlook.com 環境で NewMailEx が動作しない場合がある

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


いつも参考にさせていただいております。
  特定の題名のメールを受信した際、自動的にテキスト型に変更しファイルとして保存するためのマクロを作ったのですが、PC立ち上げをしている時にしか動かない問題が発生しました。
  基本、帰宅時はPCの電源を切っているのですが、PCを立ち上げていないときにもメールを受信してしまうようで(Office365だからでしょうか)せっかくのマクロの意味が半分なしていないので、どうにかしたいと考えております。

お知恵がございましたら、ご教示いただければ幸いです。

OSバージョン:Windows 10
  Outlookバージョン:Microsoft Outlook for Office 365 MSO 64 ビット
  よろしくお願いいたします。


通常、メールを受信した際の処理のマクロは NewMailEx イベントで記述しますが、Exchange サーバーに接続する環境 (Office 365 や Outlook.com を含む) では、Outlook を起動していないタイミングで受信したメールについては NewMailEx が実行されません。
これは、Exchange に接続している場合に NewMailEx がサーバーからの新着メールの通知により実行されており、Outlook が接続していない状況で受信したメールについてはサーバーからの新着メールの通知が受け取れないためです。

これを回避するにはメールの受信時に実行するマクロを NewMailEx イベントから起動するのではなく、自動仕分けのルールのアクションにある「スクリプトを実行する」によりマクロを実行します。
ただし、2017 年 5 月以降にリリースされた修正プログラムが適用されている場合、「スクリプトを実行する」を使用するには以下のレジストリ設定が必要となります。

Outlook 2016 のキー: HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Security\
Outlook 2013 のキー: HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Outlook\Security\
値の名前: EnableUnsafeClientMailRules
値の種類: REG_DWORD
値のデータ: 1

そして、「スクリプトを実行する」で実行するマクロのプロシージャについて以下のような形式で定義します。

Public Sub プロシージャ名(ByRef メール変数名 As MailItem)

ポイントとしては変数名の前に ByRef を付けるということと、変数名の後ろに As MailItem を付けるというものがあります。
これらの指定がない場合、スクリプトを実行するで追加するマクロとして表示されません。

NewMailEx では引数としてアイテムのエントリ ID が指定されますが、マクロで実行されるプロシージャについては受信したメールを格納した MailItem オブジェクト自体が引数として渡されます。
そのため、GetItemFromID によりアイテムを取得するという処理が省略できます。
また、マクロ実行の条件が自動仕分けのルールで指定可能なものである場合、マクロ自体で条件判定を行う必要がないというメリットもあります。

なお、アクションとしてスクリプトの実行を指定したルールはクライアント ルールとなり、Outlook が起動していない場合は動作しません。
そのため、あくまでもマクロの実行自体は Outlook が起動中に実行され、ルールで指定したマクロが Outlook を起動していない状態でサーバーにより実行されるわけではないという点にご注意ください。
また、Outlook が起動していないときに受信したメールのルールは Outlook の起動時にまとめて実行されるので、長期休暇中にルールに合致するメールを大量に受信していたような場合に、Outlook の起動に時間がかかったり、一部のルールが実行されなかったりする可能性があります。
そのため、Outlook を起動していない状態でマクロ処理が必要なメールを多数受信するようであれば、マクロ処理が必要なメールをルールで別フォルダーに移動しておき、受信時ではなく適切なタイミングでフォルダー上のすべてのアイテムにマクロを実行するというようなフローにしたほうが良いかもしれません。