SEの転職活動で使うべきサイト・エージェント 目指せ年収アップ
SEの転職活動で使うべきサイト・エージェント 目指せ年収アップ
東南アジアをバックパッカーしながら転職活動をした記録
東南アジアをバックパッカーしながら転職活動をした記録
7年目で初の転職活動 2カ月で内定獲得した記録
7年目で初の転職活動 2カ月で内定獲得した記録
おすすめのプログラミングスクール めざせ就職・年収アップ!
おすすめのプログラミングスクール めざせ就職・年収アップ!
メンズクリア2年通い放題入会! その後のヒゲ状況(不定期更新)
メンズクリア2年通い放題入会! その後のヒゲ状況(不定期更新)
ブログ開始3年が経った月収が1万超えてた!
ブログ開始3年が経った月収が1万超えてた!
プログラミング独学・スクール・就職(目次)
プログラミング独学・スクール・就職(目次)
previous arrowprevious arrow
next arrownext arrow
 
Shadow
VBA

Excel VBA メール送信ツール(フリーメール)

VBAでメール送信について紹介します。

自動でメール送信するツールを作ってみました。

今回はOutlookではなくフリーメール(YahooJapan)です。

実際に作ったファイルはこちらから無料でダウンロードできます。

使い方の説明はこちらからダウンロード可能です。

エクセルの名前の定義

エクセル自体にもセル名の定義をしているので、まずそこから説明しておきます。

意外とエクセルのVBAでは名前の定義を色々使えると良いことが多いです。

仕様と合わせて説明します。

仕様

①「送信元アカウント」を選択します。

リストは「アカウント」をもとに選べます。

下の画像で言うと、Gmail、Yahoo、YahooUSAがあるので3つから選べる状態です。

②送信ボタンをクリックすると「送信元アドレス」からとなりのシートを1つずつ読込んでメールを送信していきます。

名前の定義

メインシートの各名前は以下のようなルールで定義づけしています。

SMTPServer   :[送信元アカウント] + [_smtpserver]
PortNumber   :[送信元アカウント] + [_smtpserverport]
送信アカウント名 :[送信元アカウント] + [_sendusername]
パスワード    :[送信元アカウント] + [_sendpassword]
送信元アドレス  :[送信元アカウント] + [_From]

「メール送信」ボタンクリック後、後続の処理で「送信元アカウント」と文字連結をして送信を行います。

GoogleSpreadSheetから自動でメール送信 GoogleSpreadSheetを使って指定時刻にメールを送信するプログラムを作ってみました。 GoogleSpread...

メール用の参照設定(CDO)

参照設定

ファイル用もフォルダ用もダイアログを開くに参照設定を必要です。

手順はコードエディターから「ツール(T)」→「参照設定(R)」と移動します。

その後、Microsoft CDO for Windows 2000 Libraryにチェックを付けておいてください。

CDOとはMicrosoft Collaboration Data Objectsのことだそうです。

CDO は、メッセージング機能を持つアプリケーションの作成を容易にするために、あるいは、既存のアプリケーションにメッセージング機能を追加するために設計されたものです。
microsoft.comより

Gmailの送信許可は不可になった

Gmailアカウントを使ってメール送信する場合は「安全性の低いアプリのアクセス」許可しておく必要があります。

設定は以下にアクセスすることで変更できます。

https://myaccount.google.com/lesssecureapps

2022年5月からGmailはユーザとパスワードでログインすることはできなくなりました。

YahooJapanアカウントを使ってメール送信する場合は特に設定は必要はないようです。

メール送信処理のコード

処理の流れは以下の順です。

①メインシートから送信元情報を取得
②となりのシートから送信メール内容を取得
③添付ファイルをメールオブジェクトに貼り付ける
④メールを送信する
⑤次のシートを同様に処理

コード

