[[20210908145444]]　『Outlookメールを複数個別作成し添付有りと無しを�x（ebi）　ページの最後に飛ぶ

『Outlookメールを複数個別作成し添付有りと無しを一斉送信について』（ebi）

初めまして。VBA初心者です。
表題の通り、Outlookメールを複数個別作成し添付有りと無しを一斉送信したく、調べながら作成しているのですが、ファイル添付部分でつまづいてしまい、ご教授のほど宜しくお願い致します。

エクセルと同じフォルダーに「*.pdf」が複数あり、エクセルの「mail_list」シートの8列目の行毎に「001.pdf」「002.pdf」・・・とファイル名が記載されてあります。
添付が必要ないメールもあるため、そのセルは空白となっています。

空白無しでセルにファイル名が全て入っていると正常に作成されるのですが、途中に空白があると空白より前の行のみ作成されて、空白行で「実行時エラー'-2147024894 (80070002)': オートメーションエラーです。指定されたファイルが見つかりません。」と出てしまい、以降のセル分が作成されないのが現状です。

「If attachedfile <> "" Then」で空欄でなければ添付されると思ったのですがうまくいかず、お力添えをお願いいたします。

Option Explicit

Private Sub btnSend_Click()

  Dim myOutLook As Object
  Dim myMail As Object
  Dim myRECIPI As Object
  Dim Namespace As Object
  Dim oApp As Object
  Dim myNameSpace As Object
  Dim myFolder As Object
  Dim to_name, to_Address, to_flag, mailto, from_name As String
  Dim Attachments As String
  Dim attachedfile As String
  Dim end_row, i As Integer

 'outlook 起動
  Set oApp = CreateObject("Outlook.Application")

  Set myNameSpace = oApp.GetNamespace("MAPI")
  Set myFolder = myNameSpace.GetDefaultFolder(6)
  myFolder.Display

  Worksheets("mail_list").Select
  end_row = Cells(Rows.Count, "B").End(xlUp).Row

  For i = 3 To end_row '3行目からend記載行まで
    Set myOutLook = CreateObject("Outlook.Application")
    Set myMail = myOutLook.CreateItem(0)

   'メール内容入力
    Worksheets("mail_template").Select
    myMail.Body = ActiveSheet.Cells(3, 3)

    Worksheets("mail_list").Select
    to_name = ActiveSheet.Cells(i, 2)
    to_Address = ActiveSheet.Cells(i, 3)
    to_flag = ActiveSheet.Cells(i, 4)
    from_name = ActiveSheet.Cells(i, 5)
    myMail.subject = ActiveSheet.Cells(i, 6)

    If to_Address = "" Then Exit For
    If to_flag = "" Then
      Set myRECIPI = myMail.Recipients.Add(to_Address)
      myMail.Body = Replace(myMail.Body, "{0}", to_name)
      myMail.Body = Replace(myMail.Body, "{1}", from_name)
    End If

   'ファイル添付
    attachedfile = ThisWorkbook.Path & "\" & ActiveSheet.Cells(i, 8)

    If attachedfile <> "" Then              '空欄でなければ
      myMail.Attachments.Add attachedfile   'このセルに記載のファイル名を添付する
    End If

    myMail.Display 'メールの表示
    'myMail.Send 'メールの送信

    Set myOutLook = Nothing
    Set myMail = Nothing
    Set myRECIPI = Nothing
  Next
End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

テストしてないですが、多分こうじゃないですか？

    Sub 整理()
        Dim myMail As Object
        Dim i As Long

        With Worksheets("mail_list")
            For i = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
                Set myMail = CreateObject("Outlook.Application").CreateItem(0)

                myMail.Body = Worksheets("mail_template").Range("C3").Value
                myMail.Subject = .Cells(i, 6).Value

                If .Cells(i, 3).Value = "" Then Exit For
                If .Cells(i, 4) = "" Then
                    myMail.To = .Cells(i, 3).Value

                    myMail.Body = Replace(myMail.Body, "{0}", .Cells(i, 2).Value)
                    myMail.Body = Replace(myMail.Body, "{1}", .Cells(i, 5).Value)
                End If

                 'attachedfile = ThisWorkbook.Path & "\" & ActiveSheet.Cells(i, 8)
                 '↑だと「ActiveSheet.Cells(i, 8)」が""でも、「ThisWorkbook.Path」が格納されちゃうから「attachedfile」が""にならない

                If .Cells(i, 8).Value <> "" Then myMail.Attachments.Add ThisWorkbook.Path & "\" & .Cells(i, 8).Value

                myMail.Display 'メールの表示
            Next i
        End With
    End Sub

元のコードをステップ実行して「attachedfile」に何が格納されているかチェックしてみてもいいかもですね。

（もこな２） 2021/09/08(水) 18:29

失礼。見直したら処理順がちょっと変でした。

    Sub 整理_修正()
        Dim myMail As Object
        Dim i As Long

        With Worksheets("mail_list")
            For i = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
                If .Cells(i, 3).Value = "" Then
                    Exit For '抜けるなら「myMail」をセットする必要ないですよね。
                Else
                    Set myMail = CreateObject("Outlook.Application").CreateItem(0)
                End If

                myMail.Body = Worksheets("mail_template").Range("C3").Value
                myMail.Subject = .Cells(i, 6).Value

                If .Cells(i, 4).Value = "" Then
                    myMail.To = .Cells(i, 3).Value

                    myMail.Body = Replace(myMail.Body, "{0}", .Cells(i, 2).Value)
                    myMail.Body = Replace(myMail.Body, "{1}", .Cells(i, 5).Value)
                End If

                 'attachedfile = ThisWorkbook.Path & "\" & ActiveSheet.Cells(i, 8)
                 '↑だと「ActiveSheet.Cells(i, 8)」が""でも、「ThisWorkbook.Path」が格納されちゃうから「attachedfile」が""にならない

                If .Cells(i, 8).Value <> "" Then myMail.Attachments.Add ThisWorkbook.Path & "\" & .Cells(i, 8).Value

                myMail.Display 'メールの表示
            Next i
        End With
    End Sub

（もこな２） 2021/09/08(水) 18:35

もこな２さん

ご回答ありがとうございます。
試してみたところ、正常に動きました。ありがとうございます。
初心者の為つたないところが多くご迷惑をおかけしました。

お力添えありがとうございました。
（ebi） 2021/09/10(金) 09:02

コメント返信：

[ 一覧(最新更新順) ]

[[20210908145444]] 『Outlookメールを複数個別作成し添付有りと無しを�x（ebi） ページの最後に飛ぶ

[[20210908145444]]　『Outlookメールを複数個別作成し添付有りと無しを�x（ebi）　ページの最後に飛ぶ