【VBA】テンプレートを使用してテキストやメールを作成する

プログラムソースなどのテキストやメールを作成する際に、ExcelのVBAマクロで作成すると便利なので、よく仕事で使っています。

メールにおいては、VBAであればOutLook連携が容易です。

テキストファイルの自動生成は、他のプログラミング言語でも可能なのですが、Excelに有利な点があります。

それは、出力したいファイルによって変更したい文字列をExcel上に定義しておくことができることです。例えば以下の文字列を書き出したいとします。

佐藤さん

会議は10時から会議室Aで行います。

上記だと「佐藤さん」にしか送れないので、「佐藤さん」の部分を適時変更したいとします。

他のプログラミング言語で実装する場合には、引数に名前を渡すことになると思います。

Excelの場合は下記のように、セル上に値を定義しておけばよいので、引数で渡すよりお手軽です。

また、自分はテンプレートを使用した書き出しを行っているのですが、これが変更に強いのでお勧めです。方法について記載していきます。

この記事で作成したサンプルプログラムは以下からダウンロードもできます。

https://vbaexcel.slavesystems.com/product/excel_grep_sample.xlsm

テンプレートを使用してテキストを作成する

テンプレートとは、作成したいテキストの固定の文字列部分を予め定義したものです。例えばワークシート上に下記のように定義します。

今回のサンプルプログラムのルールで、「${〇〇}」と記載した部分は動的に書き換える文字列ということにします。

次に書き換える文字列を定義するシートを作成します。今回のサンプルでは以下のようにしました。

上記のテンプレートを使用して、テキストの書き出しを行うVBAが以下になります。

'「テンプレートのあるシート名」セルのアドレス
Const TEMPLATE_NAME_ADDRESS As String = "C2"
'テンプレートシートの値が格納されている列
Const TEMPLATE_SHEET_BODY_COLUMN As Integer = 1
'改行コード
Const NEW_LINE_CODE As String = vbCrLf
'変数のセルの列
Const VARIABLE_COLUMN As Integer = 2
'変数のセルの開始行
Const VARIABLE_START_ROW As Integer = 6
'置き換える文字列のセルの列
Const AFTER_STR_COLUMN As Integer = 3
'「文字コード」セルのアドレス
Const STR_CHAR_SET_ADDRESS As String = "C3"

'メイン処理
Public Sub textOutputMain()
    Dim savePath As String
    
    'ファイル選択ダイアログで出力先を選ぶ
    savePath = getSavePath()
    If savePath = "" Then
        'キャンセルが押されたら処理を中止
        Exit Sub
    End If
    
    '定義シートを取得
    Dim defSheet As Worksheet
    Set defSheet = ActiveSheet
    
    'テンプレートシートを取得
    Dim templateSheet As Worksheet
    Set templateSheet = ThisWorkbook.Worksheets(defSheet.Range(TEMPLATE_NAME_ADDRESS).Value)
    
    'テンプレート文字列を取得
    Dim templateBody As String
    Dim row As Long
    For row = 1 To templateSheet.Cells(Rows.Count, TEMPLATE_SHEET_BODY_COLUMN).End(xlUp).row
        If row = 1 Then
            templateBody = templateSheet.Cells(row, TEMPLATE_SHEET_BODY_COLUMN).Value
        Else
            templateBody = templateBody & NEW_LINE_CODE & templateSheet.Cells(row, TEMPLATE_SHEET_BODY_COLUMN).Value
        End If
    Next row
    
    'テンプレートの文字列を置換
    For row = VARIABLE_START_ROW To defSheet.Cells(Rows.Count, VARIABLE_COLUMN).End(xlUp).row
        If defSheet.Cells(row, VARIABLE_COLUMN).Value <> "" Then
            templateBody = Replace(templateBody, getBeforeStr(defSheet.Cells(row, VARIABLE_COLUMN).Value), defSheet.Cells(row, AFTER_STR_COLUMN).Value)
        End If
    Next row
    
    'ファイル書き出し
    Call writeFile(savePath, defSheet.Range(STR_CHAR_SET_ADDRESS).Value, templateBody)
End Sub

'置換前文字列の生成
Private Function getBeforeStr(val As String) As String
    getBeforeStr = "${" & val & "}"
End Function


'出力先を選ぶためのファイル選択ダイアログ表示処理
Private Function getSavePath() As String
    Dim fileName As Variant
    '初期表示されるファイル名
    Const DEFAULT_FILE_NAME As String = "test.txt"
    
    fileName = Application.GetSaveAsFilename(InitialFileName:=DEFAULT_FILE_NAME, FileFilter:="テキストファイル,*.txt")
    If fileName = False Then
        'キャンセルが押されたら空を返却する
        getSavePath = ""
        Exit Function
    End If
    getSavePath = CStr(fileName)

End Function

'引数で指定されたテキストファイルに文字列を書き込む
Private Sub writeFile(filepath As String, charset As String, contents As String)
    Set obj = CreateObject("ADODB.Stream")
    With obj
        .charset = charset
        .Open
        .WriteText contents, 0
        .SaveToFile filepath, 2
        .Close
    End With
    Set obj = Nothing
