ＶＢＡ エクセルマクロでCDOを使ったメール送信プログラム

ＢＡＳＰ２１を使ったメール送信プログラムは結構存在しますが、ＷｉｎｏｄｗｓにＣＤＯが標準搭載されてからは、ＣＤＯを使っプログラムもリリースされるようになりました。
以下にサンプルプログラムを用意しました。
ヒントになればと思います。
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