Excel VBA mailtoリンクを使ってOutlook on the webで新規メールを作成

## はじめに
同じ内容のメールを、異なる宛先へ、メール本文の送信先の会社名・担当者名を変更しながら、1件ずつ、送信したい。
これを手作業でやると、間違いも発生しやすく、何より面倒だ。
そのため、エクセルを使って、宛先、本文を差し込んだメールを作成する方法を模索した。


## 作成までの経緯
前提として、動作環境は以下の通りである。
・Windows11
・使用しているメーラーはWebメールの「Outlook on the web」
・ブラウザは「Microsoft Edge」

当初、mailtoを使った方法を考えた。

https://exceleaveit.com/report/2560/


しかし、文字数制限があるため、長い本文が入りきらず、諦めた。
　

次に、以下URLを参考にディープリンクを使った方法を試した。

https://idea.tostring.jp/?p=4061

だが、CC、BCCに対応できない、こちらも、文字数が一定以上になるとエラーになるなど、問題があった。

　
特に、悩んだのが、本文の長さによる文字数制限エラーだ。
どうしても本文を短くできず、最終的に、本文を差し込むのは諦めた。

結局、mailtoリンクを使って、宛先、件名、CC、BCCのみを差し込んだメールを作成し、メール本文は、クリップボードに本文を送るまでは自動化し、作成したメール画面で本文を貼り付ける作業だけ、手作業とする運用にした。
完全自動化ではないが、ほとんど自動化できたので、許容範囲としたい。

## 事前設定
mailtoリンクで、Outlook on the webをMicrosoft Edgeで開くには、事前設定が必要になる。

### 事前設定手順
１. 既定のアプリのMAILTOを設定する

　①Windowsの設定画面から、「アプリ」⇒「既定のアプリ」の画面を開く

【Windows設定の既定のアプリ選択画面】
![スクリーンショット 2025-03-22 135147.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/9a195540-82d7-47aa-a805-f2dd49f75d1c.png)

　
 
　②検索欄に「mailto」と入力、MAILTOの既定を「Microsoft Edge」に変更する。
　
【既定のアプリ MAILTO設定画面】
![スクリーンショット 2025-03-22 135450.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/5944639d-3566-412b-8041-7502bc353dae.png)


２. ブラウザのプロトコルハンドラー設定

　① Microsoft Edgeの設定画面から、「Cookieとサイトのアクセス許可」⇒「すべてのアクセス許可」⇒「プロトコルハンドラー」を開く

【Microsoft Edge 設定画面 プロトコルハンドラー選択画面 その１】
![スクリーンショット 2025-05-21 144445.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/872eaf4b-393b-4c97-8609-26b191fd8f89.jpeg)
【Microsoft Edge 設定画面 プロトコルハンドラー選択画面 その２】
![スクリーンショット 2025-05-21 144637.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/75592071-4ca0-4f9a-9bbe-382325fe14d2.jpeg)

　

 　②「サイトがプロトコルの既定のハンドラーとなることを求めることを許可する」をオンにする

【プロトコルハンドラー許可 設定画面】
![スクリーンショット 2025-03-22 141604.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/02ab5da8-1d9a-4bf9-b899-8151ca0099bd.png)

　
　③ Outlook on the webを開き、アドレスバーのひし形が重なったマークを押す


![スクリーンショット 2025-03-22 142406.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/aed8843b-b578-4fb4-8503-10eaddbfc35e.png)

　
 　④ 「メールリンクを開くことをoutolook.office.comに許可しますか？」を許可する

![スクリーンショット 2025-03-22 142609.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/a77a4773-9fcd-4d37-b841-33dd14dafc9d.png)

参考URL：
- [Google Chromeでメールのリンクを開くようにするには？ | Indeed (インディード)](https://jp.indeed.com/career-advice/career-development/how-to-get-email-links-to-open-in-chrome "Google Chromeでメールのリンクを開くようにするには？ | Indeed (インディード)")


## 作成したマクロの概要
エクセルに以下のような表を作成し、宛先のメールアドレスのリンクをクリックして、メールを作成する仕様とした。
![メール作成ツール.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3917113/aa1e1553-f6fe-41f7-89fd-6435639e63ba.jpeg)


### 操作手順
1. メールリンク作成ボタンを押し、あらかじめ宛先欄に空のハイパーリンクを設定しておく
1. 宛先欄のリンクをクリックすると、FollowHyperlinkイベントが発生し、以下の処理を行う
① 宛先情報の会社名・担当者を文頭に追加した本文データをクリップボードへ送る
② 送信情報を基にmailtoリンクを作成する
③ 作成したmailtoリンクをクリックする動作を起こして、メールを作成する
④ 作成したmailtoリンクを空のハイパーリンクに戻す
1. 作成されたメールにクリップボードへ送った本文を手動で貼り付ける

上記を踏まえ、2つのプロシージャをシートモジュール（メール作成シート）に作成した。
- シートモジュール（メール作成シート）
**①「CreateBlankLink」プロシージャ**：
　宛先欄に空のハイパーリンクを設定する
**②「Worksheet_FollowHyperlink」イベントプロシージャ**：
　本文データをクリップボードに送り、mailtoリンクを作成して、メールを作成する


　
mailtoリンクの作成について、当初、リンク作成ボタンを押して、宛先欄に直接、mailtoリンクを作成する仕様としていた。
しかし、リストのデータを変更した場合、再度、リンク作成ボタンを押して、リンクを作成し直さなければ、変更したデータが反映されない。
そのため、リンク作成ボタンを押し忘れて、変更が反映されていないということが、度々あった。

ワークシートのHYPERLINK関数であれば、すぐに変更が反映されると思ったが、HYPERLINK関数のハイパーリンクをクリックしても、FollowHyperlinkイベントが発生せず、FollowHyperlinkイベントが発生しないと、クリップボードへ本文を送る処理が実行できないため、断念した。

試行錯誤した結果、宛先欄にmailtoリンクを作成しておくのではなく、とりあえず空のリンクを宛先欄に作成しておき、FollowHyperlinkイベントプロシージャ内で、現在のリストのデータを基にmailtoリンクを作成し、リンクをクリックする動作を起こして、メールを作成する仕様とした。

#### 補足：
作成に当たって、本文のデータをクリップボードへ送る際、DataObjectを使ったクリップボード操作では、エラーが生じるという問題が発生した。
そのため、以下URLを参考に、DataObjectを使わず、TextBoxを経由して文字列をコピーする方法とした。

https://www.ka-net.org/blog/?p=7537


## 完成したマクロ
### シートモジュール（メールシート）に作成
```VB:シートモジュール（メールシート）
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
```

サンプルファイル保存先：

https://github.com/rie1234k/ExcelVBA_Tips/tree/main/CreateMailTool