I have a code that sends an email too individuals on a list.
I need the user's signature to appear at the bottom of the email. I cannot get it to display.
Below is my code.
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo Cleanup
For Each cell In Columns("M").Cells.SpecialCells(xlCellTypeConstants)
If LCase(Cells(cell.Row, "M").Value) = "no" Then
Set OutMail = OutApp.CreateItem(0)
strbody = "Dear " & Cells(cell.Row, "A").Value _
& "<br>" & "<br>" & _
"You still have outstanding work on the Rescan Spreadsheet " & _
" Title number: " & Cells(cell.Row, "E").Value _
& "<br>" & "<br>" _
& "<A href=""\\cv-vfl-d01\dlr_office\Operational Teams\RR Scanning Team\" & _
"Back file QA Xerox\Document Rescans\Rescans 2019"">Click here to open file location</A>"
On Error Resume Next
With OutMail
.To = Cells(cell.Row, "B").Value
.CC = "Bethany.Turner#Landregistry.Gov.uk"
.Subject = "Re-Scan Reminder"
.HTMLBody = strbody & .HTMLBody
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
Cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
MsgBox "Reminder Sent", vbOKOnly
End Sub
Your code needs to call Display first - that is when Outlook inserts the default signature into an empty email.
Secondly, do not concatenate two HTML strings - they must be merged, not concatenated: in the simplest case, search for the position of the "<body" substring, find the next occurrence of the ">" character (that takes care of the "<body>" HTML elements with attributes), then insert your HTML text.
If you want to send a message without displaying it first or if you want to insert an arbitrary signature, you can use Redemption (I am its author) and its RDOSignature.ApplyTo method.
Related
I have a report that is generated for me daily that I need to send out to certain admins. The problem is that not every admin is always mentioned, and the admins that are mentioned often appear multiple times. Plus the number of rows I have is always variable.
It generally appears like this:
What I'd like to have happen is for an email to be generated to each admin that is mentioned. What I have so far is this (my company's email addresses are set up as "first.last#email.email"):
Sub Email_Test()
Columns("F:F").Select
Selection.Replace What:=" ", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
End With
signature = OMail.body
With OutMail
.To = Range("F2") & "#email.email" & "; " & Range("F3") & "#email.email" & "; " & Range("F4") & "#email.email" & "; " & Range("F5") & "#email.email" & "; " & Range("F6") & "#email.email"
.CC = ""
.BCC = ""
.Subject = "Report"
.HTMLBody = "See attached" & "<br>" & .HTMLBody
.Attachments.Add ActiveWorkbook.FullName
.DeferredDeliveryTime = ""
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Clearly this will not work, but hopefully it illustrates my idea. Is there a way for me to search column F for each unique instance of a name and then add the email extension? I'm sure there's a less convoluted way than what I currently have.
Thank you!
So, first off it's really dangerous to guess email addresses from a list of names.
(Are you sure there are not two Paul Blarts? If so, only one is getting the report. Are you sure there are not two Tony Pajamas? If so is the right one getting the report?)
Anyway, I'll assume you've considered all of this and you get to keep your job if it goes to the wrong Pajamas.
I would use a scripting.dictionary to hold the emails, using the names or email addresses as the key. Then I could test for membership of the dict before adding another:
Not tested but should give you the jist:
Public Sub CreateEmails()
Dim row As Long
Dim email_address As String
Dim email_dict As Object
Set email_dict = CreateObject("Scripting.Dictionary")
Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object
row = 2
Do While ThisWorkbook.Sheets("SheetWithNames").Cells(row, 6).Value <> ""
email_address = email_address_from_name(.Cells(row, 6).Value) 'turns a name into an email
If Not email_dict.exists(email_address) Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = email_address
.Subject = "Report"
.HTMLBody = "See attached" & "<br>" & .HTMLBody
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
email_dict.Add email_address, OutMail
End If
row = row + 1
Loop
End Sub
I've used an example to create code to send emails from Excel (with Outlook), using a "Button" (red in my file).
The code works. There is a pre-selected range of rows [B1:K20], that can be manually modified thanks to the Application.InputBox function.
Sub MAIL()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBodyIn, StrBodyEnd As String
StrBodyIn = "Bonjour," & "<br>" & _
" " & "<br>" & _
"Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & _
"Cordialement" & "<br>" & _
" " & "<br>" & _
Range("M2") & "<br>"
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "ATTENZIONE!!!" & _
vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#gmail.com"
.CC = ""
.BCC = ""
.Subject = "SITUATION"
.HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(rng) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I want to add a condition.
The selected range of rows should be copied to the body of the email if the "X" symbol is written in the column "A".
In my example, rows n° 1, 2 and n° 5 should be copied.
The two tasks here are separate so I would code them as such. Here would be my approach. Separate your sub into two logical procedures.
Determine the body range
Send the email with the range
Determine the body range
Link your button to this macro. The macro will take an input and convert it into a single column range (Column B). We will then loop through the selected range and look at Column A to determine if there is an x or not. If an x is present, we will resize the range back to it's original size and add it to a collection of cells (Final).
Once the loop is complete, the macro will then do one of the following:
If the range is empty, it will prompt your message box and end the sub (your email macro is never initiated)
If the range is not empty, we will call your EMAIL macro and pass the range along to it.
Sub EmailRange()
Dim Initial As Range, Final As Range, nCell As Range
On Error Resume Next
Set Initial = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0
For Each nCell In Initial.Resize(Initial.Rows.Count, 1)
If nCell.Offset(, -1) = "X" Then
If Not Final Is Nothing Then
Set Final = Union(Final, nCell.Resize(1, Initial.Columns.Count))
Else
Set Final = nCell.Resize(1, Initial.Columns.Count)
End If
End If
Next nCell
If Not Final Is Nothing Then
MAIL Final
Else
MsgBox "ATTENZIONE!!!" & vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
End If
End Sub
Send the email with the range
Notice that the macro now has an input (On first line). If the sub is called, you no longer need to validate anything since this was all done in the original sub!
Sub MAIL(Final as Range)
Dim OutApp As Object, OutMail As Object
Dim StrBodyIn As String, StrBodyEnd As String
StrBodyIn = "Bonjour," & "<br>" & " " & "<br>" & "Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & "Cordialement" & "<br>" & " " & "<br>" & Range("M2") & "<br>"
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#gmail.com"
.CC = ""
.BCC = ""
.Subject = "SITUATION"
.HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(Final) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I continue my work starting from the 1st question here:
Excel VBA - Outlook Email - Body created with rows having a particular value
Now i have another problem.
I want to repeat the below MACROs on all the SHEETS of my file.
In particular, how can I repeat this function on different SHEETS by only clicking in 1 button present in all the sheets?
All the sheets have the same structure.
I mean, the table resulting in the email must be implemented by adding the datas in all the sheets.
The data should be copied starting from the 1st sheet, for ex. TEST(1) to the last sheet, TEST(9).
The email generated after this process must be ONLY one.
Determine the body range
Sub EmailRange()
Dim Initial As Range, Final As Range, nCell As Range
On Error Resume Next
Set Initial = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0
For Each nCell In Initial.Resize(Initial.Rows.Count, 1)
If nCell.Offset(, -1) = "X" Then
If Not Final Is Nothing Then
Set Final = Union(Final, nCell.Resize(1, Initial.Columns.Count))
Else
Set Final = nCell.Resize(1, Initial.Columns.Count)
End If
End If
Next nCell
If Not Final Is Nothing Then
MAIL Final
Else
MsgBox "ATTENZIONE!!!" & vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
End If
End Sub
Send the email with the range
Sub MAIL(Final as Range)
Dim OutApp As Object, OutMail As Object
Dim StrBodyIn As String, StrBodyEnd As String
StrBodyIn = "Bonjour," & "<br>" & " " & "<br>" & "Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & "Cordialement" & "<br>" & " " & "<br>" & Range("M2") & "<br>"
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#gmail.com"
.CC = ""
.BCC = ""
.Subject = "SITUATION"
.HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(Final) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I've tried with something like this, but it does not work:
For I = 1 To Worksheets.Count
Sheets(I).Select
***[...]CODE OF "Determine the body range"***
Next I
Sheets("TEST(I)").Select
I know my code is very clumsy, I am trying my best to make something out of it.
The idea behind is to have an excel sheet with all the relevant details and based on this sheet, emails with the respective relevant content shall be sent.
The emails starts with strbody = Cells(cell.Row, "A").Value & Cells(cell.Row, "B").Value _
Here cell.row A is the greeting (either Dear Sir or Dear Madam) and cell.row B is the name of the person.
If I run the code, everything works fine but the font of this code line is messed up. It shows in times new roman but I wish to have it in arial size: 10pt. I tried everything but always getting errors.
Any ideas?
Thanks in advance.
Sub test1()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strbody As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error GoTo cleanup
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "D").Value) = "ENG" Then
On Error Resume Next
With OutMail
.display
strbody = Cells(cell.Row, "A").Value & Cells(cell.Row, "B").Value _
& "<p style= font-family:arial;font-size:10pt> Welcome </p>" _
& IIf(Cells(cell.Row, "G").Value = "incomplete", "<p style= font-family:arial;font-size:10pt>Please do not forget to complete your registration:<p/> " & Cells(cell.Row, "F").Value, "<p> <p/>") _
& "<h3 style= font-family:arial;font-size:11pt><font color=#5b9bd5><u>Check-in & Check-out</u></font></h3>" _
& "<p style= font-family:arial;font-size:10pt>Check-In: <b>ab 15:00 Uhr</b> & Check-out: <b>bis 10:00 Uhr</b> Other hours on request </p>" _
& "<p style= font-family:arial;font-size:10pt>Thanks</b></p>" _
.Attachments.Add ("G:\E-Mail Vorlagen\Anhang\Anreise Infos\Nützliche Informationen.pdf")
.To = Cells(cell.Row, "C").Value
.Subject = "Your arrival" & Cells(cell.Row, "E").Value
.htmlbody = strbody & .htmlbody
.BodyFormat = olFormatHTML
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Use single quotes (i.e. ticks ) to isolate your style commands.
...
& "<p style='font-family:arial;font-size:10pt;'> Welcome </p>"
...
I have a few VBA macros that don't work since I installed the 2016 version of Office.
It's the bit to display a pre-typed email that doesn't work. The rest of the code runs as it should.
Sub Send_Application()
Application.ScreenUpdating = False
For Each cell In ActiveSheet.Range("NumberOfApps").Cells
If cell.Value = "Y" Then
cell.Offset(0, -1).Value = Worksheets("Data").Range("A2")
cell.Value = "SENT"
cell.Offset(0, 18).Value = "Yes"
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim sTo As String
AppName = "J:\Matrixes\All Sites\Applications\" & Worksheets("Data").Range("E3") & "\" & cell.Offset(0, 13).Value & ".pdf"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = Worksheets("Data").Range("G2") & vbNewLine & vbNewLine & _
"Please find attached our application for payment for the month of " & Worksheets("Data").Range("E2") & "." & vbNewLine & vbNewLine & _
"Can I ask you to check you are happy with this application and I will issue an Vat Invoice to you. If you do have any queries can you please notify me by email before the 15th " & _
Worksheets("Data").Range("E4") & " otherwise we look forward receiving your payment " & Worksheets("Data").Range("E6") & "." & vbNewLine & vbNewLine & _
"Thank You" & vbNewLine & vbNewLine & _
"Kind Regards"
On Error Resume Next
With OutMail
.To = sTo
.CC = ""
.BCC = ""
.Subject = cell.Offset(0, 13).Value
.Body = strbody
.Attachments.Add (AppName)
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Display
End With
'On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next cell
Application.ScreenUpdating = True
End Sub
I have commented out the "On Error Resume" lines but there are no errors that appear.
I have run Excel and Outlook as administrator, enabled all macros temporarily in both.
If I write a brand new macro using the same text, it works until I close Excel. Then I need to do it again.
I searched for a solution but everything I tried hasn't worked.
With you code do the following:
Select the Sub Send_Application() with your mouse
Press F8
Press F8
Press F8
and so on. You should be getting every line in yellow like this:
Does it work?