Question

我在Excel中有代码，可以将电子邮件发送给收件人列表：

Sub SendEMail()
    Dim xEmail As String
    Dim xSubj As String
    Dim xMsg As String
    Dim xURL As String
    Dim i As Integer
    Dim k As Double
    Dim xCell As Range
    Dim xRg As Range
    Dim xTxt As String
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select the data range:", "Send emails to:", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    If xRg.Columns.Count <> 3 Then
        MsgBox "Incorrect number of columns: You have to choose Name, Email address, Account no.!"
        Exit Sub
    End If
    For i = 1 To xRg.Rows.Count
    '   Get the email address
        xEmail = xRg.Cells(i, 2)
    '   Message subject
        xSubj = "Your customer's account is on hold"
    '   Compose the message
        xMsg = ""
        xMsg = xMsg & "Dear client" & "," & vbCrLf & vbCrLf
        xMsg = xMsg & "We would like to inform you, that Your account has been put on hold - "
        xMsg = xMsg & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
        xMsg = xMsg & "If you have any queries, please contact us on uk.ar@bodycote.com." & vbCrLf & vbCrLf
        xMsg = xMsg & "Kind regards," & vbCrLf
        xMsg = xMsg & "Jon and Martina"
    '   Replace spaces with %20 (hex)
        xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
        xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
    '   Replace carriage returns with %0D%0A (hex)
        xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
    '   Create the URL
        xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
    '   Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
    '   Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
    Next
End Sub

我想添加变量附件。它将是一个pdf文件，其名称将与客户名称（位于A列中）相同。基本上它应该寻找＆＃34; Name.pdf＆＃34;在＆＃34; S：\所有Team \ AX OTI \ test \＆＃34;

源表格如下：

Answer 1

这里有一些非常好用的东西 - Add attachement to outlook with varying file names

在您的情况下，只需复制代码并确保在strLocation部分中写下如下内容：

strLocation = "C:\Users\user\Desktop\" & Cells(i,2) & ".pdf"

因此，你将能够循环它。一般来说，仔细看看上面提到的答案，这真的是一个很好的方法（恕我直言，比发送密钥好）。

Answer 2

请尝试使用以下代码。

        xMsg = xMsg & "Dear client" & xRg.Cells(i, 1)  & "," & vbCrLf & vbCrLf 'Added the client Name (optional) you can remove it
        xMsg = xMsg & "We would like to inform you, that Your account has been put on hold - "
        xMsg = xMsg & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
        xMsg = xMsg & "If you have any queries, please contact us on uk.ar@bodycote.com." & vbCrLf & vbCrLf
        xMsg = xMsg & "Kind regards," & vbCrLf

        xMsg = xMsg & "Jon and Martina" & vbCrLf & vbCrLf 'Added two break point

        '       Replace spaces with %20 (hex)
        xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
        xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
'       Replace carriage returns with %0D%0A (hex)
        xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
'       Create the URL
        xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg &"&attachment=S:\All Team\AX OTI\test\" & Cells(i,1) & ".pdf" 'Changed to this
'       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
'       Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"

Answer 3

根据@Vityata的建议，我检查了the question并在此基础上更改了代码。 经过测试并且运行顺畅。代码更容易，但工作已经完成。

Sub SendEmail()

Dim Mail_Object, OutApp As Variant


 With ActiveSheet
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row 'list of recipients (email address) - it takes as many addresses as B column contains
    End With

For i = 2 To lastrow

Set Mail_Object = CreateObject("Outlook.Application")
Set OutApp = Mail_Object.CreateItem(0)

    With OutApp
    .Subject = "Your customer's account is on hold"
    .Body = "Dear client" & "," & vbCrLf & vbCrLf & "We would like to inform you, that Your account has been put on hold." & vbCrLf & vbCrLf & "If you have any queries, please contact us on uk.ar@bodycote.com." & vbCrLf & vbCrLf & "Kind regards," & vbCrLf & "Jon and Martina"
    .To = Cells(i, 2).Value
     strLocation = "S:\All team\AX OTI\test\" & Cells(i, 1) & ".pdf"
    .Attachments.Add (strLocation)
    .display
    '.send
    End With

Next i

debugs:
If Err.Description <> "" Then MsgBox Err.Description

End Sub

包含名称与收件人姓名匹配的附件

3 个答案: