Skip to main content
Support is Offline
Today is our off day. We are taking some rest and will come back stronger tomorrow
Official support hours
Monday To Friday
From 09:00 To 17:30
  Monday, 07 May 2018
  0 Replies
  2.5K Visits
0
Votes
Undo
Hello,
I'm using your VBA code : Send personalized mass emails to a list from Excel but I've 2 extra questions for a codechange:
- How can I add the standard signature in the mail?
- How can i add a fixed attachement present in a folder?

Can someone help me changing the code?
Thanks a lot
Regards
Bart

#If VBA7 And Win64 Then
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As LongPtr, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As LongPtr
#Else
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
#End If
Sub SendEMail()
'update by Extendoffice 20160506
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:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 3 Then
MsgBox " Regional format error, please check", , "Kutools for Excel"
Exit Sub
End If
For i = 1 To xRg.Rows.Count
' Get the email address
xEmail = xRg.Cells(i, 2)
' Message subject
xSubj = "Your Registration Code"
' Compose the message
xMsg = ""
xMsg = xMsg & "Dear " & xRg.Cells(i, 1) & "," & vbCrLf & vbCrLf
xMsg = xMsg & " This is your Registration Code "
xMsg = xMsg & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & " please try it, and glad to get your feedback! " & vbCrLf
xMsg = xMsg & "Skyyang"
' 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
There are no replies made for this post yet.