如何防止没有附件的电子邮件发送

Question

如果找不到电子邮件地址，我输入

On Error Resume Next

继续。

现在，如果找不到附件，它将发送。
我需要它才能在没有附件的情况下发送。

Sub CreateStatement()

Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")

Dim EItem As Object

'Dim EApp As Outlook.Application
'Set EApp = New Outlook.Application

'Dim EItem As Outlook.MailItem
'Set EItem = EApp.CreateItem(olMailItem)
Dim path As String
path = "K:\E-Fax Invoicing\PDF Output\"

Dim RList As Range
Set RList = Range("A2", Range("a2").End(xlDown))

Dim R As Range

For Each R In RList

    Set EItem = EApp.CreateItem(0)

    With EItem
        On Error Resume Next
        .SentOnBehalfOfName = ""
        .To = R.Offset(0, 2)
        .Subject = "December Statement: "
        .Attachments.Add (path & R.Offset(0, 3))
        .Body = "Dear " & R & vbNewLine & vbNewLine _
        & "Please find your " & R.Offset(0, 4) & " attached." 
        On Error GoTo 0
        If .Attachments.Count > 0 Then
            .send
        Else
            next
        End If
    End With

Next R

Set EApp = Nothing
Set EItem = Nothing

End Sub

Answer 1

您可以在尝试将其添加为附件之前检查该文件是否存在：

Sub CreateStatement()
    Const PATH = "K:\E-Fax Invoicing\PDF Output\" 'use const for fixed values
    
    Dim EApp As Object, EItem As Object, RList As Range, R As Range
    Set EApp = CreateObject("Outlook.Application")
    
    Set RList = Range("A2", Range("a2").End(xlDown))
    
    For Each R In RList.Cells
    
        f = Dir(PATH & R.Offset(0, 3).Value) 'any matching file?
        
        Set EItem = EApp.CreateItem(0)
        With EItem
            .SentOnBehalfOfName = ""
            .To = R.Offset(0, 2)
            .Subject = "December Statement:"
            .Body = "Dear " & R.Value & vbNewLine & vbNewLine _
              & "Please find your " & R.Offset(0, 4).Value & " attached."
            
            If Len(f) > 0 Then
                .Attachments.Add PATH & f
                .send
            Else
                .display
            End If
        End With
    Next R
End Sub