End Sub

実行結果

ちなみに、現在時刻とか固定値で表しにくいものは「この文字列が来たら必ずこの法則で書き換える」とすればよいかなと思います。

例として、現在時刻を出力するための文字列を「${現在時刻}」とします。まずはテンプレートにその文字列を追加します。

ファイル書き出しを行う前に下記のプログラムを追加すれば置き換えることができます。

    '固定で置換する文字列
    templateBody = Replace(templateBody, "${現在時刻}", Now)

実行結果

今回はテンプレートシートを加工しやすいように、別シートにしましたが2シート使ってしまっているので、1シートで完結するようにするのもよいかと思います。

特にテンプレートをたくさん増やしていく場合には1シート完結のほうがやりやすいですね。

テンプレートを使用してメールを作成する

次にテンプレートからOutLookメールを書き出すサンプルを作成します。

メールの場合はタイトルとか宛先も必要なので、定義シートを以下のようにしました。

このシートとテンプレートをもとにメールの書き出しを行うVBAを作成しました。

'「テンプレートのあるシート名」セルのアドレス
Const TEMPLATE_NAME_ADDRESS As String = "C2"
'テンプレートシートの値が格納されている列
Const TEMPLATE_SHEET_BODY_COLUMN As Integer = 1
'改行コード
Const NEW_LINE_CODE As String = vbCrLf
'変数のセルの列
Const VARIABLE_COLUMN As Integer = 2
'変数のセルの開始行
Const VARIABLE_START_ROW As Integer = 10
'置き換える文字列のセルの列
Const AFTER_STR_COLUMN As Integer = 3
'「メールタイプ」セルのアドレス
Const STR_MAIL_FORMAT_ADDRESS As String = "C3"
'TOセルのアドレス
Const TO_ADDRESS As String = "C4"
'CCセルのアドレス
Const CC_ADDRESS As String = "C5"
'BCCセルのアドレス
Const BCC_ADDRESS As String = "C6"
'タイトルセルのアドレス
Const TITLE_ADDRESS As String = "C7"

'メイン処理
Public Sub textOutputMain()
    
    '定義シートを取得
    Dim defSheet As Worksheet
    Set defSheet = ActiveSheet
    
    'テンプレートシートを取得
    Dim templateSheet As Worksheet
    Set templateSheet = ThisWorkbook.Worksheets(defSheet.Range(TEMPLATE_NAME_ADDRESS).Value)
    
    'テンプレート文字列を取得
    Dim templateBody As String
    Dim row As Long
    For row = 1 To templateSheet.Cells(Rows.Count, TEMPLATE_SHEET_BODY_COLUMN).End(xlUp).row
        If row = 1 Then
            templateBody = templateSheet.Cells(row, TEMPLATE_SHEET_BODY_COLUMN).Value
        Else
            templateBody = templateBody & NEW_LINE_CODE & templateSheet.Cells(row, TEMPLATE_SHEET_BODY_COLUMN).Value
        End If
    Next row
    
    'タイトル文字列を取得
    Dim title As String: title = defSheet.Range(TITLE_ADDRESS).Value
    
    'テンプレートの文字列とタイトル文字列を置換
    For row = VARIABLE_START_ROW To defSheet.Cells(Rows.Count, VARIABLE_COLUMN).End(xlUp).row
        If defSheet.Cells(row, VARIABLE_COLUMN).Value <> "" Then
            templateBody = Replace(templateBody, getBeforeStr(defSheet.Cells(row, VARIABLE_COLUMN).Value), defSheet.Cells(row, AFTER_STR_COLUMN).Value)
            title = Replace(title, getBeforeStr(defSheet.Cells(row, VARIABLE_COLUMN).Value), defSheet.Cells(row, AFTER_STR_COLUMN).Value)
        End If
    Next row
    
    '固定で置換する文字列
    templateBody = Replace(templateBody, "${現在時刻}", Now)
    
    'メールオブジェクト作成
    Dim outlook As Object
    Set outlook = CreateObject("Outlook.Application")
    Dim mail As Object
    Set mail = outlook.CreateItem(olMailItem)
    
    With mail
        '宛先を設定
        .To = defSheet.Range(TO_ADDRESS).Value
        .CC = defSheet.Range(CC_ADDRESS).Value
        .BCC = defSheet.Range(BCC_ADDRESS).Value
        
        'タイトルを設定
        .Subject = title
        
        '本文を設定
        .Body = templateBody
        .BodyFormat = getMailFormat(defSheet.Range(STR_MAIL_FORMAT_ADDRESS).Value)
        
        .Display
        'そのまま送信するする場合は「.Send」にする
        
    End With
    
End Sub

'置換前文字列の生成
Private Function getBeforeStr(val As String) As String
    getBeforeStr = "${" & val & "}"
End Function

