none
Outlookでメール送信すると2件目から「Outlookで認識できない名前があります」と出る RRS feed

  • 質問

  • いつもお世話になっております。VBAを使用してExcel表を参照しながら、

    Outlookで複数の宛先に一括送信するマクロを作ってみました。

    Outlookのライブラリを参照し、同一のBook内にある「アドレス帳」というシートを見ながら

    「テンプレート」というシートをひな型にして送信するものです。

    1件目は正常に送信できるのですが、2件目を送信するときに、

    objMail.Send

    という行で、「Outlookで認識できない名前があります」というエラー(-2147467259)が出て止まってしまいます。

    objMail.Display と置き換えてみると、正常に送信したい状況で、Outlookのメッセージ送信画面が起動します。

    添付ファイル関係のオブジェクトを参照する行を外してみたのですが、結果は同じなのでこれが原因でもないようです。

    さっぱり判らず困っています。アドバイス頂けたら幸いです。

    OS:Windows10(1903)   Outlook2016

    ソースは下記の通りです。

    Sub SendEmail()
    Dim objOutlook As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim objAttach As Outlook.Attachments
    Dim wsTemp As Worksheet
    Dim wsMail As Worksheet
    Dim contents As Variant
    Dim i As Integer
    Set objOutlook = CreateObject("Outlook.Application")
    Set wsTemp = ThisWorkbook.Sheets("テンプレート")
    Set wsMail = ThisWorkbook.Sheets("アドレス帳")
    On Error GoTo err:
    For i = 1 To 999
        With wsMail
            Set objMail = objOutlook.CreateItem(olMailItem)
            If .Cells(i, 1).Value = "" Then Exit For        'アドレス帳が終わるまで繰り返し
            objMail.To = .Cells(i, 2).Value                'メール宛先
            objMail.subject = wsTemp.Range("B1").Value      'メール件名
            objMail.BodyFormat = olFormatPlain              'メールの形式
            objMail.Body = Replace(Replace(Replace(wsTemp.Range("B2").Value, "$1", .Cells(i, 1).Value), "$2", .Cells(i, 2).Value), "$3", .Cells(i, 3).Value)
            Set objAttach = objMail.Attachments
            If wsTemp.Range("B3").Value <> "" Then
                objAttach.Add wsTemp.Range("B3").Value
            End If
            If wsTemp.Range("B4").Value <> "" Then
                objAttach.Add wsTemp.Range("B4").Value
            End If
            If wsTemp.Range("B5").Value <> "" Then
                objAttach.Add wsTemp.Range("B5").Value
            End If
    '        objMail.Display     // こちらではエラーが出ない
            objMail.Send
            Set objAttach = Nothing
            Set objMail = Nothing
        End With
    Next i
    Set objOutlook = Nothing
    MsgBox "送信完了"
    Exit Sub
    err:
    MsgBox err.Description & "(" & Str(err.Number) & ")"
    End Sub

    2019年10月30日 7:22