異なる本文で一斉メールするVBA

Excel VBA

[Excel VBA]異なる本文で一斉メールするVBA

公開の発端

こちら。ことりさんなら多分、時間があれば自分でVBA組んでたんだろうなあ、と思うのです。

しかも既に作業は終わってるので今更感が大きいですが、折角なので載せておこうかと。

作成経緯

件名の通り、異なる本文で複数の宛先に一斉メールするためのVBAです。

元々は同人カードゲームの通販対応用に作ったVBAで、現在は大学のOB会の案内で主に使っています。

テンプレートの中に各人毎に異なる内容を埋め込めるので、「前回の出欠」なども入れ込めて便利です。

概要

ユーザーが実行できるアクションは以下の通りです。

・テンプレートシートの追加・編集

・対象宛先の選択

・プレビュー

・一括送信

メールエンジンはOutlookに依存しています。

送信はSMTPアカウントを持っている事が前提となります。

使用方法

◎概要		
	テンプレートに名簿の内容を差し込んでメール送信するツールです。	
	使用イメージとしては、Word の差し込み印刷に似ています。	
	一括同報や、相手ごとに内容をこまめに変更して送信したりする場合など、利用できると思います。	
		
◎環境		
	Microsoft Excel　および　Microsoft Outlook がインストールされていること	
	メール作成・送信時はOutlook が起動されていることが必要になります。	
		
◎テンプレートの選択		
	「使用テンプレート」を選択します。ここで選択したシートに記載されているテンプレートに対して、名簿の情報を差し込みます。	
	ここで選択したシートの事を、本説明では、「[テンプレート]シート」と記載します。	

◎プレビュー	
	用途：メールを送信前に確認したいときに使います。
	1 送信したい行の「選択」列にチェックを入れます。
	2 「プレビュー」ボタンをクリックします。
	3 すると、選択した行の内容を [テンプレート] シートに埋め込んだ内容でメールが表示されます
◎複数宛先送信		
	複数の宛先に、送信内容を事前確認せず送信したい場合。	
	1 送信したい行の「選択」列にチェックを入れます。	
	2 「一括送信」ボタンをクリックします。	
	3 選択した行の内容を[テンプレート]シートに埋め込んだ内容で、メールが自動送信されます	
		
◎名簿、テンプレートのメンテナンス		
	▼[名簿]シート	
		タイトル行（3行目の行）は、列を自由に追加削除できます。
		ただし、1列目から表の最後の列まで、空白セルが無いようにしてください。
		空白セルでタイトル行の終わりを検知していますので、タイトルの読み込みが止まってしまいます。
		
		応用例としましては、「職務経歴」や「スキル」などの列を追加して、営業先に職務経歴を送るメールを作成するのもありだと思います。
		
	▼[テンプレート]シート	
		メールの内容を記載するシートです。
		メール作成時に名簿の内容を反映したいキーワードを「%%」で括って記載します。
		ファイルを添付したい場合、[添付ファイル]と記載した行の2列目にフルパスを入力します。
		
		なお、シート名が[テンプレート]であればよいので、複数のテンプレートを作成しておき、シート名変更で随時切り替えるのが便利と思います。

画面

「名簿」シート

f:id:wd4096:20190510224307p:plain

テンプレートシート（例）

f:id:wd4096:20190510224331p:plain

メール例

f:id:wd4096:20190510224349p:plain

コード

Thisworkbook

テンプレートシートの名前をリストボックスに追加するコードです。

Option Explicit

