How to add signature to multiple emails? - excel

I contact several colleagues across different departments and due to compliance the default email signature is to be used on all emails.
I managed to produce a blanket email, using Excel VBA, that has the same body across all emails with changes based on the staff's location and criteria.
My signature is not populated.
Sub send_mass_email()
Dim i As Integer
Dim Greeting, email, body, subject, business, Website As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
Do While Cells(i, 1).Value <> ""
Greeting = Cells(i, 2).Value
email = Cells(i, 3).Value
body = ActiveSheet.TextBoxes("TextBox 1").Text
subject = Cells(i, 4).Value
business = Cells(i, 1).Value
Website = Cells(i, 5).Value
' replace place holders
body = Replace(body, "B2", Greeting)
body = Replace(body, "A2", business)
body = Replace(body, "E2", Website)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.subject = subject
.body = body & Signature
'.Attachments.Add ("") 'You can add files here
.display
'.Send
End With
'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Sent!"
End Sub

Call the Display method before making any body-related modifications to generate/add the default signature in the message body:
With OutMail
.display
.to = email
.subject = subject
'.body = body & Signature
'.Attachments.Add ("") 'You can add files here
'.Send
End With

Related

How to add keep text with a HTML signature

Seems that i can't add the text while adding the signature in the same code. Below you may see it:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.body = body
.HTMLbody = sig
That HTMLbody is deleting the body that i have 1 row up in the formula.
I have tryed to modify as i saw in other examples here, but nothing seems to work.Bellow you can see also the whole project.
Can you check and let me know were i have faild?
Sub send_mass_email()
Dim i As Integer
Dim name, email, body, subject, copy, place, business As String
Dim OutApp As Object
Dim OutMail As Object
Dim fsFile As Object
Dim fso As Object
Dim fsFolder As Object
Dim strFolder As String
Dim sig As String
sig = ReadSignature("adi.htm")
HTMLbody = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
'Loop down name column starting at row 2 column 1
Do While Cells(i, 1).Value <> ""
name = Split(Cells(i, 1).Value, " ")(0) 'extract first name
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
business = Cells(i, 5).Value
answ = MsgBox("what it need to be attach " & Cells(i, 1) & " ?", vbYesNo + vbExclamation, "PSK Check")
If answ <> vbYes Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.HTMLbody = body
.HTMLbody = sig
.display
End With
End If
If answ = vbYes Then
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
If xFileDlg.Show = -1 Then
'replace place holders
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.HTMLbody = body & sig
.display
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
'.Send
End With
End If
'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text
End If
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try replacing these two lines...
.HTMLbody = body
.HTMLbody = sig
with
.HTMLbody = body & sig
By the way, if you want a line break between the body and signature, try the following instead...
.HTMLbody = body & "<br>" & sig

Loop a specfic range

can anyone explain to me the proper way to loop a certain range? I do not understand this part on how to make this work please? How do I do this only from row 2 to 4? It has a compile error, loop without for, any idea how to amend this please
Sub send_mass_email_display_only()
Dim i As Integer
Dim name As String, email As String, body As String, subject As String, copy As String, pdfadd As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
For i = 2 To 4
'Loop down name column starting at row 2 column 1
Do While Cells(i, 1).Value <> ""
name = Split(Cells(i, 1).Value, " ")(0)
'name = Cells(i, 1).Value
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
pdfadd = Cells(i, 5).Value
body = Replace(body, "C1", name)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = email
.cc = copy
.subject = subject
.body = body
.Attachments.Add (pdfadd)
.display
'.Send
End With
body = ActiveSheet.TextBoxes("TextBox 1").Text 'reset body text
Next i
Set OutMail = Nothing
Set OutApp = Nothing
'MsgBox "Email(s) Sent!"
End Sub
I tried as FaneDuru/grayProgrammerz suggested to delete the Do While line... seems that this works so far
Option Explicit
Sub send_mass_email_display_only()
Dim i As Integer
Dim name As String, email As String, body As String, subject As String, copy As String, pdfadd As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
For i = 2 To 4
'Specific rows
name = Split(Cells(i, 1).Value, " ")(0)
'name = Cells(i, 1).Value
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
pdfadd = Cells(i, 5).Value
body = Replace(body, "C1", name)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = email
.cc = copy
.subject = subject
.body = body
.Attachments.Add (pdfadd)
.display
'.Send
End With
body = ActiveSheet.TextBoxes("TextBox 1").Text 'reset body text
Next i
Set OutMail = Nothing
Set OutApp = Nothing
'MsgBox "Email(s) Sent!"
End Sub

Produce an individually created email based on columns of information in a file

