はじめに
同じ内容のメールを、異なる宛先へ、メール本文の送信先の会社名・担当者名を変更しながら、1件ずつ、送信したい。
これを手作業でやると、間違いも発生しやすく、何より面倒だ。
そのため、エクセルを使って、宛先、本文を差し込んだメールを作成する方法を模索した。
作成までの経緯
前提として、動作環境は以下の通りである。
・Windows11
・使用しているメーラーはWebメールの「Outlook on the web」
・ブラウザは「Microsoft Edge」
当初、mailtoを使った方法を考えた。
しかし、文字数制限があるため、長い本文が入りきらず、諦めた。
次に、以下URLを参考にディープリンクを使った方法を試した。
だが、CC、BCCに対応できない、こちらも、文字数が一定以上になるとエラーになるなど、問題があった。
特に、悩んだのが、本文の長さによる文字数制限エラーだ。
どうしても本文を短くできず、最終的に、本文を差し込むのは諦めた。
結局、mailtoリンクを使って、宛先、件名、CC、BCCのみを差し込んだメールを作成し、メール本文は、クリップボードに本文を送るまでは自動化し、作成したメール画面で本文を貼り付ける作業だけ、手作業とする運用にした。
完全自動化ではないが、ほとんど自動化できたので、許容範囲としたい。
事前設定
mailtoリンクで、Outlook on the webをMicrosoft Edgeで開くには、事前設定が必要になる。
事前設定手順
１. 既定のアプリのMAILTOを設定する
①Windowsの設定画面から、「アプリ」⇒「既定のアプリ」の画面を開く
【Windows設定の既定のアプリ選択画面】
②検索欄に「mailto」と入力、MAILTOの既定を「Microsoft Edge」に変更する。
【既定のアプリ MAILTO設定画面】
２. ブラウザのプロトコルハンドラー設定
① Microsoft Edgeの設定画面から、「Cookieとサイトのアクセス許可」⇒「プロトコルハンドラー」を開く
【Microsoft Edge 設定画面 プロトコルハンドラー選択画面】
②「サイトがプロトコルの既定のハンドラーとなることを求めることを許可する」をオンにする
【プロトコルハンドラー許可 設定画面】
③ Outlook on the webを開き、アドレスバーのひし形が重なったマークを押す
④ 「メールリンクを開くことをoutolook.office.comに許可しますか？」を許可する
参考URL：
作成したマクロの概要
エクセルに以下のような表を作成し、宛先のメールアドレスのリンクをクリックして、メールを作成する仕様とした。
操作手順
- メールリンク作成ボタンを押し、あらかじめ宛先欄に空のハイパーリンクを設定しておく
- 宛先欄のリンクをクリックすると、FollowHyperlinkイベントが発生し、以下の処理を行う
① 宛先情報の会社名・担当者を文頭に追加した本文データをクリップボードへ送る
② 送信情報を基にmailtoリンクを作成する
③ 作成したmailtoリンクをクリックする動作を起こして、メールを作成する
④ 作成したmailtoリンクを空のハイパーリンクに戻す - 作成されたメールにクリップボードへ送った本文を手動で貼り付ける
上記を踏まえ、2つのプロシージャをシートモジュール（メール作成シート）に作成した。
- シートモジュール（メール作成シート）
①「CreateBlankLink」プロシージャ：
宛先欄に空のハイパーリンクを設定する
②「Worksheet_FollowHyperlink」イベントプロシージャ：
本文データをクリップボードに送り、mailtoリンクを作成して、メールを作成する
mailtoリンクの作成について、当初、リンク作成ボタンを押して、宛先欄に直接、mailtoリンクを作成する仕様としていた。
しかし、リストのデータを変更した場合、再度、リンク作成ボタンを押して、リンクを作成し直さなければ、変更したデータが反映されない。
そのため、リンク作成ボタンを押し忘れて、変更が反映されていないということが、度々あった。
ワークシートのHYPERLINK関数であれば、すぐに変更が反映されると思ったが、HYPERLINK関数のハイパーリンクをクリックしても、FollowHyperlinkイベントが発生せず、FollowHyperlinkイベントが発生しないと、クリップボードへ本文を送る処理が実行できないため、断念した。
試行錯誤した結果、宛先欄にmailtoリンクを作成しておくのではなく、とりあえず空のリンクを宛先欄に作成しておき、FollowHyperlinkイベントプロシージャ内で、現在のリストのデータを基にmailtoリンクを作成し、リンクをクリックする動作を起こして、メールを作成する仕様とした。
補足：
作成に当たって、本文のデータをクリップボードへ送る際、DataObjectを使ったクリップボード操作では、エラーが生じるという問題が発生した。
そのため、以下URLを参考に、DataObjectを使わず、TextBoxを経由して文字列をコピーする方法とした。
完成したマクロ
シートモジュール（メールシート）に作成
Public Sub CreateBlankLink()
Dim i As Long
Dim myHyperlink As Hyperlink
i = 4
Do
Cells(i, "E").Hyperlinks.Delete
Cells(i, "E").Borders.LineStyle = xlContinuous
Set myHyperlink = ActiveSheet.Hyperlinks.Add(Anchor:=Cells(i, "E"), Address:="", ScreenTip:="メールアドレスをクリック")
i = i + 1
Loop Until Cells(i, "E").Value = ""
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim Title As String
Dim Body As String
Dim myHyperlink As Hyperlink
Dim TargetRow As Long
TargetRow = ActiveCell.Row
'件名に改行がある場合は削除し、全角の空白を半角の空白にした後、半角の空白を「%20」にエンコード
'半角の「&」があるとうまく作動しないため、全角の「＆」に置き換え
Title = Replace(Replace(Replace(WorksheetFunction.Clean(Cells(TargetRow, "D").Value), " ", " "), " ", "%20"), "&", "＆")
Body = Cells(TargetRow, "H").Value & vbCrLf & Replace(Cells(TargetRow, "I"), Chr(10), " 様" & Chr(10)) & " 様" & vbCrLf & vbCrLf & Range("B4") & vbCrLf
With CreateObject("Forms.TextBox.1")
.MultiLine = True
.Text = Body
.SelStart = 0
.SelLength = .TextLength
.Copy
End With
Set myHyperlink = Hyperlinks.Add(Anchor:=Cells(TargetRow, "E"), _
Address:="mailto:" & Cells(TargetRow, "E") & _
"?cc=" & Cells(TargetRow, "F") & _
"&bcc=" & Cells(TargetRow, "G") & _
"&subject=" & Title, _
TextToDisplay:=Cells(TargetRow, "E").Value, ScreenTip:="メールアドレスをクリック")
Application.EnableEvents = False
Selection.Hyperlinks(1).Follow
Application.EnableEvents = True
Set myHyperlink = ActiveSheet.Hyperlinks.Add(Anchor:=Cells(TargetRow, "E"), Address:="", ScreenTip:="メールアドレスをクリック")
End Sub
サンプルファイル保存先：