Private Sub Workbook_Open()
'入力規則設定
Const MAX_COL As Long = 1000    'キーワードを検索する右端のセル
Dim arySheet() As String
Dim objSheet As Worksheet
Dim lngCol As Long

    'テンプレートを選択するセルをキーワードで探す
    lngCol = getColumn("使用テンプレート", "名簿", 1)
    
    '最大列数に到達していない場合、キーワードは見つかったとみなす
    If lngCol <> MAX_COL Then
        lngCol = lngCol + 1
        ReDim Preserve arySheet(0)
        For Each objSheet In ThisWorkbook.Sheets
            'シート名に「テンプレート」の文字が入っているシートだけをテンプレートとして扱う
            If InStr(objSheet.Name, "テンプレート") > 0 Then
                '配列変数の配列を１増やす
                ReDim Preserve arySheet(UBound(arySheet) + 1)
                
                'シート名設定
                arySheet(UBound(arySheet) - 1) = objSheet.Name
            End If
        Next
    
        '設定先のセルを選択する
        ThisWorkbook.Sheets("名簿").Activate
        ThisWorkbook.Sheets("名簿").Cells(1, lngCol).Select
        
        If UBound(arySheet) = 0 Then
            '対象が無い場合、入力規則をクリアする
            With Selection.Validation
                .Delete
            End With
        Else
            '対象がある場合、入力規則を設定する
            ReDim Preserve arySheet(UBound(arySheet) - 1)
            With Selection.Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=Chr(32) & Join(arySheet, ",") & Chr(32)
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .IMEMode = xlIMEModeNoControl
                .ShowInput = True
                .ShowError = True
            End With
        End If
    End If
End Sub

modMain.bas

プレビュー表示、メール一括送信のコードです。

もっと簡単にできる方法はあれこれあるので、参考になれば幸い程度です。

まずAccessがあるならすごく楽ですし、キーワードの右端を1000と決め打ちしているのも美しくないです。

あと、ぷち工夫として、チェックを入れるのにフォント「Marlett」を使っています。

このフォントだと、「a」が「チェック」を表す記号になるのですよね。

    Option Explicit

Const TITLE_ROW As Long = 3 'タイトル行

Public Sub pSubSendMail()
Dim lngRow As Long

    lngRow = TITLE_ROW + 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
        If ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a" Then
            Call pSubMakOrSendeMail(lngRow, True)
        End If
        lngRow = lngRow + 1
    Loop
End Sub

Public Sub pSubMakeMail()
Dim lngRow As Long

    lngRow = TITLE_ROW + 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
        If ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a" Then
            Call pSubMakOrSendeMail(lngRow, False)
        End If
        lngRow = lngRow + 1
    Loop
End Sub


Private Sub pSubMakOrSendeMail(lngTargetRow As Long, blnSend As Boolean)
'メール作成
'「名簿マスター」シートの選択行から情報を読み取り、
'「テンプレート」シートのテンプレートに従ってメールを作成する
Const MAX_COL As Long = 1000    'キーワードを検索する右端のセル
Dim objOutlook As Outlook.Application
Dim objMail As MailItem
Dim lngRow As Long
Dim lngCol As Long
Dim strTemp As String
Dim strTitle As String
Dim strValue As String
Dim vntTemp As Variant

Dim varRecipients As Variant
Dim lngIdx As Long

Dim strTemplate As String

    'テンプレートを選択するセルをキーワードで探す
    lngCol = getColumn("使用テンプレート", "名簿", 1)
    
    '最大列数に到達していない場合、キーワードは見つかったとみなす
    If lngCol <> MAX_COL Then
        strTemplate = Trim(ThisWorkbook.Sheets("名簿").Cells(1, lngCol + 1))
        
        'Outlookオブジェクト作成
        Set objOutlook = New Outlook.Application
        
        'メールアイテム作成
        Set objMail = objOutlook.CreateItem(olMailItem)
        
        '＊＊＊　メールに項目を記載　＊＊＊
        '＊＊　ReplyTo　＊＊
        strTemp = ThisWorkbook.Sheets(strTemplate).Cells(1, 2)
        If strTemp <> "" Then
            varRecipients = Split(strTemp, ";")
            For lngIdx = 0 To UBound(varRecipients)
                objMail.ReplyRecipients.Add varRecipients(lngIdx)
            Next
        End If
        
        '＊＊　To　＊＊
        objMail.To = ThisWorkbook.Sheets("名簿").Cells(lngTargetRow, getCol("電子メール アドレス"))
        
        '＊＊　件名　＊＊
        objMail.Subject = ThisWorkbook.Sheets(strTemplate).Cells(2, 2)
        
        '＊＊　本文　＊＊
        '＊　テンプレート読み込み　＊
        '%END%になるまで読み込む
        lngRow = 3
        strTemp = ""
        Do While (ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 2) <> "%END%")
            strTemp = strTemp & ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 2) & vbCrLf
            lngRow = lngRow + 1
        Loop
        
        '＊　キーワード置換　＊
        With ThisWorkbook.Sheets("名簿")
            lngCol = 1
            Do Until .Cells(TITLE_ROW, lngCol) = ""
                strTitle = .Cells(TITLE_ROW, lngCol)
                strValue = .Cells(lngTargetRow, lngCol)
                strTemp = Replace(strTemp, "%" & strTitle & "%", strValue)
                lngCol = lngCol + 1
            Loop
        End With
                
        objMail.Body = strTemp
        
        
        '＊＊　添付ファイルを添付　＊＊
        '＊　添付ファイルのパスを記載した行を探す　＊
        Do While (ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 1) <> "添付ファイル")
            lngRow = lngRow + 1
        Loop
        strTemp = ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 2)
        
        '＊　添付ファイル追加　＊
        If strTemp <> "" Then
            vntTemp = Split(strTemp, ",")
            For lngIdx = 0 To UBound(vntTemp)
                objMail.Attachments.Add (vntTemp(lngIdx))
            Next
        End If
        
        'メール表示
        objMail.Display
        If blnSend Then
            objMail.Send
        End If
    End If
