Excel2016のVBAでOutlook2016のメールを作成しようとすると、エラーが発生します。

Question

先般、質問しました、

https://social.msdn.microsoft.com/Forums/ja-JP/51aa67c5-a3e1-446d-a22c-c7713aae3875/65317653686534765349653561239865334653146531312434210332999212?forum=vbajp

につきまして、下記のとおり改修しました。

（１）会社名、部署名、担当者名、メールアドレス（宛て先、cc、BCC）が空白の場合は、エラーとして処理を止める。

（２）メールの本文が空白の場合は、エラーとして処理を止める。

（３）メールの件名が空白の場合は、エラーとして処理を止める。

（４）送信先の１つ右の列に、番号を付与する。

（５）上記（５）の隣に、会社名、部署名、担当者名、メールアドレス（宛て先、cc、BCC）、添付ファイル（１～３）がすべて空白の場合は、「1」を表示する。具体的には、

=IF(NOT(AND(会社名="",部署名="",担当者名="",宛て先="",CC="",BCC="",添付ファイル1="",添付ファイル2="",添付ファイル3="")),1,"")

である。

（６）上記（５）の隣に、下記の数式を組み込み、その列の最大値を記入されている行数とする。

=IF(NOT(（５）の結果=""),COUNTIF($（５）の列$（５）の一番上のセル:$（５）の右隣のセル,1),"")

以上を踏まえて、下記のプログラムを組みました。

Option Explicit
Sub SendEmail()
 
Dim objOutlook As Outlook.Application
Dim i As Long
Dim rowMax As Long
Dim rowMax2 As Long
Dim wsList As Worksheet
Dim wsMail As Worksheet
Dim objMail As Outlook.MailItem
Dim rng As Range
Dim rc As Integer

Set objOutlook = New Outlook.Application
Set wsList = ThisWorkbook.Sheets("送信先")
Set wsMail = ThisWorkbook.Sheets("メール内容")
Set rng = wsList.Range("A5:I1048576")