'==============================
'目的    :シート分のメールを送信する
'==============================
Sub SendMail_Click()

  Dim MyDir As String                   '自分のファイルが存在するディレクトリ格納用
  Dim i As Long                      'ループ用変数
  Dim j As Long                      'ループ用変数
  Dim SheetCnt As Long                   'シート数を格納する変数
  Dim SheetName As String                 'シート名を格納する変数

  Dim ToAddress As String                 'Toアドレス用の変数
  Dim CcAddress As String                 'Ccアドレス用の変数
  Dim BccAddress As String                'Bccアドレス用の変数
  Dim FromAddress As String                'Fromアドレス用の変数
  Dim cdoMsg As Object                  'CDOメッセージオブジェクト用変数
  Dim cdoConf As Object                 'CDOコンフィグレーションオブジェクト用変数
  Dim strMailBody As String               'メール本文用の変数
  Dim strSubject As String                '件名用の変数
  Dim strSignature As String               '署名用の変数
  Dim strAttachmentPath As String            '添付ファイルの格納用変数
  Dim strAttachmentsPath() As String          '添付ファイルの格納配列
  Dim strSendAccount As String              '送信するアカウント
  
  '固定値をセット(長いと見づらいため)
  Const cstUnderscore As String = "_"          'アンダーバー
  Const cstSendusing As String = "http://schemas.microsoft.com/cdo/configuration/sendusing"
  Const cstSmtpserver As String = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
  Const cstSmtpserverport As String = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
  Const cstSendusername As String = "http://schemas.microsoft.com/cdo/configuration/sendusername"
  Const cstSendpassword As String = "http://schemas.microsoft.com/cdo/configuration/sendpassword"
  Const cstSmtpauthenticate As String = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
  Const cstSmtpusessl As String = "http://schemas.microsoft.com/cdo/configuration/smtpusessl"

  'エラー時はErrCatchラベルへ
  On Error GoTo ErrCatch
  
  '-------シート枚数分ループ(2枚目のシートから)-------
  '自分の配置されているパスを取得
  MyDir = ThisWorkbook.Path
  
  'シート件数を取得
  SheetCnt = ThisWorkbook.Sheets.Count
  
  For i = 2 To SheetCnt
  
    '----------送信元アカウント情報を設定(メインシートから取得)----------
    'CDOをオブジェクト作成
    Set cdoMsg = CreateObject("CDO.Message")
    Set cdoConf = CreateObject("CDO.Configuration")
    
    cdoConf.Load -1
    
    '送信元アカウントを取得
    strSendAccount = Sheets(1).Range("SendAccount").Value
    
    '送信元アカウントが未選択の場合終了
    If strSendAccount = "" Then
      MsgBox "送信元アカウントを設定してください。"
      End
    End If
    
    '送信元アカウントにアンダーバーをセット
    strSendAccount = strSendAccount + cstUnderscore
    
    With cdoConf.Fields
      .Item(cstSendusing) = 2
      .Item(cstSmtpserver) = Sheets(1).Range(strSendAccount & "smtpserver").Value
      .Item(cstSmtpserverport) = Sheets(1).Range(strSendAccount & "smtpserverport").Value
      .Item(cstSendusername) = Sheets(1).Range(strSendAccount & "sendusername").Value
      .Item(cstSendpassword) = Sheets(1).Range(strSendAccount & "sendpassword").Value
      .Item(cstSmtpauthenticate) = True
      .Item(cstSmtpusessl) = True
      .Update
    End With
    
    'Fromアドレス取得
    FromAddress = Sheets(1).Range(strSendAccount & "From").Value
    
    '重要度を変更
    cdoMsg.Fields.Item("urn:schemas:mailheader:X-Priority") = 1
    cdoMsg.Fields.Update
    
    '-------各メールフォーマットから取得-------
    'シート名を取得
    SheetName = Sheets(i).Name

    '-------メール情報を取得-------
    'セル内改行(LF)はCRLFに置換 → Yahooでは落ちるため
    ToAddress = Replace(Sheets(i).Range("Mail_TO").Value, vbLf, vbCrLf)      'To宛先
    CcAddress = Replace(Sheets(i).Range("Mail_CC").Value, vbLf, vbCrLf)      'cc宛先
    BccAddress = Replace(Sheets(i).Range("Mail_BCC").Value, vbLf, vbCrLf)     'bcc宛先
    strSubject = Replace("【" & SheetName & "様】" & _
              Sheets(i).Range("Mail_Subject").Value, vbLf, vbCrLf)    '件名
    strMailBody = Replace(Sheets(i).Range("Mail_Body").Value, vbLf, vbCrLf)    'メール本文
    strSignature = Replace(Sheets(i).Range("Mail_Signature").Value, vbLf, vbCrLf) '署名
  
    '-------メールに情報をセットする-------
    With cdoMsg
      Set .Configuration = cdoConf
      .From = FromAddress
      .To = ToAddress
      .CC = CcAddress
      .BCC = BccAddress
      .MDNRequested = True
      .Subject = strSubject
      .TextBody = strMailBody & vbCrLf & vbCrLf & strSignature
      .BodyPart.Charset = "utf-8"
    End With
    
    '-------添付ファイルを貼り付ける-------
    '[yyyymmdd_会社名].[拡張子]を検索し、取得する
    strAttachmentsPath() = FileSearch(Format(Now(), "yyyymmdd") & "_" & SheetName & ".*", MyDir & "\添付ファイル\")  '"

        If strAttachmentsPath(0) = "dummy" Then
            '添付ファイルが一件もなければ、次のメール処理へ行く(発注連絡が不要なため)
            GoTo nextDO
        Else
            '添付ファイルが一件でもあれば添付
    
                'ファイル件数分ループして添付する
                For j = 0 To UBound(strAttachmentsPath())
                    'ファイルパスを取得
                    strAttachmentPath = strAttachmentsPath(j)
    
                    'ファイルを添付
                    cdoMsg.AddAttachment strAttachmentPath
                Next j
        End If

    '-------メールを送信する-------
    'メール送信
    cdoMsg.Send

nextDO:
    '-------Outlookを閉じる(オブジェクトを解放)---
    Set cdoMsg = Nothing
    Set cdoConf = Nothing

  Next i
  
  MsgBox "送信が完了しました。"
  
'エラーキャッチ
ErrCatch:
  
  ' エラーの場合、エラーメッセージを表示する
  Call ShowErrMsg
  
End Sub

メール送信処理の解説

送信元アカウント情報を設定(メインシートから取得)

strSendAccount = Sheets(1).Range(“SendAccount”).Value

でメインシートの名前「SendAccount」からアカウント名を取得しています。

その後取得したアカウント名とSMTPServerやPortNumberの名前を文字連結して送信するための情報を取得しています。

送信元アカウントでGmailを選んだなら.Range(strSendAccount & “smtpserver”).Valueの中身はRange(“Gmail_smtpserverport)”.Value

Yahooを選んだならRange(“Yahoo_smtpserverport”).Valueのようになります。

メール情報を取得

ここでは改行コードLFをCRLFに置換しています。

なぜかと言うとYahooで送信する場合は、エラーになるためです。

改行コードがCRとLFではなく、LFだけの行があるために、エラー
メールが送信できるようになった より

改行があっても動いて欲しいものですが、仕様なら仕方ありませんね…

メールに情報をセットする

ここではメールのオブジェクトに件名や宛先などをセットしています。

添付ファイルを貼り付ける

FileSearchメソッドを使って、添付ファイルのパスを取得しメールのオブジェクトに張り付ける処理を行っています。

FileSearchは後で説明を記載しています。

その後、添付ファイルがない場合、メールは送らず次のシートを処理するようになっています。

※発注連絡という想定なので、発注書の添付ファイルがなければ連絡はする必要がないから送らないという考え方です。

メール添付ファイル取得 FileSearchメソッド

送信対象のファイル([yyyymmdd_シート名.拡張子]フォーマット)のファイル名を検索し配列に格納する処理です。

検索する場所は「..\VBA Outlookメール送信\添付ファイル」以下のみです。

他の場所に配置したファイルは添付ファイルとして検索されません。

コード

'==============================
'目的    :添付ファイルを検索し、ファイルのパスを取得する
'引数    :SearchText         検索するファイル名
'       :SearchPath         検索するパス
'戻り値   : ファイルパスの配列
'==============================
Private Function FileSearch(SearchText As String, SearchPath As String) As String()

    Dim FileName As String
    Dim Cnt As Long
    Dim Files() As String                         'ファイルパス格納用配列
    
    '中身をダミー値でセット
    ReDim Files(0)
    Files(0) = "dummy"
    
    'ファイルを検索
    FileName = Dir(SearchPath & "\" & SearchText)
    
    Do While FileName <> ""
        
        'ファイル名を返却用配列に格納
        ReDim Preserve Files(Cnt) As String
        Files(Cnt) = SearchPath & FileName
        Cnt = Cnt + 1
        
        ' 次のファイル名を参照
        FileName = Dir()
    Loop

    FileSearch = Files()
  
End Function

解説

引数として受け取った検索フォルダ(SearchPath)を検索条件(SearchText)を元に検索します。

見つかったファイルのパスを配列に格納していきます。

検索条件に一致するファイルが見つからなくなったら配列を呼び出し元に返しています。

エラー表示 ShowErrMsgメソッド

エラーをキャッチするメソッドです。

予測できないエラーがあればここでキャッチしてエラーがあったことをメッセージ表示します。

コード

'==============================
'目的    :エラーの場合、エラーメッセージを表示する
'==============================
Public Sub ShowErrMsg()

  'エラーがあればメッセージ表示
  If Err.Number <> 0 Then
    MsgBox "想定外のエラーが発生しました。" & vbCrLf + _
        "エラー番号:" + CStr(Err.Number) & vbCrLf + _
        "エラーの種類:" + Err.Description
  End If

End Sub

解説

エラーがあった場合、そのエラー番号とエラー内容をメッセージ表示します。

送信結果

送信結果はこんなメールです。

GoogleSpreadSheetから自動で予定をメールお知らせ 予定がいっぱいあると、忘れてしまいがちなので、事前に通知してくれるアプリが欲しいと思っていました。 なので、以前C#で予定...
プログラミング初心者の独学方法 文系卒の経験談 私はIT系の会社に勤めて4年目ですが、最初の1年は開発をさせてもらえませんでした。 文系卒でプログラミング経験はなかったの...

・メールを送信する
http://officetanaka.net/excel/vba/tips/tips45.htm
・「 Gmailで相手に一斉に送信するエクセルマクロ」のコメント一覧
http://bzowner.blog.fc2.com/blog-entry-2.html?sp&m2=res
・CDO.Messageによるメール送信
http://serialty.blog117.fc2.com/blog-entry-10.html
・iCloud メールクライアント向けのメールサーバ設定
https://support.apple.com/ja-jp/HT202304
・CDOでメール送信
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_800_080.html
・VBAでメール送信する
https://excel-ubara.com/excelvba4/EXCEL233.html
・VBAでGmail送信!CDOを活用してメールを操作する方法
http://www.fastclassinfo.com/entry/vba_gmail_sendmail
・メールが送信できるようになった
https://ajya.hatenablog.jp/entry/2012/03/22/223917
・CDO の概要
https://msdn.microsoft.com/ja-jp/library/cc446847.aspx

・【Excel VBA】【マクロ】【Tips】Sgn関数はExcel64bit版では使えない?

https://lenoco.tokyo/?p=136

ABOUT ME
LooseCarrot
LooseCarrot
ブログ運営をしているLooseCarrotです。 興味のあることにトライして発信していきます! プロフィール

関連している記事