メール送信用EXCELマクロなり
ありがちだけどメールのテンプレートをEXCELに作って
そいつを送信するとか言うCDOのメール送信用マクロ作成しました。
まぁ、決してやってはいけない用途で作ったんですが・・・・。
だいたい1つずつ手でメールを打つのもなぁ。
かといってBccで全員に送るのもなぁ。というので
けど本当は手書きでやるべきですがね。
・EXCELを処理する本体。
・メール処理部分
注意点
templateシート
FromAddrシート
AdressListシート
上記シートは指定の形式で準備する必要があります。
あと会社のメールサーバでは検証しましたがGmailはポート閉じられてて検証できませんでした。
例のごとく本ソースは無保証なので、使用した結果生じたトラブルに関しては
責任は持てませんのであしからず。
そいつを送信するとか言うCDOのメール送信用マクロ作成しました。
まぁ、決してやってはいけない用途で作ったんですが・・・・。
だいたい1つずつ手でメールを打つのもなぁ。
かといってBccで全員に送るのもなぁ。というので
けど本当は手書きでやるべきですがね。
・EXCELを処理する本体。
' AdressListにある区分、会社名、氏名を引いてきて
' 区分に応じたテンプレートのメールを送信する
' 区分に応じてメール件名、テンプレート、署名が可変となる
'
'
Sub ボタン1_Click()
Const Replaceword = "●●" 'メールで埋め込みしたい場合の置換前文字列
Dim rtn As String
Dim selectFlg As String '送信テンプレート判定用フラグ
Dim Category As String '送信属性(本文判定用)
Dim toMailaddr As String '宛先メールアドレス
Dim toCompany As String '会社
Dim toName As String '名前
Dim toHeader As String '宛名
Dim messagetxt As String '本文
Dim signature As String 'メール署名
Dim messageBody As String 'メールBody
Dim AddrSheet As Worksheet 'アドレスリストシート
Dim TemplateSheet As Worksheet 'メールテンプレート用シート
Dim FromAddrSheet As Worksheet 'FROM用設定シート
Dim addrloopCnt As Long 'メールアドレス行数
Dim temploopCnt As Long 'テンプレート行数
Dim i As Long 'メールアドレスループカウンター
Dim j As Long 'メールテンプレートループカウンター
Dim k As Long '送信件数用
Dim subject As String '件名
Dim FromMailAddr As String 'Fromアドレス
Dim bccMailAddr As String 'BCC
'シート定義(ここをもう少し綺麗に書ける方法はないか？)
'送信先アドレスシート設定
Set AddrSheet = ThisWorkbook.Worksheets("AdressList")
addrloopCnt = AddrSheet.Cells(Rows.Count, 1).End(xlUp).Row
'テンプレートシート設定
Set TemplateSheet = ThisWorkbook.Worksheets("template")
temploopCnt = TemplateSheet.Cells(Rows.Count, 1).End(xlUp).Row
'送信元アドレスシート
Set FromAddrSheet = ThisWorkbook.Worksheets("FromAddr")
FromMailAddr = FromAddrSheet.Cells(2, 1).Value 'A列(送信元アドレス)
bccMailAddr = FromAddrSheet.Cells(2, 2).Value 'B列(BCCアドレス)
'送信対象件数が0件、テンプレートが存在しないなら処理しない
If addrloopCnt = 1 Or temploopCnt = 1 Then
MsgBox ("アドレスリストに処理対象がないか、メールテンプレートの登録漏れです。")
Exit Sub
End If
'メイン処理
k = 0
For i = 2 To addrloopCnt
Mailaddr:
Category = AddrSheet.Cells(i, 1).Value 'A列(区分)
toCompany = AddrSheet.Cells(i, 2).Value 'B列(会社名)
toName = AddrSheet.Cells(i, 4).Value 'D列(氏名)
toMailaddr = AddrSheet.Cells(i, 5).Value 'E列(メールアドレス)
If toMailaddr = "" Then '送信先メールが空欄だと処理しない
i = i + 1
GoTo Mailaddr
Else
'メールテンプレート取得
j = 2
For j = 2 To temploopCnt
MailTemplate:
If Category = TemplateSheet.Cells(j, 1).Value Then
subject = TemplateSheet.Cells(j, 2).Value 'B列(件名)
messagetxt = TemplateSheet.Cells(j, 3).Value 'C列(本文)
signature = TemplateSheet.Cells(j, 4).Value 'D列(署名)
Exit For
Else
j = j + 1
GoTo MailTemplate:
End If
Next j
'改行コードをLFからCR+LFに置き換えと名前の埋込
messagetxt = Replace(messagetxt, vbLf, vbCrLf)
signature = Replace(signature, vbLf, vbCrLf)
messagetxt = Replace(messagetxt, Replaceword, toName)
'社名があれば社名と氏名、氏名のみの場合は氏名のみに
If toCompany <> "" Or IsEmpty(toCompany) Then
toHeader = toCompany & vbCrLf & toName & vbCrLf
Else
toHeader = toName & vbCrLf
End If
'メール本文組立
messageBody = toHeader & vbCrLf & messagetxt & vbCrLf & signature
'メール送信
rtn = SendMail(toMailaddr, FromMailAddr, bccMailAddr, subject, messageBody)
'エラー制御
If rtn = "True" Then
k = k + 1
Else
MsgBox (i & "行目の処理でエラーが発生しました。詳細メッセージは以下を確認してください。" & vbCrLf & rtn)
End If
End If
Next i
MsgBox (k & "件のメール送信が完了しました。")
End Sub
・メール処理部分
' メール送信用マクロ
' 参照：http://excel-ubara.com/excelvba4/EXCEL233.html
' https://www.ka-net.org/blog/?p=4730
' http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_800_080.html
' http://serialty.blog117.fc2.com/blog-entry-10.html
' http://no-idea.doorblog.jp/archives/44367271.html
' http://excelfactory.net/excelboard/excelvba/cfs.cgi?logs=.%2Fvbadat%2Fexcelqa.dat&word=%82%ED%82%EA
'
'
Function SendMail(toMailaddr, FromMailAddr, bccMailAddr, subject, toBody) As String
Const cdoBasic = 1
Const cdoSendUsingPort = 2
Const cdoSendPassword = "http://schemas.microsoft.com/cdo/configuration/sendpassword"
Const cdoSendUserName = "http://schemas.microsoft.com/cdo/configuration/sendusername"
Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Const cdoSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
Const cdoSMTPServerPort = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Const cdoSMTPUseSSL = "http://schemas.microsoft.com/cdo/configuration/smtpusessl"
Const cdoSMTPAuthenticate = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
Dim strErr As String
Dim objCDO As New CDO.Message
SendMail = "True"
'メール関連定義
With objCDO
.MDNRequested = False '開封確認
.MimeFormatted = True 'MIMEを使って書式設定
.From = FromMailAddr 'From
.To = toMailaddr 'To
.BCC = bccMailAddr 'BCC
.subject = subject '件名
.TextBody = toBody '本文
'メールサーバ設定
With .Configuration.Fields '設定項目
.Item(cdoSendUsingMethod).Value = cdoSendUsingPort '
.Item(cdoSendPassword).Value = "mypass" 'パスワード
.Item(cdoSendUserName).Value = "myaddr@gmail.com" 'メールアカウント
.Item(cdoSMTPAuthenticate).Value = cdoBasic
.Item(cdoSMTPServer).Value = "smtp.gmail.com" 'SMTPサーバ
.Item(cdoSMTPServerPort).Value = 465 'ポート番号
.Item(cdoSMTPUseSSL).Value = True 'SSL使用
.Item(cdoSMTPConnectionTimeout).Value = 100 'タイムアウト
.Item(CdoConfiguration.cdoLanguageCode) = CdoCharset.cdoShift_JIS '文字セット指定
.Update '設定を更新
End With
With .Fields
.Item("urn:schemas:mailheader:X-Priority") = 1 '重要度、通常は以下のどちらかで良い
.Item("urn:schemas:mailheader:X-MsMail-Priority") = "High"
.Update '設定を更新
End With
On Error Resume Next
.Send '送信
If Err.Number <> 0 Then
strErr = "エラーが発生しました。" & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description
SendMail = strErr
End If
On Error GoTo 0
End With
Set objCDO = Nothing
End Function
注意点
templateシート
| 区分 | 件名 | 本文 | 署名 |
FromAddrシート
| 送信元メールアドレス | BCCアドレス(複数の場合は「;」で区切ってください。) |
AdressListシート
| 区分 | 会社名 | 部署名 | 氏名 | メールアドレス |
上記シートは指定の形式で準備する必要があります。
あと会社のメールサーバでは検証しましたがGmailはポート閉じられてて検証できませんでした。
例のごとく本ソースは無保証なので、使用した結果生じたトラブルに関しては
責任は持てませんのであしからず。
コメント