仅通过VBA代码发送那些带有附件的电子邮件 [英] Send only those emails that have attachments by way of a VBA code

问题描述

我刚刚开始处理宏，到目前为止，已经取得了相当不错的进步.

I've just started working on macros and have made a pretty decent progress so far.

但是，我被困在一个地方，找不到答案.

However, I'm stuck in a place and can't find an answer to it.

我正在使用宏通过Outlook向特定的收件人发送电子邮件.我要发送多个excel&每封电子邮件中的pdf附件.

I'm using a macro to send emails to specific recipients via outlook. I'm sending multiple excel & pdf attachments in each email.

该代码非常棒！尽管如此，我仍然需要添加一个条件，其中不会发送没有任何EXCEL附件的电子邮件，并且针对此特定情况的Outlook创建邮件项目只会自动关闭.

The code works fantastic! I, nonetheless, need to add a condition wherein an email that doesn't have any EXCEL attachments isn't sent and the outlook create mail item for this specific case only closes automatically.

对于具有excel附件的其他客户端，宏的其余部分应继续.

The rest of the macro should continue for other clients with the excel attachments.

希望有人可以帮助我.以下是我当前正在使用的代码.

Hoping for someone to help me on this. Following is the code that I'm currently using.

Sub SendEmailWithReview_R()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim X As Long

    Lastrow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row

    For X = 10 To Lastrow
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(olmailitem)

        With OutMail
            .To = Cells(X, 4)
            .CC = Cells(X, 6)
            .Subject = Cells(X, 8)
            .Body = Cells(1, 8)

            strlocation = "C:\Users\HKhan\Desktop\Final Macro\" & Cells(X, 1) & "-OICR.xlsx"
            On Error Resume Next
            .Attachments.Add (strlocation)
            On Error Resume Next
            strlocation = "C:\Users\HKhan\Desktop\Final Macro\" & Cells(X, 1) & "-OICLR.xlsx"
            On Error Resume Next
            .Attachments.Add (strlocation)
            On Error Resume Next
            strlocation = "C:\Users\HKhan\Desktop\Final Macro\" & "OIC - Bank Details" & ".pdf"
            On Error Resume Next
            .Attachments.Add (strlocation)
            On Error Resume Next
            strlocation = "C:\Users\HKhan\Desktop\Final Macro\" & "OICL - Bank Details" & ".pdf"
            On Error Resume Next
            .Attachments.Add (strlocation)
            On Error Resume Next
            .Display
            'send
        End With  
    Next X
End Sub

推荐答案

要添加条件以检查OutMail是否具有Excel附件，只需替换以下内容

To add condition to check if OutMail has Excel attachment, simply replace the following

       .Display
        'send

使用这些代码

Dim Atmt As Object
For Each Atmt In OutMail.Attachments

    Dim sFileType As String
    sFileType = LCase$(Right$(Atmt.fileName, 4)) ' Last 4 Char in Filename
    Debug.Print Atmt.fileName

    Select Case sFileType
        Case ".xls", "xlsx"

         .Display
        '.send

    End Select
Next

这篇关于仅通过VBA代码发送那些带有附件的电子邮件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！