This file pulls in the different pieces of information
.
The textbox in the code shows what the email will look like before the code runs.
When I try to send the email, the error is
"Loop without Do"
As well how do I allow for multiple addresses per email (Email1,email2,email3). Currently the code only pulls in Email1.
Sub send_mass_email()
Dim i As Integer
Dim name, Email, Email2, Email3, GMEmail, body, subject, MTDRev, LMRev, SYSRevGrowth, MTDNMU, LMNMU, NMUChange, MTDLeads, LMLeads, LeadsChange, OSAvg, AvgNMU, AvgActivityMTD As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
Do While Cells(i, 1).Value <> ""
name = Range("B2").Value
Email = Range("C2").Value
Email2 = Range("D2").Value
Email3 = Range("E2").Value
GMEmail = Range("F2").Value
body = ActiveSheet.TextBoxes("TextBox 1").Text
subject = Range("G2").Value
MTDRev = Range("H2").Value
LMRev = Range("I2").Value
SYSRevGrowth = Range("J2").Value
MTDNMU = Range("K2").Value
LMNMU = Range("L2").Value
NMUChange = Range("M2").Value
MTDLeads = Range("N2").Value
LMLeads = Range("O2").Value
LeadsChange = Range("P2").Value
OSAvg = Range("Q2").Value
AvgNMU = Range("R2").Value
AvgActivityMTD = Range("S2").Value
body = Replace(body, "B2", name) & "font.color=red"
body = Replace(body, "H2", MTDRev)
body = Replace(body, "I2", LMRev)
body = Replace(body, "J2", SYSRevGrowth)
body = Replace(body, "K2", MTDNMU)
body = Replace(body, "L2", LMNMU)
body = Replace(body, "M2", NMUChange)
body = Replace(body, "N2", MTDLeads)
body = Replace(body, "O2", LMLeads)
body = Replace(body, "P2", LeadsChange)
body = Replace(body, "Q2", OSAvg)
body = Replace(body, "R2", AvgNMU)
body = Replace(body, "S2", AvgActivityMTD)
body = Replace(body, "X2", Title)
body = Replace(body, "Y2", Date)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = Email
.to = Email2
.to = Email3
.to = GMEmail
.subject = subject
.body = body
'.Attachments.Add ("") 'You can add files here
.Display
'.Send
body = ActiveSheet.TextBoxes("TextBox 1").Text 'reset body text
i = i + 1
Loop
End If
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Sent!"
End Sub
Untested but this should get you closer:
Sub send_mass_email()
Dim i As Integer, ws As Worksheet, col, c As Range
Dim OutApp As Object, body As String, sTo As String
Dim OutMail As Object
Set ws = ActiveSheet
i = 2
Do While ws.Cells(i, 1).Value <> ""
body = ws.TextBoxes("TextBox 1").Text & "font.color=red" '??
'loop over the 3 potential address cells and concatenate any content
For Each c In ws.Cells(i, "C").Resize(1, 3).Cells
If Len(c.Value) > 0 Then
sTo = sTo & IIf(Len(sTo) > 0, ";", "") & c.Value 'build the "to" string
End If
Next c
'you can skip all those intermediate variables and replace directly
For Each col In Array(Split("B,H,I,J,K,L,M,N,O,P,Q,R,S,X,Y", ",")) 'loop array of column letters
body = Replace(body, col & "2", ws.Cells(i, col).Value) 'replace tokens in body
Next col
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = sTo
.subject = ws.Cells(i, "G").Value
.body = body
'.Attachments.Add ("") 'You can add files here
.Display
'.Send
End With
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Sent!"
End Sub

Loop to send one email to a fixed number of addresses from a list until end of list. Nested range loops vs array

