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

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")
    
  '送信者
  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
  
  '開始〜終了行番号のメールを作成
  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)
    
    'メール作成
    msg = bobj.SendMail(mailq, mailto, mailfrom, tmpSubj, tmpBody, "")
    
    ' 作成チェック
    If msg <> "" Then
      MsgBox "行番号" & i & "のメールで作成エラー。" & vbCrLf & msg, vbOKOnly + vbCritical, "作成時エラー"
      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