毎日のメール処理の時短ツールの紹介
私の仕事の中で研修の申込書をメールで受け取って集計する業務があります。
VBAで自動集計するため専用のExcelフォーマットをメールで送っていただく運用にし、受付専用のメールアドレスを指定しているのですが、申し込みをしてくる対象者が多いためか徹底されず違うメールアドレスに送ってくることが多くあります。
異なるアドレスに送られてきた申込書は受付しないで拒否する手もあるのですが、なるべく親切にしたいなという思いから、
の流れで処理をしています。
このメールを2つ送る作業が何気に面倒で、前回は①の返信を自動で作成できるVBAコードを考えてみました。
今回は②のメールに添付されている申込書を正しいアドレスに転送する部分を自動化したいと思いVBAコードを考えてみました。
添付ファイルを残して返信したい
先ほどの②メールに添付されている申込書を正しいアドレスに転送に関して、単純に転送を用意するのでも良いのですが、どうせなら一度で済むように①の申込書の送信元に送るメールに添付を付けた状態にしておいて、CCに正しいアドレスを入力する方法を考えました。
ここで肝心なのが元のメールにある添付を残した状態で返信メールを作成することです。
通常Outlookの転送では添付そのまま残りますが、返信では添付がなくなります。
これはいただいた添付を他の人に伝える目的の転送と異なり、送信者にそのままの状態で返信するケースが少ないからと推測されます。
実際Outlook以外のメーラーでも同様の挙動になると思います。
スポンサーリンク
添付ファイルを残した状態で返信メールを作成するExcelVBAコード
Outlookの標準の機能では返信メールに添付を残す方法がないようなので、VBAで機能を考える必要がありました。
具体的な方法としては下記2通りを考えてみました。
これら2つのコードについて順にご紹介します。
なお、ベースとして前回ご紹介したExcelのワークシートに追加宛先・追加CC・件名・本文などの記入フォーマットを用意しています。
①返信メールを作成→元のメールの添付をダウンロード→返信メールに添付
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を指定する
’転送メールを作成した後、返信メールに変更する
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
転送メールを作成した後の宛先の作り方が難しく、届いたメールの宛先が複数ある場合で送信元とは別の宛先に送る場合にアカウント名で表示されているとうまくメールが送れなくなります。
宛先の作成は送信元のみにすればエラー回避できますが、複数の宛先に送れないという意味で機能が制限されています。
①の添付を後で作成する方が実用的な気がします。
コメント