I have an Excel sheet with about 200 e-mail addresses in a column.
I'm trying to create an email with a standard recipient in the "to" field, and loop through those 200 addresses and put a fixed number of addresses in the "bcc" field and then create another mail with the next following fixed number of addresses, and so on until I have reached the end of the list.
I modified the following code I found online to send individual mails:
Sub BulkMail()
Application.ScreenUpdating = False
ThisWorkbook.Activate
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, subj, atchmnt, msg, ccTo, bccTo As String
Dim lstRow As Long
ThisWorkbook.Sheets("Sheet1").Activate
'Getting last row of containing email id in column 5.
lstRow = Cells(Rows.Count, 5).End(xlUp).Row
'Variable to hold all email ids
Dim rng As Range
Set rng = Range("E2:E" & lstRow, 20)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.
'Loop to iterate through each row, hold data in of email in variables and send
'mail to each email id.
For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2
subj = Range(cell.Address).Offset(0, 1).Value2 & "-MS"
msg = Range(cell.Address).Offset(0, 2).Value2
atchmnt = Range(cell.Address).Offset(0, -1).Value2
ccTo = Range(cell.Address).Offset(0, 3).Value2
bccTo = Range(cell.Address).Offset(0, 4).Value2
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.BCC = bccTo
.Body = "Hi this is a test"
.Subject = "Test"
.Attachments.Add atchmnt
.Send 'this send mail without any notification. If you want see mail
'before send, use .Display method.
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
End Sub
My searches to see if I can modify the step size didn't provide me with anything that seemed useful.
I understand that my range is set from the value in the second row until the last value found in a cell in (in this case) column E.
I essentially don't want to use For Each cell In rng but something like For every 20 cells In rng (the last one obviously doesn't work, but it might be a useful pseudo code example).
I've read that an array might be more useful, and from what I understood I could potentially store ranges of values in multiple arrays and then loop through the array. I want to learn to do this.
You need to replace the following piece of code:
For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2
subj = Range(cell.Address).Offset(0, 1).Value2 & "-MS"
msg = Range(cell.Address).Offset(0, 2).Value2
atchmnt = Range(cell.Address).Offset(0, -1).Value2
ccTo = Range(cell.Address).Offset(0, 3).Value2
bccTo = Range(cell.Address).Offset(0, 4).Value2
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.BCC = bccTo
.Body = "Hi this is a test"
.Subject = "Test"
.Attachments.Add atchmnt
.Send 'this send mail without any notification. If you want see mail
'before send, use .Display method.
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
First of all, there is no need to create a new mail item object for each row in the worksheet. So, you need to create a mail item out of the loop:
Set outMail = outApp.CreateItem(0)
sendTo = Range(cell.Address).Offset(0, 0).Value2
subj = Range(cell.Address).Offset(0, 1).Value2 & "-MS"
msg = Range(cell.Address).Offset(0, 2).Value2
atchmnt = Range(cell.Address).Offset(0, -1).Value2
Set recipients = outMail.Recipients
For Each cell In rng
ccTo = Range(cell.Address).Offset(0, 3).Value2
bccTo = Range(cell.Address).Offset(0, 4).Value2
recipientTo = recipients.Add(ccTo)
recipientTo.Type = Outlook.OlMailRecipientType.olTo
recipientBCC = recipients.Add(bccTo)
recipientBCC.Type = Outlook.OlMailRecipientType.olBCC
Next cell 'loop ends
recipients.ResolveAll()
.Body = "Hi this is a test"
.Subject = "Test"
.Attachments.Add atchmnt
.Send 'this send mail without any notification. If you want see mail
Set outMail = Nothing 'nullifying outmail object for next mail
Use the Recipients property of the MailItem class for adding recipients which contains a collection of Recipient objects for an Outlook item. Use the Add method to create a new Recipient object and add it to the Recipients object. The Type property of a new Recipient object is set to the default for the associated AppointmentItem, JournalItem, MailItem, or TaskItem object and must be reset to indicate another recipient type. The name can be a string that represents the display name, the alias, the full SMTP email address, or the mobile phone number of the recipient. A good practice is to use the SMTP email address for a mail message.
Read more about that in the How To: Fill TO,CC and BCC fields in Outlook programmatically article.

How do I open Email Meeting Template instead of Email using VBA excel

I have a create a bit of dynamic email where user is able to send multiple email based on how many data in the said column. The code itself will follow the textbox word by word and generate in the email body, but I am currently trying to make Excel open an Email Meeting template instead of a normal email.
Here is the code.
Sub send_mass_email()
Dim i As Integer
Dim name, email, body, subject, copy, place, business As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
'Loop down name column starting at row 2 column 1
Do While Cells(i, 1).Value <> ""
name = Split(Cells(i, 1).Value, " ")(0) 'extract first name
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
business = Cells(i, 5).Value
place = Cells(i, 6).Value
'replace place holders
body = Replace(body, "C1", name)
body = Replace(body, "C5", business)
body = Replace(body, "C6", place)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.body = body
'.Attachments.Add ("") 'You can add files here
.display
'.Send
End With
'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Sent!"
End Sub
I have tried to use olmeeting but an error occurs: Object doesn't support this property or method .
There are no silly questions!
Please reference the VBA documentation here.
It seems that you want to modify this part of the code:
Set OutMail = OutApp.CreateItem(0)
to
Set OutMail = OutApp.CreateItem(1)
The documentation imples that by changing the parameter of .CreateItem method to one of the listed values here, you will achieve the desired effect. Please note I did not yet test it.

Resources