ExcelVBAのメール作成ツール(文字列自動置換、改行変換、ハイパーリンク自動作成)

目次

・概要
・イメージ
・使い方
・機能
・作成方法

概要

ExcelVBAを活用したメール作成ツール。
フォーマットが決まっているメールならほぼ自動で作成可。

イメージ

一覧シート

テンプレート

入力サンプル

使い方

メールボタンを押すと、Outlookのメールが自動で作成される(送信はしない)

機能

以下メールボタンの機能について説明

・メールボタン左のセルを読み取り、それに合致するシートから情報を取得
・件名と本文と添付内の半角%で囲まれた文字列を置換
・本文内の「http,¥¥,file:,:¥」がついた箇所にハイパーリンクを設定
・添付に記載したパスのファイルを添付¹
・各種改行「vbCrLf,vbCr,vbLf」を適切な改行に変換
・游ゴシック、サイズ11に設定

作成方法

①Module1に以下のコードを貼り付け

Option Explicit

Enum eRow
    宛先 = 2
    CC '値未指定の場合は、上の項目+1
    BCC
    件名
    本文
    添付
    置換TOP = 2
End Enum
Enum eClm
    項目 = 1
    入力内容
    置換前 = 4
    置換後
End Enum
Dim ws As Worksheet

Sub subClickButton()
    Call subCreateMail(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -1).Value) 'ボタンの左隣のセル値(シート名)を引数としてsubCreateMailに渡す
End Sub

Sub subCreateMail(strSheetName As String)
    Dim objOutlook As Object
    Dim objMailItem As Object
    Dim strAttach As String
    Dim i As Long
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMailItem = objOutlook.CreateItem(0)
    Set ws = ThisWorkbook.Sheets(strSheetName)
    
    'メールを作成
    With objMailItem
        .To = ws.Cells(eRow.宛先, eClm.入力内容)
        .CC = ws.Cells(eRow.CC, eClm.入力内容)
        .BCC = ws.Cells(eRow.BCC, eClm.入力内容)
        .Subject = fncReplaceString(ws.Cells(eRow.件名, eClm.入力内容)) '文字列置換を行ってから格納
        .htmlBody = fncCreateMailBody(ws.Cells(eRow.本文, eClm.入力内容)) '文字列置換、改行変換、ハイパーリンク設定、書式設定を行ってから格納
        i = eRow.添付
        Do Until ws.Cells(i, eClm.入力内容) = ""
            strAttach = fncReplaceString(ws.Cells(i, eClm.入力内容)) '文字列置換
            strAttach = fncTrimString(strAttach, """") '余分なダブルクォーテーションの削除
            .attachments.Add strAttach 'ファイルを添付
            i = i + 1
        Loop
        .display
    End With
    
    Set objOutlook = Nothing
    Set objMailItem = Nothing
    Set ws = Nothing
End Sub

Function fncCreateMailBody(strBody As String) As String
    strBody = fncReplaceString(strBody) '文字列置換
    
    '各種改行を適切な改行に変換
    strBody = Replace(strBody, vbCrLf, "<br>")
    strBody = Replace(strBody, vbCr, "<br>")
    strBody = Replace(strBody, vbLf, "<br>")
    
    strBody = fncAddHyperlink(strBody) '本文にハイパーリンクを設定
    strBody = "<span style=""font-size:11pt;font-family:游ゴシック"">" & strBody & "</span>" '本文の書式を変更
    
    fncCreateMailBody = strBody
End Function

Function fncAddHyperlink(strBody As String) As String '本文内のパスにハイパーリンクを設定
    Dim aryBodySplit As Variant
    Dim result As String
    Dim temp As String
    Dim i As Long
    aryBodySplit = Split(strBody, "<br>")
    For i = LBound(aryBodySplit) To UBound(aryBodySplit)
        temp = aryBodySplit(i)
        temp = fncTrimString(temp, """")
        If InStr(temp, "http") Or InStr(temp, "\\") Or InStr(temp, "file:") Or InStr(temp, ":\") Then
            result = result & "<a href=""" & temp & """>" & temp & "</a>" & "<br>"
        Else
            result = result & temp & "<br>"
        End If
    Next
    fncAddHyperlink = fncTrimString(result, "<br>")
End Function

Function fncTrimString(str As String, strTrim As String) As String '第一引数の文字列の先頭・末尾に、第二引数の文字列があれば除去
    If Left(str, Len(strTrim)) = strTrim Then
        str = Right(str, Len(str) - Len(strTrim))
    End If
    If Right(str, Len(strTrim)) = strTrim Then
        str = Left(str, Len(str) - Len(strTrim))
    End If
    fncTrimString = str
End Function

Function fncReplaceString(str As String) As String '%で囲んだ文字列を置換
    Dim i As Long
    i = eRow.置換TOP
    Do While ws.Cells(i, eClm.置換前) <> ""
        str = Replace(str, "%" & ws.Cells(i, eClm.置換前) & "%", ws.Cells(i, eClm.置換後))
        i = i + 1
    Loop
    fncReplaceString = str
End Function

②イメージのようにシートを作成
③メールボタンを配置

メールボタンの作成方法
適当なセルにメールと入力し、中央揃え、外枠付与、背景灰色、コピー、配置したい箇所に図貼り付け

④メールボタンを右クリック→マクロの登録→「subClickButton」を選択してOK。

ボタンを一つ作成すれば、あとはコピーで使い回しが可能

1. 添付ファイルが複数ある場合は、下の行に続けてパスを入力 ↩