「今さら」なんてない

「自分にもできそう」を伝播させるブログ

Excel VBA 定型メンバーへのメールはExcelで作成してしまえ

OutlookThunderbirdにもテンプレート機能はあるのですが、使いにくいので作りました。

概要・使い方

  1. 件名・本文を書く
    html形式で書かれます。ハイパーリンクも使えます。

  2. 送信先リストのアドレスの右のTO,CC,BCCに○をする

  3. アドレス転記のボタンを押す
    →上の送信先リストに転記されます。

  4. メール作成のボタンを押す
    →メール作成画面が開きます。

やること

  1. 標準モジュールを挿入し、コードをコピペする

  2. メール作成用のシートを用意する

  3. VBAの参照設定でoutlookのライブラリを開く

メール作成用のシートを用意する

  1. シートを下図の様に作成します。

    f:id:yoshino-ya:20180625045741p:plain

  2. ①~③の手順でボタンを配置します。(2つ作します)

    f:id:yoshino-ya:20180625045750p:plain

  3. 挿入されたボタンで右クリックメニューを開き④、⑤の手順で作成したマクロ(メール作成,アドレス転記)の選択をします。(ボタン1つにつき1マクロ登録です)

    f:id:yoshino-ya:20180625045754p:plain

VBAの参照設定でoutlookのライブラリを開く

①~④の手順でoutlookのライブラリを開きます。 f:id:yoshino-ya:20180625045759p:plain f:id:yoshino-ya:20180625045803p:plain

outlookのバージョンが異なる人への配布時は、配布された方の方で一度チェックを外し、再度outlookのライブラリを選択する必要があります。

コード

Sub メール作成()
    ' Outlookのメールを作成する
        Dim ol As Object
    ' 起動しているOutlookを取得する
        Set ol = GetObject(, "Outlook.Application")
        If ol Is Nothing Then Exit Sub ' Outlookが起動していない場合、終了する
    ' メールを作成する
    With ol.CreateItem(0)
        .BodyFormat = olFormatHTML
        .To = Replace(Range("C4").Value, vbCrLf, "")      ' 宛先
        .CC = Replace(Range("C5").Value, vbCrLf, "")       ' CC
        .BCC = Replace(Range("C6").Value, vbCrLf, "")      ' BCC
        .Subject = Range("C7").Value    ' 件名
        .Display                        ' 表示
        If Range("C9").Hyperlinks.Count = 1 Then 'C9ハイパーリンク有無確認
            .HTMLBody = Replace(Range("C8"), vbLf, "<br>") & "<br>" _
            & "<a href=" & Range("C9").Hyperlinks(1).Address & ">" & Range("C9").Value & "</a>" _
            & Replace(.Body, vbLf, "<br>")     ' 本文(署名を本文の下部に表示)
        Else
            .HTMLBody = Replace(Range("C8"), vbLf, "<br>") & "<br>" _
            & Replace(.Body, vbLf, "<br>")     ' 本文(署名を本文の下部に表示)
        End If
    End With
    Set ol = Nothing
End Sub

Sub アドレス転記() Dim buf As String Dim i As Integer, j As Integer For j = 1 To 3 buf = "" For i = ActiveSheet.ListObjects(1).ListRows.Count + 13 To 13 Step -1 If Cells(i, "C").Value <> "" And Cells(i, j + 3).Value <> "" Then buf = Cells(i, 3).Value & ";" & vbCrLf & buf Next i Cells(j + 3, "C").Value = Replace(buf, ";;", ";") Next j End Sub

以上です。

現在Outlookを使用しているのでOutlook版しか作成しておりませんが、他のメールサービスでも同様のやり方で作成できるはずなのでトライして頂ければと思います。