'メールフォーマットを取得
Private Function getMailFormat(val As String) As Integer
    Select Case val
        Case "テキスト"
            getMailFormat = 1
        Case "HTML"
            getMailFormat = 2
        Case Else
            getMailFormat = 3
    End Select
End Function

タイトルの文字列も置換させる必要があるケースのほうが多いと思ったので置換できるようにしています。

しかし、タイトルと本文は結びつきが強いので、やはり1シートで完結できるように作ったほうが運用上メリットが多そうでしたねえ…。

テンプレートにタブを使いたいときはどうするか

今回、Excel上にテンプレートを作成していましたが、Excelはタブ区切りなのでタブが使えなくなるというデメリットがあります。

メールの場合にタブを入れることはあまりなさそうですが、テキストの場合は結構ありそうですよねえ。

特にプログラムソースを出力する場合などです。

その場合は、テキストファイルにテンプレートの情報を書き込んでおいて、それを読み込んで置換させるのがよさそうですね。

'「テンプレートファイル」セルのアドレス
Const TEMPLATE_PATH_ADDRESS As String = "C2"
'改行コード
Const NEW_LINE_CODE As String = vbCrLf
'変数のセルの列
Const VARIABLE_COLUMN As Integer = 2
'変数のセルの開始行
Const VARIABLE_START_ROW As Integer = 6
'置き換える文字列のセルの列
Const AFTER_STR_COLUMN As Integer = 3
'「文字コード」セルのアドレス
Const STR_CHAR_SET_ADDRESS As String = "C3"

'フォルダピッカーを起動して対象フォルダのセルに値を設定する
Public Sub pickFolder()
    Call setCellFromFileDialog(ActiveSheet.Range(TEMPLATE_PATH_ADDRESS))
End Sub

'メイン処理
Public Sub txtToTxtMain()
    Dim savePath As String
    
    'ファイル選択ダイアログで出力先を選ぶ
    savePath = getSavePath()
    If savePath = "" Then
        'キャンセルが押されたら処理を中止
        Exit Sub
    End If
    
    '定義シートを取得
    Dim defSheet As Worksheet
    Set defSheet = ActiveSheet
    
    'テンプレート文字列を取得
    Dim templateBody As String
    templateBody = readFile(defSheet.Range(TEMPLATE_PATH_ADDRESS).Value, defSheet.Range(STR_CHAR_SET_ADDRESS).Value)
    
    'テンプレートの文字列を置換
    Dim row As Long
    For row = VARIABLE_START_ROW To defSheet.Cells(Rows.Count, VARIABLE_COLUMN).End(xlUp).row
        If defSheet.Cells(row, VARIABLE_COLUMN).Value <> "" Then
            templateBody = Replace(templateBody, getBeforeStr(defSheet.Cells(row, VARIABLE_COLUMN).Value), defSheet.Cells(row, AFTER_STR_COLUMN).Value)
        End If
    Next row
    
    '固定で置換する文字列
    templateBody = Replace(templateBody, "${現在時刻}", Now)
    
    'ファイル書き出し
    Call writeFile(savePath, defSheet.Range(STR_CHAR_SET_ADDRESS).Value, templateBody)
End Sub


'置換前文字列の生成
Public Function getBeforeStr(val As String) As String
    getBeforeStr = "${" & val & "}"
End Function

'出力先を選ぶためのファイル選択ダイアログ表示処理
Public Function getSavePath() As String
    Dim fileName As Variant
    '初期表示されるファイル名
    Const DEFAULT_FILE_NAME As String = "test.txt"
    
    fileName = Application.GetSaveAsFilename(InitialFileName:=DEFAULT_FILE_NAME, FileFilter:="テキストファイル,*.txt")
    If fileName = False Then
        'キャンセルが押されたら空を返却する
        getSavePath = ""
        Exit Function
    End If
    getSavePath = CStr(fileName)

End Function

'ファイル選択ダイアログを開き、返却結果をセルに格納する
Public Sub setCellFromFileDialog(cell As Object)
    cell.Value = showFileDialog(cell.Value)
End Sub

'ファイル選択ダイアログを開く
Public Function showFileDialog(strInit As String) As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = strInit
        If .Show = True Then
            showFileDialog = .SelectedItems(1)
        End If
    End With
    If showFileDialog = "" Then
        showFileDialog = strInit
    End If
End Function

'引数で指定されたテキストファイルを開いて、内容の文字列を返す
Public Function readFile(filepath As String, charset As String) As String
    Set obj = CreateObject("ADODB.Stream")
    Dim buf As String
    With obj
        .charset = charset
        .Open
        .LoadFromFile filepath
        buf = .ReadText
        .Close
    End With
    readFile = buf
    Set obj = Nothing
End Function

'引数で指定されたテキストファイルに文字列を書き込む
Public Sub writeFile(filepath As String, charset As String, contents As String)
    Set obj = CreateObject("ADODB.Stream")
    With obj
        .charset = charset
        .Open
        .WriteText contents, 0
        .SaveToFile filepath, 2
        .Close
    End With
    Set obj = Nothing
End Sub