rc = MsgBox("メールの作成を開始しますか？", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
    MsgBox "作成を中止します。"
    End
    End If

    '送信先が何も書いてない場合、処理を終了
    If Application.CountBlank(rng) = rng.Cells.Count Then
    MsgBox "送信先が何も書いてありません。送信先を入力してください。"
    End
    End If
   
    '件名が何も書いてない場合、処理を終了
    If wsMail.Range("B1").Value = "" Then
    MsgBox "件名が空白です。件名を入力してください。"
    End
    End If
   
    'メール本文が何も書いてない場合、処理を終了
    If wsMail.Range("B2").Value = "" Then
    MsgBox "メール本文が空白です。メール本文を入力してください。"
    End
    End If
   
    '送信先の件数
    'rowMax = wsList.Cells(wsList.Rows.Count, 12).End(xlUp).Row
    'If wsList.Cells(wsList.Rows.Count, 12).Value <> "" Then
    rowMax = WorksheetFunction.Max(wsList.Range("L5:L1048576"))
    rowMax2 = rowMax + 5
    'End If
   
    '送信先の件数分繰り返す
        For i = 5 To rowMax2
        Set objMail = objOutlook.CreateItem(olMailItem)
            objMail.subject = wsMail.Range("B1").Value  'メール件名
            objMail.BodyFormat = olFormatPlain          'メールの形式
           
            '添付ファイルの有無の処理。セルにファイルのリンクが無い場合は、何もしない。
            If Not (wsList.Cells(i, 7).Value) = "" And Not (wsList.Cells(i, 8).Value) = "" And Not (wsList.Cells(i, 9).Value) = "" Then
            objMail.Attachments.Add wsList.Cells(i, 7).Value
            objMail.Attachments.Add wsList.Cells(i, 8).Value
            objMail.Attachments.Add wsList.Cells(i, 9).Value
            ElseIf wsList.Cells(i, 7).Value = "" And Not (wsList.Cells(i, 8).Value) = "" And Not (wsList.Cells(i, 9).Value) = "" Then
            objMail.Attachments.Add wsList.Cells(i, 8).Value
            objMail.Attachments.Add wsList.Cells(i, 9).Value
            ElseIf Not (wsList.Cells(i, 7).Value) = "" And wsList.Cells(i, 8).Value = "" And Not (wsList.Cells(i, 9).Value) = "" Then
            objMail.Attachments.Add wsList.Cells(1, 7).Value
            objMail.Attachments.Add wsList.Cells(i, 9).Value
            ElseIf Not (wsList.Cells(i, 7).Value) = "" And wsList.Cells(i, 8).Value = "" And wsList.Cells(i, 9).Value = "" Then
            objMail.Attachments.Add wsList.Cells(i, 7).Value
            ElseIf wsList.Cells(i, 7).Value = "" And Not (wsList.Cells(i, 8).Value) = "" And wsList.Cells(i, 9).Value = "" Then
            objMail.Attachments.Add wsList.Cells(i, 8).Value
            ElseIf wsList.Cells(i, 7).Value = "" And wsList.Cells(i, 8).Value = "" And Not (wsList.Cells(i, 9).Value) = "" Then
            objMail.Attachments.Add wsList.Cells(i, 9).Value
            End If
           
            '会社名・部署名・担当者名の有無の処理。担当者名が空白の場合は、”御中”、書いてある場合は”様”を付ける。
            'セルが空白の場合は、何もしない。
            If wsList.Cells(i, 1).Value = "" And Not (wsList.Cells(i, 2).Value = "") And Not (wsList.Cells(i, 3).Value = "") Then
            objMail.Body = wsList.Cells(i, 2).Value & " " & vbCrLf & _
                         wsList.Cells(i, 3).Value & "　様" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 2).Value = "" And Not (wsList.Cells(i, 1).Value = "") And Not (wsList.Cells(i, 3).Value = "") Then
            objMail.Body = wsList.Cells(i, 1).Value & " " & vbCrLf & _
                         wsList.Cells(i, 3).Value & "　様" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 3).Value = "" And Not (wsList.Cells(i, 2).Value = "") And Not (wsList.Cells(i, 1).Value = "") Then
            objMail.Body = wsList.Cells(i, 1).Value & " " & vbCrLf & _
                         wsList.Cells(i, 2).Value & "　御中" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 1).Value = "" And wsList.Cells(i, 2).Value = "" And Not (wsList.Cells(i, 3).Value = "") Then
            objMail.Body = wsList.Cells(i, 3).Value & "　様" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 1).Value = "" And wsList.Cells(i, 3).Value = "" And Not (wsList.Cells(i, 2).Value = "") Then
            objMail.Body = wsList.Cells(i, 2).Value & "　御中" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 2).Value = "" And wsList.Cells(i, 3).Value = "" And Not (wsList.Cells(i, 1).Value = "") Then
                        objMail.Body = wsList.Cells(i, 1).Value & "　御中" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 1).Value = "" And wsList.Cells(i, 2).Value = "" And wsList.Cells(i, 3).Value = "" Then
            objMail.Body = wsMail.Range("B2").Value 'メール本文
            ElseIf Not (wsList.Cells(i, 1).Value) = "" And Not (wsList.Cells(i, 2).Value) = "" And Not (wsList.Cells(i, 3).Value) = "" Then
            objMail.Body = wsList.Cells(i, 1).Value & vbCrLf _
                         & wsList.Cells(i, 2).Value & " " & vbCrLf _
                         & wsList.Cells(i, 3).Value & "　様" & vbCrLf & vbCrLf & vbCrLf _
                         & wsMail.Range("B2").Value 'メール本文
            End If
                                           
            '宛て先・cc・BCCの有無の処理。セルが空白の場合は、何もしない。
            If Not (wsList.Cells(i, 4).Value) = "" And Not (wsList.Cells(i, 5).Value) = "" And Not (wsList.Cells(i, 6).Value) = "" Then
            objMail.To = wsList.Cells(i, 4).Value
            objMail.cc = wsList.Cells(i, 5).Value
            objMail.BCC = wsList.Cells(i, 6).Value
            ElseIf wsList.Cells(i, 4).Value = "" And Not (wsList.Cells(i, 5).Value) = "" And Not (wsList.Cells(i, 6).Value) = "" Then
            objMail.cc = wsList.Cells(i, 5).Value
            objMail.BCC = wsList.Cells(i, 6).Value
            ElseIf Not (wsList.Cells(i, 4).Value) = "" And wsList.Cells(i, 5).Value = "" And Not (wsList.Cells(i, 6).Value) = "" Then
            objMail.To = wsList.Cells(i, 4).Value
            objMail.BCC = wsList.Cells(i, 6).Value
            ElseIf Not (wsList.Cells(i, 4).Value) = "" And Not (wsList.Cells(i, 5).Value) = "" And wsList.Cells(i, 6).Value = "" Then
            objMail.To = wsList.Cells(i, 4).Value
            objMail.cc = wsList.Cells(i, 5).Value
            ElseIf Not (wsList.Cells(i, 4).Value) = "" And wsList.Cells(i, 5).Value = "" And wsList.Cells(i, 6).Value = "" Then
            objMail.To = wsList.Cells(i, 4).Value
            ElseIf wsList.Cells(i, 4).Value = "" And Not (wsList.Cells(i, 5).Value) = "" And wsList.Cells(i, 6).Value = "" Then
            objMail.cc = wsList.Cells(i, 5).Value
            ElseIf wsList.Cells(i, 4).Value = "" And wsList.Cells(i, 5).Value = "" And Not (wsList.Cells(i, 6).Value) = "" Then
            objMail.BCC = wsList.Cells(i, 6).Value
            ElseIf wsList.Cells(i, 4).Value = "" And wsList.Cells(i, 5).Value = "" And wsList.Cells(i, 6).Value = "" Then
            objMail.To = wsList.Cells("").Value
            objMail.cc = wsList.Cells("").Value
            objMail.BCC = wsList.Cells("").Value
            End If
           
            objMail.Save '下書き保存
           
    Next i
 
    Set objOutlook = Nothing
    MsgBox "下書き保存しました。メールの内容を確認の上、送信してください。"
 
