Excelからメールを送信するプログラムの総まとめ。

これまでにExcelからメール送信するプログラムを作ってきましたが、今回はその総まとめです。

システムの完成図、どんな機能・特徴が実現できたのか、フォーム「frm送信」のVBAプログラム全体を、整理して掲載しておきます。

【メール送信完成図】
・ワークシート「設定」 (メールサーバーの設定)
mail-297.gif

・ワークシート「送信」 (氏名、メルアドなどの情報)
mail-296.gif

・フォーム「frm送信」 (実際にメール送信する画面)
mail-295.gif


【機能と特徴】 順序不同
(1)ワークシート「設定」で、メールサーバーの設定が可能。
(2)氏名やメールアドレスなどの情報を、ワークシート上で管理できる。
(操作に慣れているExcelなので、管理が楽。一覧できるので見やすい。)
(3)ExcelのBookごとコピーすれば、目的に合わせてメルアドをグループ管理できる。
(4)独自のメルマガ配信などに応用可能。
(5)ワークシートの値を参照して利用できる。
(商品名や金額などのデータを、メールに挿入可能)
(6)メールの件名や本文に、挿入タグを使い、データを自動的に挿入できる。
(氏名など)
(7)メール送信する範囲を選択できる。
(8)メールを一括送信できる。
(9)1件だけ送信することも可能。
(10)複数の添付ファイルを指定して送信できる。
(11)添付ファイルは、メールごとに変えることができる。
(12)ワークシートを切り替えると、フォームが自動的に表示される。
(13)ちゃんとエラー処理を行なっている。
(14)行番号の値をチェックしている。
(15)氏名やメールアドレスで未入力がないか、チェックしている。
(16)正規表現で、メールアドレスが適切かどうか、チェックしている。
(17)ログファイルに送信結果の記録が残る。
(18)sentフォルダに送信済み履歴が残る。

以上で、メール送信に必要な基本的な機能は、実現できました。

また、一般的なメーラーでは出来ないような機能を実現することができたので、オリジナルのメール送信プログラムを作成する価値は、あったと思います。


【送信プログラム全体を掲載】
*「\」はWindowsでは円記号のことです。

Option Explicit

Dim svname As String
Dim id As String
Dim pass As String
Dim mSender As String '送信者
Dim mailq As String 'メールキュー
Dim logfile As String 'ログファイル
Dim startPos As Long '開始行番号
Dim endPos As Long '終了行番号

Private Sub cmd送信_Click()
  
  'エラーが発生したら処理を行なう
  On Error GoTo Err_Shori
    
  Dim bobj As Object
  Dim mailto As String
  Dim mailfrom As String
  Dim subj As String
  Dim body As String
  Dim msg As Variant 'メール作成チェック用
  Dim rc As Integer '一括送信チェック用
  Dim i As Long
  Dim tName As String
  Dim eMail As String
    
  '行番号の値をチェック
  If endPos < startPos Then
    Me.lblMsg = "終了行番号は、開始行番号以上の値を入力してください。"
    'フォーカスを移す
    Me.txtEndPos.SetFocus
    'メール送信ボタン使用不可
    Me.cmd送信.Enabled = False
    Exit Sub
  End If
  
  '未入力の項目が無いかチェック
  For i = startPos To endPos
    'ワークシートの値を取得
    tName = Trim(Range("A" & i).Value)
    eMail = Trim(Range("B" & i).Value)
    
    If tName = "" Or eMail = "" Then
      Me.lblMsg = "行番号" & i & "にデータが未入力の項目があります。"
      'フォーカスを移す
      Me.txtEndPos.SetFocus
      'メール送信ボタン使用不可
      Me.cmd送信.Enabled = False
      Exit Sub
    End If

  Next i
    
  'オブジェクトを作成
  Set bobj = CreateObject("basp21")
  
  'メールアドレスが有効かチェック
  Dim match As Integer
  Dim target As String
  Dim regstr As String
  
  regstr = "/^[\w\-+\.]+\@[\w\-+\.]+$/i"
  
  For i = startPos To endPos
    'ワークシートの値を取得
    eMail = Trim(Range("B" & i).Value)
    target = eMail
    
    match = bobj.match(regstr, target)
        
    If match = 0 Then
      Me.lblMsg = "行番号" & i & "のメールアドレスが正しくありません。"
      'メール送信ボタン使用不可
      Me.cmd送信.Enabled = False
      Exit Sub
    End If

  Next i
  
    
  '送信者
  mailfrom = mSender & vbTab & id & ":" & pass
    
  '件名取得
  subj = Me.txtSubject
  
  '本文取得
  body = Me.txtBody
  
  Dim tmpSubj As String
  Dim tmpBody As String
  Dim itemName As String
  Dim price As String
  Dim files As String
  
  '開始~終了行番号のメールを作成
  For i = startPos To endPos
    'ワークシートの値を取得
    tName = Trim(Range("A" & i).Value)
    eMail = Trim(Range("B" & i).Value)
    
    '宛先
    mailto = eMail
        
    '件名を一時変数に代入
    tmpSubj = subj
    
    '件名に自動挿入
    tmpSubj = Replace(tmpSubj, "[氏名]", tName)
    
    '本文を一時変数に代入
    tmpBody = body
        
    '本文に自動挿入
    tmpBody = Replace(tmpBody, "[氏名]", tName)
    
    itemName = Trim(Range("D" & i).Value)
    tmpBody = Replace(tmpBody, "[商品名]", itemName)
    
    price = Trim(Range("E" & i).Value)
    price = Format(CLng(price), "##,##0")
    tmpBody = Replace(tmpBody, "[金額]", price)
    
    '添付ファイル
    files = Trim(Range("F" & i).Value)
    files = Replace(files, ";", vbTab)
    
    'メール作成
    msg = bobj.SendMail(mailq, mailto, mailfrom, tmpSubj, tmpBody, files)
    
    '作成チェック
    If msg <> "" Then
      MsgBox "行番号" & i & "のメールで作成エラー。" & vbCrLf & msg, vbOKOnly + vbCritical, "作成時エラー"
      
      '送信用フォルダをクリアする
      If Dir(mailq & "\*.txt") <> "" Then
        Kill mailq & "\*.txt"
      End If
      
      Exit Sub
    Else
      Me.lblMsg = "行番号" & i & "のメールを作成しました。"
    End If
    
  Next i
  
  Me.lblMsg = "メール送信開始・・・"
  
  'メール一括送信
  rc = bobj.FlushMail(svname, mailq, logfile)
  
  '送信チェック
  If rc <= 0 Then
    MsgBox "送信できませんでした。" & vbCrLf & "エラー:" & rc, vbOKOnly + vbCritical, "送信時エラー"
  Else
    MsgBox rc & "件のメールを送信しました。", vbOKOnly + vbInformation, "完了"
  End If
  
  'ラベルをクリア
  Me.lblMsg = ""
    
