I have a list of 1000+ of customers dowloaded from SAP. I have a macro for sending monthly statements (pdfs about outstanding invoices or open cases).
My macro grabs email address from column A, the next column is Subject of email and last one is body of the email:
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet
For Each cell In ws.Range("A2:A1000")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = cell.Value
.Subject = cell.Offset(0, 1).Value
.Body = cell.Offset(0, 2).Value
.Attachments.Add cell.Offset(0, 3).Value
'display will show you email before it is sent, replace it with "send" and it will sent email without displaying
.send
End With
Set objMail = Nothing
Next cell
Set ws = Nothing
Set objOutlook = Nothing
End Sub
It works but I want to adapt it.
How can I add signature which is for example stored in .htm on desktop (to have it changed for all of my colleagues to personalize emails).
Emails contain a list of delayed invoices also from report from SAP - customer has specific SAP number.
I need to add to the email all open items which contain the specific customer number (named as account).
Regarding part 1, you can convert HTML to an Outlook template file (.oft) as per the instructions here:
http://smallbusiness.chron.com/convert-html-oft-52249.html
That template file can then be used using the Application.CreateItemFromTemplate method as per the docs below:
https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/application-createitemfromtemplate-method-outlook
Regarding part 2, to include table data in the email just use something like below:
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0) ' or use the template method specified in pt 1.
Dim html As String: html = "<html><body><table>"
Dim row As String
' the two lines below should be changed to include data from your excel
' table when filtered. Repeat the two lines below for the rows as required
row = "<tr><td> .... </td></tr>"
html = html & row
' once the rows are processed, close off the html tags
html = html & "</table></body></html>"
With OutMail
.To = "email_address#email.com"
.CC = ""
.BCC = ""
.HTMLBody = html
.BodyFormat = olFormatHTML
.Display ' or .Send
End With
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
Sub SendEmail()
Dim email As String
Dim subject As String
Dim msg As String
Dim mailURL As String
Dim i As Integer
Dim tableRange As Range
On Error Resume Next
Set tableRange = Application.InputBox("Please select the data range:", "Custom Email Sender", Type:=8) ''Type 8 is cell reference
If tableRange Is Nothing Then Exit Sub ''A little error handeling incase someone accidentily doesn't select a range
If tableRange.Columns.Count <> 4 Then
MsgBox "You must select 4 columns of data. Please try again"
Exit Sub
End If
For i = 1 To tableRange.Rows.Count
email = tableRange.Cells(i, 3)
subject = "Thank you for your Recent Purchase at Think Forward Computer Services"
''Create the message
msg = "Hi " & tableRange.Cells(i, 1) & ", "
msg = msg & "We want to thank you for your recent business at our store! We really appreciate it."
msg = msg & "If you have any questions or concerns about your " & tableRange.Cells(i, 4) & " we're here to help. Just reply to this email at anytime " _
& "or call us at 555-555-5555 between the hours of 8am - 8pm " & vbNewLine & vbNewLine & "Thanks Again, " & vbNewLine & "Think Forward Computer Services"
mailURL = "mailto:" & email & "?subject=" & subject & "&body=" & msg
Call Shell(sCmd, vbNormalFocus)
''Send the Email
ShellExecute 0&, vbNullString, mailURL, vbNullString, vbNullString, vbNormalFocus
''Wait for email client to open
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Next
End Sub
Related
I have a table in Excel. It is built as follows:
|Information on food|
|date: April 28th, 2021|
|Person|Email|Apples|Bananas|Bread|
|------|-----|------|-------|-----|
|Person_A|person_A#mailme.com|3|8|9|
|Person_B|person_B#mailme.com|10|59|11|
|Person _C|person_C#maime.com|98|12|20|
There is also a date field in the table. For a test, this could be set to todays date.
Based on this information, I am looking for a VBA code which prepares an email to each of the listed persons and is telling them what they have eaten on the specific date.
I need to access several fields in the table, and at the same time loop through the email addresses. Then I would like VBA to open Outlook and prepare the emails. Ideally not send them so I can take a final look before I send the mails.
It would be fine to access certain cells specifically via ranges etc. I am using Excel/Outlook 2016.
How can this be achieved in VBA?
Assuming the data is a named table and title/date are above the corner of the table as shown in your example. Also all the rows of the table have valid data. The emails are prepared and shown but not sent (unless you change the code where shown).
Option Explicit
Sub EmailMenu()
Const TBL_NAME = "Table1"
Const CSS = "body{font:12px Verdana};h1{font:14px Verdana Bold};"
Dim emails As Object, k
Set emails = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet, rng As Range
Dim sName As String, sAddress As String
Dim r As Long, c As Integer, s As String, msg As String
Dim sTitle As String, sDate As String
Set ws = ThisWorkbook.Sheets("Sheet1")
Set rng = ws.ListObjects(TBL_NAME).Range
sTitle = rng.Cells(-1, 1)
sDate = rng.Cells(0, 1)
' prepare emails
For r = 2 To rng.Rows.Count
sName = rng.Cells(r, 1)
sAddress = rng.Cells(r, 2)
If InStr(sAddress, "#") = 0 Then
MsgBox "Invalid Email: '" & sAddress & "'", vbCritical, "Error Row " & r
Exit Sub
End If
s = "<style>" & CSS & "</style><h1>" & sDate & "<br>" & sName & "</h1>"
s = s & "<table border=""1"" cellspacing=""0"" cellpadding=""5"">" & _
"<tr bgcolor=""#ddddff""><th>Item</th><th>Qu.</th></tr>"
For c = 3 To rng.Columns.Count
s = s & "<tr><td>" & rng.Cells(1, c) & _
"</td><td>" & rng.Cells(r, c) & _
"</td></tr>" & vbCrLf
Next
s = s & "</table>"
' add to dictonary
emails.Add sAddress, Array(sName, sDate, s)
Next
' confirm
msg = "Do you want to send " & emails.Count & " emails ?"
If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
' send emails
Dim oApp As Object, oMail As Object, ar
Set oApp = CreateObject("Outlook.Application")
For Each k In emails.keys
ar = emails(k)
Set oMail = oApp.CreateItem(0)
With oMail
.To = CStr(k)
'.CC = "email#test.com"
.Subject = sTitle
.HTMLBody = ar(2)
.display ' or .send
End With
Next
oApp.Quit
End Sub
not sure how to best title this, but I have a sheet from which I loop through each row and create an email for each row. Attachments are based on the Division name. Currently, it creates an email for every row, so if one person under Name has, say 8 divisions, they will receive 8 emails, each with a different attachment. This is annoying people, so I want to have it now loop (maybe nested?) and if if finds the same Name, then create one email for that Name, with all their Division reports attached.
To make it easier, I have set the list so that any dupe Names are all grouped together. In this example, I would want it to create one email to the Name Sample Sample1, with attachments for Widgets and Doorknobs. Then for the rest, they would each get their usual one email. I have tried for hours to get this to work, but simply do not have enough VBA knowledge to make this work. I can do it in Excel itself with formulas, basically saying that if A2=A3, then do this. But I need help to get this to happen in VBA. Please see the image.
Update: I have updatedthe below code I have put together using the factoring method shown to be by Vityata. It runs, but creates dupes of each email.
Option Explicit
Public Sub TestMe()
Dim name As String
Dim division As String
Dim mail As String
Dim dict As Object
Dim dictKey As Variant
Dim rngCell As Range
Set dict = CreateObject("Scripting.Dictionary")
For Each rngCell In Range("b2:b4")
If Not dict.Exists(rngCell.Value) Then
dict.Add rngCell.Value, rngCell.Offset(0, -1)
End If
Next rngCell
For Each dictKey In dict.keys
SendMail dictKey, dict(dictKey)
Next dictKey
End Sub
Public Sub SendMail(ByVal address As String, ByVal person As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strdir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As String
Dim strName1 As String
Dim strDept As String
Dim strName2 As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Test.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
strdir = "z:\"
strBody = "<Font Face=calibri>Please review the attached report for your department."
For Each address In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
strName = Cells(cell.Row, "a").Value
strName1 = Cells(cell.Row, "d").Value
strName2 = Left(strName, InStr(strName & " ", " ") - 1)
strFilename = Dir("z:\*" & strName1 & "*")
.To = cell.Value
.Subject = "Monthly Budget Deficit Report for " & strName1
.HTMLBody = "<Font Face=calibri>" & "Dear " & address & ",<br><br>"
.Attachments.Add strdir & strFilename
.Display 'Or use Send
End With
Set OutMail = Nothing
End If
Next cell
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function
A question like this can be summarized to the following: How do I avoid duplicate values in VBA, as far as you do not want to send twice the same e-mail to the same address.
Thus, imagine the following data:
You do not want to send the email twice to Mr. Test and Mr. Test2. What is the alternative? Try to build a dictionary, as a key the unique mail column. Then refactor your code, sending code only to the people that "made it" to the dictionary. You need to refactor your code, thus at the end you get something like this:
Option Explicit
Public Sub TestMe()
Dim name As String
Dim division As String
Dim mail As String
Dim dict As Object
Dim dictKey As Variant
Dim rngCell As Range
Set dict = CreateObject("Scripting.Dictionary")
For Each rngCell In Range("C2:C6")
If Not dict.exists(rngCell.Value) Then
dict.Add rngCell.Value, rngCell.Offset(0, -1)
End If
Next rngCell
For Each dictKey In dict.keys
SendMail dictKey, dict(dictKey)
Next dictKey
End Sub
Public Sub SendMail(ByVal address As String, ByVal person As String)
Debug.Print "Mr./Mrs. " & person & ", here is your email -> " & address
End Sub
This is what you get:
Mr./Mrs. Test, here is your email -> test#t.t
Mr./Mrs. Test2, here is your email -> test2#t.t
Mr./Mrs. Test3, here is your email -> test3#t.t
The idea of the refactoring, is that you separate the "reading-from-Excel" logic from the "Send email" logic. In the "reading-from-Excel" logic you will only read those parts, which are unique and in the "Send email" you will send mail to anyone who has passed the reading logic.
I have a macro that copies a word document content, pastes it into an email. Then pulls email addresses and names from Excel, and sends each person the email with an attachment. (Essentially a mailmerge)
Problem is, anytime the subject has a colon ":", the email message sends as blank. This doesn't happen if I save the email, nor when I display it. Only happens if it is immediately sent.
Here is the code:
Option Explicit
Sub SendInitialEmail()
'directory of email body
Dim dirEmailBody As String
' Directory of email template
dirEmailBody = _
"C:\Users\me\Documents\Email Body.docx"
Dim wordApp As Word.Application
Dim docEmail As Document
' Opens email template and copies it
Set wordApp = New Word.Application
Set docEmail = wordApp.Documents.Open(dirEmailBody)
docEmail.Content.Copy
Dim outEdit As Document
Dim outApp As Outlook.Application
Set outApp = New Outlook.Application
Dim outMail As MailItem
' The names/emails to send too
Dim sendName As String, sendEmail As String, _
ccEmail As String, siteName As String
Dim row As Integer
' Was only testing on one row, but generally this pulls from
'a sheet of names and email addresses to send an email with attachments too.
For row = 1 to 1
sendName = actSheet.Cells(row, 1)
sendEmail = actSheet.Cells(row, 2)
ccEmail = actSheet.Cells(row, 3)
siteName = actSheet.Cells(row, 4)
Set outMail = outApp.CreateItem(olMailItem)
With outMail
.SendUsingAccount = outApp.Session.Accounts.Item(1)
.To = "myemailaddress to test#gmail.com"
.BodyFormat = olFormatHTML
.subject = _
"Is the error cause of a colon: Email test to me"
' it was
Set outEdit = .GetInspector.WordEditor
outEdit.Content.Paste
outEdit.Range(0).InsertBefore ("Dear " & sendName & "," & vbNewLine)
' If I do display, it shows up correctly.
' If I display then send it is fine (workaround)
.Send
End With
Next row
docEmail.Close
wordApp.Quit
End Sub
Remove the following:
Set outEdit = .GetInspector.WordEditor
outEdit.Content.Paste
outEdit.Range(0).InsertBefore ("Dear " & sendName & "," & vbNewLine)
and add:
`.Body = "Dear " & sendName & "," & vbNewLine & docEmail.Content.Text`
The colon is not the problem.
Try to use the Chr() command, in this case the ":" is Chr(58)
I have the following problem. I use MSword mail merge to send emails. I regularly send out 100-500 emails (not spam, singular requests). I keep my email addresses in a single MSexcel sheet. Many of the email addresses are broken, and most replies are negative. Many of the emails responses come within the first 30 minutes of sending the email. After I get a response, I need to mark the response on the excel list. This process can be time consuming. Thus, the problem. Now, the question.
Is there a way to make my computer check the subject line of my emails for a specified string, and if it contains that string, then it copies the email address from that email, either in the body of the email, or in the sender field, and then moves to a specified excel sheet, searches for the email address in the excel sheet, and then marks the email address in the excel sheet.
Very happy for anyone that can point me in the right direction. I have absolutely no programming experience. I have used computers my entire life, but mostly to send and receive emails, or browse the internet.
You can use this directly from Excel, it's a bit overkill for what you want but you can remove fields if you don't need them:
'*********************************************************************************************
' All code is supplied under the Creative Commons License (CC). Code samples provided by
' Wilde XL Solutions are strictly for non-commerical use only and provided for the purpose
' learning and study. If you would like to seek permission to use this code in any way other
' than specified in this license agreement, please email cc#wxls.co.uk.
'
' A copy of the general creative commons (CC) license can be found at:
' http://tinyurl.com/WXLSCCinfo
'*********************************************************************************************
Sub getMail()
' This sub is designed to be used with a blank worksheet. It will create the header
' fields as required, and continue to populate the email data below the relevant header.
' Declare required variables
'-------------------------------------------------------------
Dim olApp As Object
Dim olFolder As Object
Dim olMailItem As Object
Dim strTo As String
Dim strFrom As String
Dim dateSent As Variant
Dim dateReceived As Variant
Dim strSubject As String
Dim strBody As String
Dim loopControl As Variant
Dim mailCount As Long
Dim totalItems As Long
'-------------------------------------------------------------
'Turn off screen updating
Application.ScreenUpdating = False
'Setup headers for information
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")
'Format columns E and F to
Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
'Create instance of Outlook
Set olApp = CreateObject("Outlook.Application")
'Select folder to extract mail from
Set olFolder = olApp.GetNamespace("MAPI").PickFolder
'Get count of mail items
totalItems = olFolder.items.Count
mailCount = 0
'Loop through mail items in folder
For Each loopControl In olFolder.items
'If loopControl is a mail item then continue
If TypeName(loopControl) = "MailItem" Then
'Increase mailCount
mailCount = mailCount + 1
'Inform user of item count in status bar
Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems
'Get mail item
Set olMailItem = loopControl
'Get Details
With olMailItem
strTo = .To
'If strTo begins with "=" then place an apostrophe in front to denote text format
If Left(strTo, 1) = "=" Then strTo = "'" & strTo
strFrom = .Sender
'If sender displays name only, show name followed by email address e.g.(Bloggs, Joe < j.bloggs#mail.com >)
If InStr(1, strFrom, "#") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
dateSent = .SentOn
dateReceived = .ReceivedTime
strSubject = .Subject
strBody = .Body
End With
'Place information into spreadsheet
'import information starting from last blank row in column A
With Range("A" & Rows.Count).End(xlUp).Offset(0, 0)
.Value = strTo
.Offset(1, 1).Value = strFrom
.Offset(2, 2).Value = strSubject
'Check for previous replies by looking for "From:" in the body text
'Check for the word "From:"
If InStr(0, strBody, "From:") > 0 Then
'If exists, copy start of email body, up to the position of "From:"
.Offset(1, 1).Value = Mid(strBody, 1, InStr(1, strBody, "From:") - 1)
Else
'If doesn't exist, copy entire mail body
.Offset(3, 3).Value = strBody
End If
.Offset(4, 4).Value = dateSent
.Offset(5, 5).Value = dateReceived
End With
'Release item from memory
Set olMailItem = Nothing
End If
'Next Item
Next loopControl
'Release items from memory
Set olFolder = Nothing
Set olApp = Nothing
'Resume screen updating
Application.ScreenUpdating = True
'reset status bar
Application.StatusBar = False
'Inform user that code has finished
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"
End Sub
Hi I am using the below code to send multiple emails based on different cases. (Email addressess and other information are stored in a worksheet) The code works fine however I have 20 different cases (example below only shows two). Putting the outlook application code within each case seems cumbersome.
Is there a method to perform the email against each case without having to express the outlook code within each case?
I have searched using For Each Case without any luck. Help is greatly appreciated.
Sub RequestUpdates()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim blRunning As Boolean
Dim email As String
Dim fname As String
Dim fllink As String
Dim cpname As String
Dim v As Integer
Dim y As Integer
Dim rng As Range
Dim rdate As Date
Dim signature As String
v = Sheets("Contributors").Range("A" & Rows.Count).End(xlUp).Row
Set rng = Sheets("Contributors").Range("A1")
rdate = Sheets("Contributors").Range("A1").Value
For y = 0 To v
Select Case rng.Offset(1 + y, 0).Value
Case "PCR"
email = Sheets("Contributors").Range("E4").Value
fname = Sheets("Contributors").Range("D4").Value
fllink = Sheets("Contributors").Range("F4").Value
cpname = Sheets("Contributors").Range("B4").Value
'get application
blRunning = True
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = New Outlook.Application
blRunning = False
End If
On Error GoTo 0
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.Display
End With
signature = olMail.HTMLBody
With olMail
'Specify the email subject
.Subject = "test " & rdate
'Specify who it should be sent to
'Repeat this line to add further recipients
.Recipients.Add email
'specify the file to attach
'repeat this line to add further attachments
'.Attachments.Add "LinktoAttachment"
'specify the text to appear in the email
.HTMLBody = "<p>Hi " & fname & ",</p>" & _
"<P>Please follow the link below to update the " & cpname & " test" _
& "For month ending " & rdate & ".</p>" & _
"<P> </br> </p>" & _
fllink & _
"<P> </br> </p>" & _
"<p>If you face issues with file access please contact me directly.</p>" & _
"<P>Note: xxxxx.</p>" & _
signature
'Choose which of the following 2 lines to have commented out
.Display 'This will display the message for you to check and send yourself
'.Send ' This will send the message straight away
End With
Case "NFG"
email = Sheets("Contributors").Range("E6").Value
fname = Sheets("Contributors").Range("D6").Value
fllink = Sheets("Contributors").Range("F6").Value
cpname = Sheets("Contributors").Range("B6").Value
'get application
blRunning = True
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = New Outlook.Application
blRunning = False
End If
On Error GoTo 0
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.Display
End With
signature = olMail.HTMLBody
With olMail
'Specify the email subject
.Subject = "Test" & rdate
'Specify who it should be sent to
'Repeat this line to add further recipients
.Recipients.Add email
'specify the file to attach
'repeat this line to add further attachments
'.Attachments.Add "LinktoAttachment"
'specify the text to appear in the email
.HTMLBody = "<p>Hi " & fname & ",</p>" & _
"<P>Please follow the link below to update the " & cpname & " component Test" _
& "For month ending " & rdate & ".</p>" & _
"<P> </br> </p>" & _
fllink & _
"<P> </br> </p>" & _
"<p>If you face issues with file access please contact me directly.</p>" & _
"<P>Note: Test.</p>" & _
signature
'Choose which of the following 2 lines to have commented out
.Display 'This will display the message for you to check and send yourself
'.Send ' This will send the message straight away
End With
End Select
Next
End Sub
I see two cases you showed follow one template, how about creating sub which sends emails retreiving subject, to etc. from parameters and then calling it from within Select Case with proper values passed?