Include attachment where the name matches recipient name - vba

Question

I have code in Excel which sends email to a list of recipients:
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
I would like to add variable attachments. It will be a pdf file and its name will be the same as the name of customer (which is placed in column A). Basically it should look for "Name.pdf" in "S:\All Team\AX OTI\test\"
The source table looks like:

Answer 1

Please try to use the below code.
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 2

Based on #Vityata advice, I've checked the question and based on that, I' ve changed the code. It is tested and works smoothly. The code is much easier, but the job is done.
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

Answer 3

Here you have something that works really nicely - Add attachement to outlook with varying file names
In your case, simply copy the code and make sure that in the part strLocation you write something like:
strLocation = "C:\Users\user\Desktop\" & Cells(i,2) & ".pdf"
thus, you will be able to loop around it. In general, take a good look at the mentioned answer, it is really a good approach (IMHO quite better than sending keys).