End Sub

Function getCol(strKeyword As String) As Long
    getCol = 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(TITLE_ROW, getCol) = "") Or (ThisWorkbook.Sheets("名簿").Cells(TITLE_ROW, getCol) = strKeyword)
        getCol = getCol + 1
    Loop
End Function

Sub clearCheckAll()
'Noがある行のチェックをクリアする
Dim lngRow As Long

    lngRow = TITLE_ROW + 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
        ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = ""
        lngRow = lngRow + 1
    Loop
End Sub

Sub setCheckAll()
'Noがある行のチェックをセットする
Dim lngRow As Long

    lngRow = TITLE_ROW + 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
        ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a"
        lngRow = lngRow + 1
    Loop
End Sub

Sub clearCheck()
'Noがある行のチェックをクリアする
Dim lngRow As Long
Dim lngOldRow As Long
Dim objRange As Range
    
    lngOldRow = 0
    For Each objRange In Selection
        lngRow = objRange.Row
        If lngOldRow <> lngRow Then
            If lngRow > TITLE_ROW And ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) <> "" Then
                ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = ""
            End If
            lngOldRow = lngRow
        End If
    Next
End Sub

Sub setCheck()
'Noがある行のチェックをセットする
Dim lngRow As Long
Dim lngOldRow As Long
Dim objRange As Range
    
    lngOldRow = 0
    For Each objRange In Selection
        lngRow = objRange.Row
        If lngOldRow <> lngRow Then
            If lngRow > TITLE_ROW And ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) <> "" Then
                ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a"
            End If
            lngOldRow = lngRow
        End If
    Next
End Sub

Function getColumn(strKeyword As String, strSheet As String, lngRow As Long) As Long
'入力規則設定
Const MAX_COL As Long = 1000    'キーワードを検索する右端のセル
Dim lngCol As Long

    'キーワードで探す
    lngCol = 1
    Do Until ThisWorkbook.Sheets(strSheet).Cells(lngRow, lngCol) = strKeyword Or lngCol > MAX_COL
        lngCol = lngCol + 1
    Loop
    
    getColumn = lngCol
End Function

2019/05/11 0:19追記

添付ファイルを相手先ごとに変更するコード出来ました。さっきまでツイッター触ってたので実質10分位。やはり小工数だったのです。

変更箇所だけを掲載しておきます。

こうして見てみると、キーワード置換は関数化するべきですね。

明日もそこそこ早いので今日はそろそろ寝るのです。

        '＊　添付ファイル追加　＊
        If strTemp <> "" Then
            '添付ファイルにキーワードを使えるようにする
            If Left(strTemp, 1) = "%" Then
                '＊　キーワード置換　＊
                With ThisWorkbook.Sheets("名簿")
                    lngCol = 1
                    Do Until .Cells(TITLE_ROW, lngCol) = ""
                        strTitle = .Cells(TITLE_ROW, lngCol)
                        strValue = .Cells(lngTargetRow, lngCol)
                        strTemp = Replace(strTemp, "%" & strTitle & "%", strValue)
                        lngCol = lngCol + 1
                    Loop
                End With
            End If

            vntTemp = Split(strTemp, ",")
            For lngIdx = 0 To UBound(vntTemp)
                objMail.Attachments.Add (vntTemp(lngIdx))
            Next
        End If