Excel メール送信フォームのプログラム全体を掲載します。

メール送信の改良を行なってきましたが、いろいろ変更点が多かったので、ここでフォーム「frm送信」のVBAプログラム全体を掲載しておきます。

上手く出来なかった人は、参考にしてください。


Option Explicit

Dim svname As String
Dim id As String
Dim pass As String
Dim mSender As String

Dim pos As Long
Dim tName As String
Dim eMail As String

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 '送信チェック用
    
  'オブジェクトを作成
  Set bobj = CreateObject("basp21")
  
  '宛先
  mailto = eMail
  
  '送信者
  mailfrom = mSender & vbTab & id & ":" & pass
    
  '件名
  subj = Me.txtSubject
  
  '本文
  body = Me.txtBody
  
  'メール送信
  msg = bobj.SendMail(svname, mailto, mailfrom, subj, body, "")
  
  ' 送信チェック
  If msg <> "" Then
    MsgBox "送信できませんでした。" & vbCrLf & msg, vbOKOnly + vbCritical, "送信時エラー"
  Else
    MsgBox "送信に成功しました。", vbOKOnly + vbInformation, "完了"
  End If
    
Err_Shori_Exit:
  Exit Sub

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

End Sub

Private Sub txtPos_Exit(ByVal Cancel As MSForms.ReturnBoolean)

  'エラーが発生したら処理を行なう
  On Error GoTo Err_Shori
  
  'メール送信ボタン使用不可
  Me.cmd送信.Enabled = False
  
  '行番号が空白の時の処理
  If Me.txtPos = "" Then
    Me.lblMailto = "行番号を入力してください。"
    Cancel = True
    Exit Sub
  End If
  
  '行番号を取得
  pos = CLng(Me.txtPos)
  
  '行番号が2未満の時の処理
  If pos < 2 Then
    Me.lblMailto = "行番号は、2以上の数値を入力してください。"
    Cancel = True
    Exit Sub
  End If
  
  'ワークシートの値を取得
  tName = Trim(Range("A" & pos).Value)
  eMail = Trim(Range("B" & pos).Value)
  
  '未入力の項目が無いかチェック
  If tName = "" Or eMail = "" Then
    Me.lblMailto = "この行は、データが未入力の項目があります。"
    Cancel = True
  Else
    '送信先を表示
    Me.lblMailto = "氏名:" & tName & " " & "メールアドレス:" & eMail
    'メール送信ボタン使用可
    Me.cmd送信.Enabled = True
  End If
  
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.txtPos = 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)
End Sub




【補足】
そのまま全てコピー&ペーストすると、プログラムが動かないことがあります。

その場合は、各イベントプロシージャは、コンボボックスから選択して、中のプログラムだけコピー&ペーストするようにしてください。

スポンサードリンク

スポンサードリンク






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