Err_Shori_Exit:
  Exit Sub

'ここからエラー処理
Err_Shori:
  MsgBox Err.Description, vbOKOnly + vbCritical, "実行時エラー"
  Resume Err_Shori_Exit
'ここまで

End Sub

Private Sub txtEndPos_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  'エラーが発生したら処理を行なう
  On Error GoTo Err_Shori
  
  'メール送信ボタン使用不可
  Me.cmd送信.Enabled = False
  
  '行番号が空白の時の処理
  If Me.txtEndPos = "" Then
    Me.lblMsg = "終了行番号を入力してください。"
    Cancel = True
    Exit Sub
  End If
  
  '行番号を取得
  endPos = CLng(Me.txtEndPos)
  
  '行番号が2未満の時の処理
  If endPos < 2 Then
    Me.lblMsg = "終了行番号は、2以上の数値を入力してください。"
    Cancel = True
    Exit Sub
  End If
  
  'ラベルをクリア
  Me.lblMsg = ""
  'メール送信ボタン使用可
  Me.cmd送信.Enabled = True
  
Err_Shori_Exit:
  Exit Sub

'ここからエラー処理
Err_Shori:
  MsgBox Err.Description, vbOKOnly + vbCritical, "実行時エラー"
  Cancel = True
  Resume Err_Shori_Exit
'ここまで

End Sub

Private Sub txtStartPos_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  'エラーが発生したら処理を行なう
  On Error GoTo Err_Shori
  
  'メール送信ボタン使用不可
  Me.cmd送信.Enabled = False
  
  '行番号が空白の時の処理
  If Me.txtStartPos = "" Then
    Me.lblMsg = "開始行番号を入力してください。"
    Cancel = True
    Exit Sub
  End If
  
  '行番号を取得
  startPos = CLng(Me.txtStartPos)
  
  '行番号が2未満の時の処理
  If startPos < 2 Then
    Me.lblMsg = "開始行番号は、2以上の数値を入力してください。"
    Cancel = True
    Exit Sub
  End If
  
  'ラベルをクリア
  Me.lblMsg = ""
  'メール送信ボタン使用可
  Me.cmd送信.Enabled = True
  
Err_Shori_Exit:
  Exit Sub

'ここからエラー処理
Err_Shori:
  MsgBox Err.Description, vbOKOnly + vbCritical, "実行時エラー"
  Cancel = True
  Resume Err_Shori_Exit
'ここまで

End Sub

Private Sub UserForm_Initialize()
  'メール送信ボタン使用不可
  Me.cmd送信.Enabled = False
  
  '初期値
  Me.txtStartPos = 2
  Me.txtEndPos = 2
  startPos = 2
  endPos = 2
  
  '送信者
  mSender = Trim(Sheets("設定").Range("B1").Value)
  
  'SMTPサーバー
  svname = Trim(Sheets("設定").Range("B2").Value)
  
  '送信ID
  id = Trim(Sheets("設定").Range("B3").Value)
  
  '送信パスワード
  pass = Trim(Sheets("設定").Range("B4").Value)
  
  'メールキュー
  mailq = "C:\mailPG\Send"
  
  'ログファイル
  logfile = "C:\mailPG\logfile.txt"
End Sub



上記のプログラムは、プログラミング初心者向けに分かりやすく書くため、処理が上から下に流れるように書いています。また全てイベントプロシージャ内に記述しています。

実は Subプロシージャ や Functionプロシージャ を使うと、プログラムを分離分割できるので、もっとスッキリ書くことができます。

でもプログラミング入門編としては、今のままで十分だと思います。

このプログラムを基に、あなたなりの機能を付け加えていくと、独自のメール送信プログラムを、簡単に作ることができます。

また、メール送信の応用編として、課題で「ステップメール」を作成しますが、それも上記のプログラムを基にしています。

まだ未完成の人は、課題の前にプログラムを完成させておいてください。

スポンサードリンク

スポンサードリンク






メール送信・受信プログラミング初心者入門 TOPへ