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

  • 質問

  • 先般、質問しました、

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

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

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

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

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

    (4)送信先の1つ右の列に、番号を付与する。

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

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

    である。

    (6)上記(5)の隣に、下記の数式を組み込み、その列の最大値を記入されている行数とする。

    =IF(NOT((5)の結果=""),COUNTIF($(5)の列$(5)の一番上のセル:$(5)の右隣のセル,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)」というエラーがでてプログラムが終了しません。

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

    2019年8月19日 5:42

すべての返信

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

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

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

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

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

    2019年8月19日 8:32
  • 下記の行に不具合があるようです。

                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にメールは必要数保存されるのですが、

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

    • 回答の候補に設定 minmin312 2019年8月21日 7:10
    2019年8月19日 8:50
  • 魔界の仮面弁士 様、皆様


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

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

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

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

    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

    2019年8月21日 4:13