End Sub

しかし、実行すると、Outlookにメールは必要数保存されるのですが、「プロシージャの呼び出しまたは引数が無効です (エラー 5)」というエラーがでてプログラムが終了しません。

お手数をおかけしますが、エラーの原因及び対処につきまして、ご教授のほど、よろしくお願いします。

Answer 1

Outlook.Application の起動と破棄にもコストがかかるので、入力チェックを終えてから New するべきかと。
(objOutlook.Quit していないのも気になりますが、これは自動的に解放されるかな…?)

エラーの原因及び対処につきまして、ご教授のほど、よろしくお願いします。

どの行を実行する際にエラーになっているかは、特定できていますか?

ひとまず、「メールは必要数保存される」とのことから、『objMain.Save』は必要回数分呼び出されているものと推察しますが、最後にある『MsgBox "下書き保存しました。メールの内容を確認の上、送信してください。"』の行まで実行できているかどうかを教えてください。

もし、最後のメッセージまで出力されているのに実行時エラー 5 となる場合には、今月の Windows Update の障害に該当しているかもしれませんので、合わせてご確認ください。（修正プログラムも随時リリースされているようです）

Answer 2

下記の行に不具合があるようです。

            ElseIf wsList.Cells(i, 4).Value = "" And wsList.Cells(i, 5).Value = "" And wsList.Cells(i, 6).Value = "" Then
            objMail.To = wsList.Cells("").Value
            objMail.cc = wsList.Cells("").Value
            objMail.BCC = wsList.Cells("").Value
            End If

[送信先]シートの D、E、F 列のすべてが空欄の行があった場合、wsList.Cell("") によって、実行時エラー 5 が引き起こされるものと推察します。

Outlookにメールは必要数保存されるのですが、

保存されたメールが、本当に必要数に達しているかどうか（件数が不足していないかどうか）も確認してみてください。

Answer 3

魔界の仮面弁士　様、皆様

お忙しいところ引き続き回答していただき、ありがとうございます

魔界の仮面弁士　様からのアドバイスに基づいて下記のとおりプログラムを書き換えました。

無事、必要数のメールを添付ファイル付きで保存する、といった目的を達成することができました。

この場をお借りして、厚く御礼申し上げます。

Option Explicit
Sub SendEmail()
 
Dim objOutlook As Outlook.Application
Dim i As Long
Dim rowMax As Long
Dim rowMax2 As Long
Dim wsList As Worksheet
Dim wsMail As Worksheet
Dim objMail As Outlook.MailItem
Dim rng As Range
Dim rc As Integer

Set objOutlook = New Outlook.Application
Set wsList = ThisWorkbook.Sheets("送信先")
Set wsMail = ThisWorkbook.Sheets("メール内容")
Set rng = wsList.Range("A5:I1048576")

