Outlookで添付ファイルを残した状態で返信メールを作成するExcelVBA

スポンサーリンク

毎日のメール処理の時短ツールの紹介

私の仕事の中で研修の申込書をメールで受け取って集計する業務があります。
VBAで自動集計するため専用のExcelフォーマットをメールで送っていただく運用にし、受付専用のメールアドレスを指定しているのですが、申し込みをしてくる対象者が多いためか徹底されず違うメールアドレスに送ってくることが多くあります。

異なるアドレスに送られてきた申込書は受付しないで拒否する手もあるのですが、なるべく親切にしたいなという思いから、

  • ①きちんと正しいアドレスに送るように連絡
  • ②メールに添付されている申込書を正しいアドレスに転送
  • の流れで処理をしています。

    このメールを2つ送る作業が何気に面倒で、前回は①の返信を自動で作成できるVBAコードを考えてみました。
    今回は②のメールに添付されている申込書を正しいアドレスに転送する部分を自動化したいと思いVBAコードを考えてみました。

    添付ファイルを残して返信したい

    先ほどの②メールに添付されている申込書を正しいアドレスに転送に関して、単純に転送を用意するのでも良いのですが、どうせなら一度で済むように①の申込書の送信元に送るメールに添付を付けた状態にしておいて、CCに正しいアドレスを入力する方法を考えました。

    ここで肝心なのが元のメールにある添付を残した状態で返信メールを作成することです。

    通常Outlookの転送では添付そのまま残りますが、返信では添付がなくなります。
    これはいただいた添付を他の人に伝える目的の転送と異なり、送信者にそのままの状態で返信するケースが少ないからと推測されます。

    実際Outlook以外のメーラーでも同様の挙動になると思います。

    スポンサーリンク

    添付ファイルを残した状態で返信メールを作成するExcelVBAコード

    Outlookの標準の機能では返信メールに添付を残す方法がないようなので、VBAで機能を考える必要がありました。
    具体的な方法としては下記2通りを考えてみました。

  • ①返信メールを作成→元のメールの添付をダウンロード→返信メールに添付
  • ②転送メールを作成→宛先に元のメールの送信者とToを指定する(→おまけ:件名の「Fw」を「Re」に変更する)
  • これら2つのコードについて順にご紹介します。

    なお、ベースとして前回ご紹介したExcelのワークシートに追加宛先・追加CC・件名・本文などの記入フォーマットを用意しています。

    123-1Excel表

    ①返信メールを作成→元のメールの添付をダウンロード→返信メールに添付

    Sub 返信メール作成添付保持1()

    Dim 本文

    本文 = ActiveSheet.Cells(5, 2)
    本文 = Replace(本文, vbLf, “<br />”) ’本文の改行文字をHTML用に

    Dim oApp As New Outlook.Application
    Dim objItem As Outlook.MailItem
    ’選択しているメールのMailItemオブジェクトを取得
    Set objItem = oApp.ActiveExplorer.Selection.Item(1) ’インデックスは1番から開始

    Dim objReply As Outlook.MailItem
    ’ReplyAll→全員に返信、Reply→返信
    Set objReply = objItem.ReplyAll

    If Cells(6, 2) <> “” Then ’送信アカウントの設定が必要な場合
    objReply.SendUsingAccount = Session.Accounts(Cells(6, 2).Text)
    End If

    If Cells(2, 2) <> “” Then ’Toの設定 置き換えではなく追加
    objReply.To = objReply.To & “; ” & Cells(2, 2)
    End If

    If Cells(3, 2) <> “” Then ’CCの設定 置き換えではなく追加
    objReply.CC = objReply.CC & “; ” & Cells(3, 2)
    End If

    If Cells(4, 2) <> “” Then ’件名の設定 置き換え
    objReply.Subject = Cells(4, 2)
    End If

    宛名 = objItem.SenderName & “<br />” & “ご担当者さま”

    objReply.HTMLBody = “<font size=2.8>” & 宛名 & “<br /> “<br />” & 本文 & “” & objReply.HTMLBody

    Dim j
    Dim FSO As Object
    Set FSO = CreateObject(“Scripting.FileSystemObject”)
    Dim Path As String, WSH As Variant
    Set WSH = CreateObject(“Wscript.Shell”)
    Dim DesktopPath As String
    DesktopPath = WSH.SpecialFolders(“Desktop”)
    Dim 一時フォルダ名
    一時フォルダ名 = “一時フォルダ”

    ’デスクトップに一時格納用のフォルダ作成
    If FSO.FolderExists(DesktopPath & “” & 一時フォルダ名) = False Then
    FSO.CreateFolder DesktopPath & “” & 一時フォルダ名
    Else
    MsgBox “一時フォルダが作成できないので中断します”
    Exit Sub
    End If

    ’作成したフォルダに添付ファイルをダウンロードしつつ返信メールに添付していく
    For j = 1 To objItem.Attachments.Count
    objItem.Attachments(j).SaveAsFile (DesktopPath & “” & 一時フォルダ名 & “” & objItem.Attachments(j).DisplayName)
    objReply.Attachments.Add DesktopPath & “” & 一時フォルダ名 & “” & objItem.Attachments(j).DisplayName
    ’添付ファイルが同じ名前だった場合に上書きするのを防止する目的で削除しておく
    FSO.DeleteFile DesktopPath & “” & 一時フォルダ名 & “” & objItem.Attachments(j).DisplayName
    Next j

    ’デスクトップの一時格納用フォルダの削除
    FSO.DeleteFolder DesktopPath & “” & 一時フォルダ名

    Set FSO = Nothing

    objReply.Display ’画面を表示する
    objReply.Save ’下書き保存
    ’objReply.Close 0 ’閉じる

    Set objReply = Nothing
    Set objItem = Nothing

    End Sub

    元のメールの添付ファイルを一度ダウンロードし、返信メールに添付した後ダウンロードしたファイルを削除するフローで考えました。

    デスクトップにフォルダを作成し、そのフォルダにダウンロードするのですが、同じ名前のフォルダがあると誤って削除しないように中断するようにしています。
    一時フォルダの名前を普段使わないような名称にすればカブることもないと思いますし、手順は回りくどいですが一応目的の機能は達しています。

    ②転送メールを作成→宛先に元のメールの送信者とToを指定する

    Sub 返信メール作成添付保持2()

    ’転送メールを作成した後、返信メールに変更する
    Dim 本文, 件名

    本文 = ActiveSheet.Cells(5, 2)
    本文 = Replace(本文, vbLf, “<br />”) ’本文の改行文字をHTML用に

    Dim oApp As New Outlook.Application
    Dim objItem As Outlook.MailItem
    ’選択しているメールのMailItemオブジェクトを取得
    Set objItem = oApp.ActiveExplorer.Selection.Item(1) ’インデックスは1番から開始

    Dim objForward As Outlook.MailItem
    Set objForward = objItem.Forward

    If Cells(6, 2) <> “” Then ’送信アカウントの設定が必要な場合
    objForward.SendUsingAccount = Session.Accounts(Cells(6, 2).Text)
    End If

    objForward.To = objItem.To & “;” & objItem.SenderEmailAddress ’元のメールのToと差出人本人をToに設定(自分も追加される)
    objForward.To = Replace(objForward.To, objForward.SendUsingAccount.SmtpAddress, “”) ’自分のメールアドレスは削除

    If Cells(2, 2) <> “” Then ’Toの追加がある場合
    objForward.To = objForward.To & “; ” & Cells(2, 2)
    End If

    objForward.CC = objItem.CC ’CCに元のメールのCCを設定
    If Cells(3, 2) <> “” Then ’CCの追加がある場合
    objForward.CC = objForward.CC & “; ” & Cells(3, 2)
    End If

    objForward.Subject = Replace(objForward.Subject, “Fw”, “Re”) ’件名の「Fw」を「Re」に変更する
    If Cells(4, 2) <> “” Then ’件名の設定 置き換え
    objForward.Subject = Cells(4, 2)
    End If

    宛名 = objItem.SenderName & “<br />” & “ご担当者さま”
    objForward.HTMLBody = “<font size=2.8>” & 宛名 & “<br /><br />” & 本文 & “</font size>” & objForward.HTMLBody

    objForward.Display ’画面を表示する
    objForward.Save ’下書き保存
    ’objForward.Close 0 ’閉じる

    Set objForward = Nothing
    Set objItem = Nothing

    End Sub

    転送メールを作成した後の宛先の作り方が難しく、届いたメールの宛先が複数ある場合で送信元とは別の宛先に送る場合にアカウント名で表示されているとうまくメールが送れなくなります。

    宛先の作成は送信元のみにすればエラー回避できますが、複数の宛先に送れないという意味で機能が制限されています。

    ①の添付を後で作成する方が実用的な気がします。

    コメント