ＢＡＳＰ２１を使ったメール送信プログラムは結構存在しますが、ＷｉｎｏｄｗｓにＣＤＯが標準搭載されてからは、ＣＤＯを使っプログラムもリリースされるようになりました。
以下にサンプルプログラムを用意しました。
ヒントになればと思います。
GmailとYahoo mailで試したところ、本文のCRLFの扱いの違いがありました。
改行コードCRLFをLFに変換する機能は有った方が良いようです。
SMTPサーバーのプラットフォームの違いなのかもしれません。
サンプルプログラム
Option Explicit
'参照設定でCDOを参照しておくこと
Public passwd As String
Public sw As Byte
Sub MySendMail()
Dim ret As String
Dim szLogfile As String
Dim szServer As String, szTo As String, szFrom As String
Dim szSubject As String, szBody As String, szFile As String
Dim flBody
Dim i As Long
Dim fs, a As Object
Dim oMsg As New CDO.Message
Dim szCC As String, szBCC As String
On Error GoTo Err_Handler
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(Worksheets("設定").Cells(27, 1).Value, True) 'ログファイル
passwd = ""
oMsg.Configuration.Fields.Item(cdoSendUsingMethod) = cdoSendUsingPort '2
oMsg.Configuration.Fields.Item(cdoSMTPServer) = Worksheets("設定").Cells(11, 1).Value 'SMTPサーバー名
oMsg.Configuration.Fields.Item(cdoSMTPServerPort) = Worksheets("設定").Cells(13, 1).Value 'ポート番号
oMsg.Configuration.Fields.Item(cdoSMTPConnectionTimeout) = 60 'タイムアウト値
If Worksheets("設定").Cells(7, 1).Value <> "" Then 'CC
oMsg.CC = Worksheets("設定").Cells(7, 1).Value
End If
If Worksheets("設定").Cells(9, 1).Value <> "" Then 'BCC
oMsg.BCC = Worksheets("設定").Cells(9, 1).Value
End If
oMsg.Configuration.Fields.Item(cdoSMTPAuthenticate) = Worksheets("設定").Cells(15, 1).Value 'SMTP認証
'要パスワード認証の場合
If Worksheets("設定").Cells(17, 1) = 1 Then
UserForm1.Show
If sw = 1 Then
oMsg.Configuration.Fields.Item(cdoSendPassword) = passwd
Else
MsgBox "送信処理をキャンセルしました。"
GoTo Exit_sub
End If
End If
If Worksheets("設定").Cells(21, 1) = 1 Then
oMsg.Configuration.Fields.Item(cdoSMTPUseSSL) = True 'SSL暗号化
Else
oMsg.Configuration.Fields.Item(cdoSMTPUseSSL) = False 'SSL暗号化しない
End If
oMsg.Configuration.Fields.Item(cdoLanguageCode) = Worksheets("設定").Cells(23, 1).Value '文字コード
oMsg.Configuration.Fields.Update
' メール送信結果を記録するファイル名を指定します。
szServer = Worksheets("設定").Cells(11, 1) ' SMTPサーバ名
'
With Worksheets("宛名及び置換文字")
If .Cells(1, 3) & .Cells(1, 7) = "" Then
MsgBox "タイトルとＦＲＯＭを入力してください"
GoTo Exit_sub
Else
If MsgBox("タイトル：" & .Cells(1, 3) & vbCrLf & "送信元：" & .Cells(1, 7) & vbCrLf & vbCrLf & "上記でよろしいですか？", _
vbOKCancel, "確認") = vbCancel Then
GoTo Exit_sub
End If
End If
szSubject = .Cells(1, 3) ' 件名
szFrom = .Cells(1, 7) ' 送信元
If .Cells(1, 10) = "高" Then
oMsg.Fields("urn:schemas:mailheader:Importance") = "High"
oMsg.Fields("urn:schemas:mailheader:Priority") = 1
oMsg.Fields("urn:schemas:mailheader:X-Priority") = 1
oMsg.Fields("urn:schemas:mailheader:X-MsMail-Priority") = "High"
oMsg.Fields.Update
End If
If Worksheets("設定").Cells(19, 1).Value = "" Then
oMsg.Configuration.Fields.Item(cdoSendUserName) = Cells(1, 7).Value 'メールアドレス
Else
oMsg.Configuration.Fields.Item(cdoSendUserName) = Worksheets("設定").Cells(19, 1).Value 'ログインID
End If
oMsg.Configuration.Fields.Update
oMsg.From = szFrom
oMsg.Subject = szSubject
i = 3
Do While .Cells(i, 1) <> "END"
If .Cells(i, 1) = "○" Then
szTo = .Cells(i, 5) ' 宛先
szBody = .Cells(i, 6) ' 本文
If Worksheets("設定").Cells(25, 1).Value = 1 Then '改行コードCRLF
szBody = Replace(szBody, vbLf, vbCrLf)
End If
szFile = .Cells(i, 11) '添付ファイル
oMsg.To = szTo
oMsg.TextBody = szBody
If szFile <> "" Then
oMsg.AddAttachment szFile
End If
On Error GoTo ErrHandler1
oMsg.Send
.Cells(i, 1) = "完了"
cont1:
End If
i = i + 1
Loop
End With
' パラメータエラーのときは、戻り値にエラーメッセージが返ります。
MsgBox "終了しました"
GoTo Exit_sub
ErrHandler1:
MsgBox "エラー:" & Err.Number & vbCrLf & Err.Description
a.WriteLine (Date & " " & Time & " " & Err.Number & "－" & szTo & "－" & Err.Description)
Worksheets("宛名及び置換文字").Cells(i, 1) = "エラー"
Resume cont1
Err_Handler:
MsgBox Err.Description, vbCritical, "Error"
GoTo Exit_sub
Exit_sub:
a.Close
End Sub