rc = MsgBox("メールの作成を開始しますか？", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
    MsgBox "作成を中止します。"
    End
    End If

    '送信先（会社名等、メールアドレス）が何も書いてない場合、処理を終了
    If Application.CountBlank(rng) = rng.Cells.Count Then
    MsgBox "送信先（会社名等、メールアドレス）が何も書いてありません。入力してください。"
    End
    End If
   
    '件名が何も書いてない場合、処理を終了
    If wsMail.Range("B1").Value = "" Then
    MsgBox "件名が空白です。入力してください。"
    End
    End If
   
    'メール本文が何も書いてない場合、処理を終了
    If wsMail.Range("B2").Value = "" Then
    MsgBox "メール本文が空白です。入力してください。"
    End
    End If
   
    '送信先の件数
    rowMax = WorksheetFunction.Max(wsList.Range("L5:L1048576"))
    rowMax2 = rowMax + 4
   
    '送信先の件数分繰り返す
        For i = 5 To rowMax2
        Set objMail = objOutlook.CreateItem(olMailItem)
            objMail.subject = wsMail.Range("B1").Value  'メール件名
            objMail.BodyFormat = olFormatPlain          'メールの形式
           
            '添付ファイルの有無の処理。セルにファイルのリンクが無い場合は、何もしない。
            If Not (wsList.Cells(i, 7).Value) = "" And Not (wsList.Cells(i, 8).Value) = "" And Not (wsList.Cells(i, 9).Value) = "" Then
            objMail.Attachments.Add wsList.Cells(i, 7).Value
            objMail.Attachments.Add wsList.Cells(i, 8).Value
            objMail.Attachments.Add wsList.Cells(i, 9).Value
            ElseIf Not (wsList.Cells(i, 7).Value) = "" And Not (wsList.Cells(i, 8).Value) = "" And wsList.Cells(i, 9).Value = "" Then
            objMail.Attachments.Add wsList.Cells(i, 7).Value
            objMail.Attachments.Add wsList.Cells(i, 8).Value
            ElseIf wsList.Cells(i, 7).Value = "" And Not (wsList.Cells(i, 8).Value) = "" And Not (wsList.Cells(i, 9).Value) = "" Then
            objMail.Attachments.Add wsList.Cells(i, 8).Value
            objMail.Attachments.Add wsList.Cells(i, 9).Value
            ElseIf Not (wsList.Cells(i, 7).Value) = "" And wsList.Cells(i, 8).Value = "" And Not (wsList.Cells(i, 9).Value) = "" Then
            objMail.Attachments.Add wsList.Cells(i, 7).Value
            objMail.Attachments.Add wsList.Cells(i, 9).Value
            ElseIf Not (wsList.Cells(i, 7).Value) = "" And wsList.Cells(i, 8).Value = "" And wsList.Cells(i, 9).Value = "" Then
            objMail.Attachments.Add wsList.Cells(i, 7).Value
            ElseIf wsList.Cells(i, 7).Value = "" And Not (wsList.Cells(i, 8).Value) = "" And wsList.Cells(i, 9).Value = "" Then
            objMail.Attachments.Add wsList.Cells(i, 8).Value
            ElseIf wsList.Cells(i, 7).Value = "" And wsList.Cells(i, 8).Value = "" And Not (wsList.Cells(i, 9).Value) = "" Then
            objMail.Attachments.Add wsList.Cells(i, 9).Value
            End If
           
            '会社名・部署名・担当者名の有無の処理。担当者名が空白の場合は、”御中”、書いてある場合は”様”を付ける。
            'セルが空白の場合は、何もしない。
            If wsList.Cells(i, 1).Value = "" And Not (wsList.Cells(i, 2).Value = "") And Not (wsList.Cells(i, 3).Value = "") Then
            objMail.Body = wsList.Cells(i, 2).Value & " " & vbCrLf & _
                         wsList.Cells(i, 3).Value & "　様" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 2).Value = "" And Not (wsList.Cells(i, 1).Value = "") And Not (wsList.Cells(i, 3).Value = "") Then
            objMail.Body = wsList.Cells(i, 1).Value & " " & vbCrLf & _
                         wsList.Cells(i, 3).Value & "　様" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 3).Value = "" And Not (wsList.Cells(i, 2).Value = "") And Not (wsList.Cells(i, 1).Value = "") Then
            objMail.Body = wsList.Cells(i, 1).Value & " " & vbCrLf & _
                         wsList.Cells(i, 2).Value & "　御中" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 1).Value = "" And wsList.Cells(i, 2).Value = "" And Not (wsList.Cells(i, 3).Value = "") Then
            objMail.Body = wsList.Cells(i, 3).Value & "　様" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 1).Value = "" And wsList.Cells(i, 3).Value = "" And Not (wsList.Cells(i, 2).Value = "") Then
            objMail.Body = wsList.Cells(i, 2).Value & "　御中" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 2).Value = "" And wsList.Cells(i, 3).Value = "" And Not (wsList.Cells(i, 1).Value = "") Then
                        objMail.Body = wsList.Cells(i, 1).Value & "　御中" & vbCrLf & vbCrLf & vbCrLf & _
                         wsMail.Range("B2").Value  'メール本文
            ElseIf wsList.Cells(i, 1).Value = "" And wsList.Cells(i, 2).Value = "" And wsList.Cells(i, 3).Value = "" Then
            objMail.Body = wsMail.Range("B2").Value 'メール本文
            ElseIf Not (wsList.Cells(i, 1).Value) = "" And Not (wsList.Cells(i, 2).Value) = "" And Not (wsList.Cells(i, 3).Value) = "" Then
            objMail.Body = wsList.Cells(i, 1).Value & vbCrLf _
                         & wsList.Cells(i, 2).Value & " " & vbCrLf _
                         & wsList.Cells(i, 3).Value & "　様" & vbCrLf & vbCrLf & vbCrLf _
                         & wsMail.Range("B2").Value 'メール本文
            End If
                                           
            '宛て先・cc・BCCの有無の処理。セルが空白の場合は、何もしない。
            If Not (wsList.Cells(i, 4).Value) = "" And Not (wsList.Cells(i, 5).Value) = "" And Not (wsList.Cells(i, 6).Value) = "" Then
            objMail.To = wsList.Cells(i, 4).Value
            objMail.cc = wsList.Cells(i, 5).Value
            objMail.BCC = wsList.Cells(i, 6).Value
            ElseIf wsList.Cells(i, 4).Value = "" And Not (wsList.Cells(i, 5).Value) = "" And Not (wsList.Cells(i, 6).Value) = "" Then
            objMail.cc = wsList.Cells(i, 5).Value
            objMail.BCC = wsList.Cells(i, 6).Value
            ElseIf Not (wsList.Cells(i, 4).Value) = "" And wsList.Cells(i, 5).Value = "" And Not (wsList.Cells(i, 6).Value) = "" Then
            objMail.To = wsList.Cells(i, 4).Value
            objMail.BCC = wsList.Cells(i, 6).Value
            ElseIf Not (wsList.Cells(i, 4).Value) = "" And Not (wsList.Cells(i, 5).Value) = "" And wsList.Cells(i, 6).Value = "" Then
            objMail.To = wsList.Cells(i, 4).Value
            objMail.cc = wsList.Cells(i, 5).Value
            ElseIf Not (wsList.Cells(i, 4).Value) = "" And wsList.Cells(i, 5).Value = "" And wsList.Cells(i, 6).Value = "" Then
            objMail.To = wsList.Cells(i, 4).Value
            ElseIf wsList.Cells(i, 4).Value = "" And Not (wsList.Cells(i, 5).Value) = "" And wsList.Cells(i, 6).Value = "" Then
            objMail.cc = wsList.Cells(i, 5).Value
            ElseIf wsList.Cells(i, 4).Value = "" And wsList.Cells(i, 5).Value = "" And Not (wsList.Cells(i, 6).Value) = "" Then
            objMail.BCC = wsList.Cells(i, 6).Value
            ElseIf wsList.Cells(i, 4).Value = "" And wsList.Cells(i, 5).Value = "" And wsList.Cells(i, 6).Value = "" Then
            objMail.To = ""
            objMail.cc = ""
            objMail.BCC = ""
            End If
           
            objMail.Save '下書き保存
           
    Next i
 
    Set objOutlook = Nothing
    MsgBox "下書き保存しました。メールの内容を確認の上、送信してください。"
 
End Sub