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

# 目次
・[概要](#概要)
・[イメージ](#イメージ)
・[使い方](#使い方)
・[機能](#機能)
・[作成方法](#作成方法)

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

# イメージ
一覧シート
![スクリーンショット 2024-02-06 204030.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3682265/8c8b0c0f-040f-6450-8f47-79f033cb7a77.png)

テンプレート
![スクリーンショット 2024-02-16 002237.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3682265/3c8b7701-7f1d-d217-eef9-4101bd5185c3.png)

入力サンプル
![スクリーンショット 2024-02-16 003259.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3682265/34a48b1e-7f8d-b678-55e2-c02ff83e5bee.png)


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

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

・メールボタン左のセルを読み取り、それに合致するシートから情報を取得
・件名と本文と添付内の半角%で囲まれた文字列を置換
・本文内の「http,¥¥,file:,:¥」がついた箇所にハイパーリンクを設定
・添付に記載したパスのファイルを添付[^1]
・各種改行「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

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

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

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

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

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