This macro uses an HTML file that holds the template to send mass emails.
I set up a function to call on a column of email addresses to fill the CC.
Needs have changed and I would like to not condense two columns into one to CC two people.
I tried making a second function to add the second variable to the CC.
I'd like .Cc = email#email.com; email#email.com
The macro pulls from pre-filled email address list which is why it has a range in the function.
Sub PreviewEmail(wsNew As Worksheet, looper As Range, month As Range, year As Range)
'Macro Purpose: To send an email through Outlook
Dim rng As Range
Dim ToEmailList As String
Dim CcEmailList As String
Dim CcEmailListT As String
Dim sSubject As String
Dim sName As String
Dim line As String
Dim oFSO
Dim oFs
Dim pathName As String
pathName = ActiveWorkbook.Path & "\template.htm"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFs = oFSO.OpenTextFile(pathName)
ToEmailList = setToEmail
CcEmailList = setCcEmail
CcEmailListT = setCcEmailT
sSubject = "This is a test"
sName = setSendName
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set rng = wsNew.Range("A1:F" & wsNew.UsedRange.Rows.Count)
With OutMail
stext = oFs.readall
For Each cell In looper
line = line & cell.Text & " " & cell.Offset(0, 1).Text & " <br />"
Next
stext = Replace(stext, "%variable%", line)
stext = Replace(stext, "monthmonthmonth", month.Text)
stext = Replace(stext, "yearyearyear", year.Text)
.SentOnBehalfOfName = "JPMC Workforce Screening"
.To = ToEmailList
.Cc = CcEmailList, CcEmailListT
.Subject = sSubject
.HTMLBody = stext
.Display
End With
End Sub
Replace
.Cc = CcEmailList, CcEmailListT
with
.Cc = CcEmailList & ";" & CcEmailListT
Related
The below code attaches one file per email. I need to attach seven files from the folder.
I have approximately 150 files.
I need to
In the first email attach the first 7 files and then loop to attach 7 files to each subsequent email then in the last email attach the remaining three PDF files.
Subject for the first email: Invoice 001 to Invoice 007
Body for First Email:
Please find attached the following invoices
Invoice 001 to Invoice 007 (7 invoices)
...
Subject for the last email: Invoice 148 to Invoice 150
Body for last Email:
Please find attached the following invoices
Invoice 148 to Invoice 150 (3 invoices)
Sub sendmailsss()
Dim path As String
Dim counter As Integer
counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet").Range("M2")
If ThisWorkbook.Worksheets("Sheet").Range("M2") = "" Then
MsgBox "No folder selected. Please Select a folder with Invoives."
Exit Sub
End If
fpath = path & "\*.pdf"
fname = Dir(path)
Dim OutApp As Outlook.Application
Dim Source As String
Dim subj() As String
Do While fname <> ""
subj = Split(fname, ".")
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Dim OutMail As Outlook.MailItem
Dim OutAccount As Outlook.Account
Set OutAccount = OutApp.Session.Accounts.Item(2)
Set OutMail = OutApp.CreateItem(olMailItem)
Source = path & fname
With OutMail
.To = "info#abc.co.uk"
.Subject = "Company Ltd " & subj(0)
.HTMLBody = "Invoice attached"
.Attachments.Add Source
.SendUsingAccount = OutAccount
'.Display
.Send
End With
If Err Then
MsgBox "Error while sending Email" & vbLf & "Press OK to check it in the Outlook", vbExclamation
'.Display
Else
ms = ms + 1
End If
On Error GoTo 0
Application.Wait Now + #12:00:10 AM#
fname = Dir()
'If ms = 3 Then
' Exit Do
'End If
Loop
MsgBox "Process Completed. " & ms & " emails sent."
End Sub
Here is the re-built code:
Sub SendMailSSS()
Dim path As String
'Dim counter As Integer
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outAccount As Outlook.Account
Dim source As String
'Dim subj() As String
Dim fPath As String
Dim fName As String
Dim fileList As Variant
Dim innerLoop As Integer
Dim fileCounter As Integer
'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
If path <> "" Then
fileList = FncGetFilesFromPath(path)
fileCounter = 0
Do While fileCounter < UBound(fileList)
Set outApp = CreateObject("Outlook.Application")
Set outAccount = outApp.Session.Accounts.Item(2)
Set outMail = outApp.CreateItem(olMailItem)
With outMail
.To = "info#abc.co.uk"
.Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
.HTMLBody = "Invoice attached"
.SendUsingAccount = outAccount
'Gets next up to 7 files
For innerLoop = fileCounter To (fileCounter + 7)
If innerLoop <= UBound(fileList) Then
.Attachments.Add fileList(innerLoop)
Else
Exit For
End If
Next innerLoop
End With
outMail.Send
fileCounter = fileCounter + innerLoop
Loop
Else
MsgBox "No folder selected. Please Select a folder with Invoices."
End If
Set outApp = Nothing
Set outMail = Nothing
Set outAccount = Nothing
End Sub
Private Function FncGetFilesFromPath(fPath As String) As Variant
Dim result As Variant
Dim fName As String
Dim i As Integer
ReDim result(0)
i = 0
fName = Dir(fPath)
Do While fName <> ""
ReDim Preserve result(i)
result(i) = fPath & fName
i = i + 1
fName = Dir()
Loop
FncGetFilesFromPath = result
End Function
You should be able to adapt this into your existing code. What you need to do I think is add all the references to the attachment files to an array first. This will allow you to loop over them according to your specific counting requirements of 7 per e-mail:
Sub SendMailSSS()
Dim path As String
'Dim counter As Integer
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outAccount As Outlook.Account
Dim source As String
'Dim subj() As String
Dim fPath As String
Dim fName As String
Dim fileList As Variant
Dim innerLoop As Integer
Dim fileCounter As Integer
'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
If path <> "" Then
fileList = FncGetFilesFromPath(path & "\*.pdf")
fileCounter = 0
Do While fileCounter < UBound(fileList)
Set outApp = CreateObject("Outlook.Application")
Set outAccount = outApp.Session.Accounts.Item(2)
Set outMail = outApp.CreateItem(olMailItem)
With outMail
.To = "info#abc.co.uk"
.Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
.HTMLBody = "Invoice attached"
.SendUsingAccount = outAccount
'Gets next up to 7 files
For innerLoop = fileCounter To (fileCounter + 7)
If innerLoop <= UBound(fileList) Then
.Attachments.Add fileList(innerLoop)
Else
Exit For
End If
Next innerLoop
End With
outMail.Send
fileCounter = fileCounter + innerLoop
Loop
Else
MsgBox "No folder selected. Please Select a folder with Invoices."
End If
Set outApp = Nothing
Set outMail = Nothing
Set outAccount = Nothing
End Sub
Private Function FncGetFilesFromPath(fPath As String) As Variant
Dim result As Variant
Dim fName As String
Dim i As Integer
ReDim result(0)
i = 0
fName = Dir(fPath)
Do While fName <> ""
ReDim Preserve result(i)
result(i) = fPath & fName
i = i + 1
fName = Dir()
Loop
FncGetFilesFromPath = result
End Function
I'm not sure what "subj" or "counter" are supposed to be doing in your code so I have commented them out. I cannot 100% test this, because I don't have Outlook on this machine, but it should give you the idea of how the looping will work.
I have a list of names, email, attachment name and I need to send email and attach these attachment, my macro worked if I specify number of attachment, but what I have is not a fix number of attachments for each name/email, sometimes it's one and sometimes more than 1. Can you check my macro and advise what should I change/add in order to make the attachment dynamic?
Sub CreateNewMessage()
Dim aOutlook As Object
Dim aEmail As Object
Dim obj As Object
Dim olInsp As Object
Dim myDoc As Object
Dim oRng As Object
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
Dim ToCc As Range, strBody, strSig As String
Dim fColorBlue, fColorGreen, fColorRed, fDukeBlue1, fDukeBlue2, fAggieMaroon, fAggieGray As String
Dim Greeting, emailContent As String
Dim emailOpen, emailMid1, emailMid2, emailMid3, emailClose, emailCustom, emailSig As String
Dim AttachmentPath, AttachmentNm As String
AttachmentPath = [O1] & "\"
fColorBlue = "#003846"
fColorGreen = "#5e9732"
fColorRed = "#FF0000"
fDukeBlue1 = "#001A57"
fDukeBlue2 = "#00009C"
fAggieMaroon = "#500000"
fAggieGray = "#332C2C"
For Each ToCc In ActiveSheet.[A2:A100] 'This is the range for how many records (rows) you want to send email
'=============================================================
Dim ToEmail, CcEmail, ToNm, CcNm, CcLNm As String
Dim DescrDt, LocID, LsmID, DescrNm As String
Dim Attach1, Attach2, Attach3 As String
ToNm = Cells(ToCc.Row, [To___fName].Column).Value
CcNm = Cells(ToCc.Row, [Cc___fName].Column).Value
CcLNm = Cells(ToCc.Row, [Cc___LName].Column).Value
ToEmail = Cells(ToCc.Row, [To___Email].Column).Value
CcEmail = Cells(ToCc.Row, [Cc___Email].Column).Value
Attach1 = Cells(ToCc.Row, [Attachment1].Column).Value
Attach2 = Cells(ToCc.Row, [Attachment2].Column).Value
Attach3 = Cells(ToCc.Row, [Attachment3].Column).Value
AttachmentNm1 = Attach1
AttachmentNm2 = Attach2
AttachmentNm3 = Attach3
Dim FileAttach1 As String
Dim FileAttach2 As String
Dim FileAttach3 As String
FileAttach1 = AttachmentPath & AttachmentNm1
FileAttach2 = AttachmentPath & AttachmentNm2
FileAttach3 = AttachmentPath & AttachmentNm3
'MsgBox FileAttach1
'MsgBox FileAttach2
'MsgBox FileAttach3
'Exit Sub
'=============================================================
Set aEmail = aOutlook.CreateItem(0)
With aEmail
'.SentOnBehalfOfName = "name#company.com"
.SentOnBehalfOfName = "name2#company.com"
.To = ToEmail
.cc = CcEmail '& "; " & SupvEmail & "; " & HREmail
.Subject = "LSM Monthly Dashboard " & Application.WorksheetFunction.Proper(ToNm) & Chr(32) & Application.WorksheetFunction.Proper(DescrNm)
'.BodyFormat = olFormatPlain ' send plain text message
'.BodyFormat = olFormatHTML
'.Importance = olImportanceHigh
'.Sensitivity = olConfidential
.HTMLBody = emailContent
'MsgBox FileAttach1
.Attachments.Add FileAttach1
.Attachments.Add FileAttach2
.Attachments.Add FileAttach3
.display
' .send
End With
NEXT_ToCC:
Set aEmail = Nothing
Set olInsp = Nothing
Set myDoc = Nothing
Set oRng = Nothing
Next ToCc
End Sub
You should use array to do this.
Add files paths to an array.
Dim files()
Files = array(path1, path2)
And after ‚htmlbody’ write:
For i = lbound(files) to ubound(files)
.attachments.add files(i)
Next i
I have a sample sheet
I have a module that runs through the list in a loop within another loop, checking for duplicate names and then grouping the names together to send an email with an attachment based on Column D (Division).
Sample 4 would get one email with 3 attachments.
I have been asked to build in the ability to exclude people based on a value (I chose yes or no, column C) before running the module.
Reason being that if the list is long (over 1000 names) to set it before generating the emails. I would build in a trigger to set that value, but it is apparently an arbitrary decision made by the senders in a dept.
I have tried to build an IF statement into the loop as shown below but it is as if the If statement is coming out as not being true (I stepped through).
Which means all the With Outmail objects will not work.
I was able to get it to work by using the if statement with a for/next setup on its own (no loops), but cannot get it to work with the loop, which is the more important piece.
Here is the main piece of code. The main loop and then the if statement to account for the yes or no values:
Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*#?*.?*" And LCase(rng.Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
End If
And here is the full sub:
Sub EmailDivisions()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Divisions.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*#?*.?*" And LCase(rng.Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
End If
Set strName = rng.Cells(r, 1)
Set strDept = rng.Cells(r, 4)
strName2 = Left(strName, InStr(strName & " ", " ") - 1)
With OutMail
strFilename = Dir("\\Divisons\1a*" & strDept & "*")
.SentOnBehalfOfName = "divisionalsend#xyz.org"
.To = rng.Cells(r, 2).Value
.Subject = "Monthly Divisional Report for " & strDept
.HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
.Attachments.Add strDir & strFilename
'See if the next row is for the same sender. If so, process that
'row as well. And then keep doing it until no more rows match
Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
r = r + 1
Set strDept = rng.Cells(r, 4)
strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
.Subject = "Monthly Divisional Report for Your Departments"
.Attachments.Add strDir & strfilename1
Loop
.Display
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = Nothing
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
Figured it out, here is the final sub:
Sub EmailDivisions()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Divisions.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.Rows.Count
Debug.Print LCase(rng.Cells(r, 2))
If Cells(r, 2).Value Like "?*#?*.?*" And LCase(Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
ElseIf Cells(r, 2).Value Like "?*#?*.?*" And LCase(Cells(r, 3)) = "no" Then GoTo ContinueLoop
End If
Set strName = Cells(r, 1)
Set strDept = Cells(r, 4)
strName2 = Left(strName, InStr(strName & " ", " ") - 1)
With OutMail
strFilename = Dir("\\Divisons\1a*" & strDept & "*")
.SentOnBehalfOfName = "divisionalsend#xyz.org"
.To = Cells(r, 2).Value
.Subject = "Monthly Divisional Report for " & strDept
.HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
.Attachments.Add strDir & strFilename
.display
'See if the next row is for the same sender. If so, process that
'row as well. And then keep doing it until no more rows match
Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
r = r + 1
Set strDept = Cells(r, 4)
strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
.Subject = "Monthly Divisional Report for Your Departments"
.Attachments.Add strDir & strfilename1
.Display
ContinueLoop:
Loop
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = Nothing
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
I'm trying to use the split funtion here. I'm trying to get content from the clipboard then store it into an array then populate the subject line with whatever I get from the array. But i always get a type mismatch error. I will appreciate some help. Here's my code
Dim DataObj As MsForms.DataObject
Set DataObj = New MsForms.DataObject
Dim varArray() As Variant
Dim myString As String
'Get data from the clipboard.
DataObj.GetFromClipboard
'Get clipboard contents
myString = DataObj.GetText
varArray() = Split(myString, Chr(10))
With OutMail
.BodyFormat = 3
.To = ""
.CC = ""
.BCC = ""
.subject = varArray(0) & " - " & varArray(2) & " - " & varArray(4)
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.collapse 1
oRng.Paste
.Display
End With
On Error GoTo 0
change
Dim varArray() As Variant to Dim varArray () as String
also, varArray = Split(myString, Chr(10)) is fine.
I'd like to build\edit the mail signiture in Excel:
1st cell : |Regards, |
2nd cell (Name) : |Asaf Gilad |
3rd Cell (Title): |PMO |
4th cell (Mail) : |Asaf#mail.com |
So that when I click send, the body of the message will look like:
Dear sir
................................
....... Message Content ........
................................
................................
Regards,
Asaf Gilad
PMO
Asaf#mail.com
The signiture contains pictures as well.
I managed to save the range as picture and send that picture as attachment, but the picture turned out to be empty in the body, dispite the fact that it was sent correctly as attachment.
Here is the code I use:
Public Sub ExportEmail(recipentName As String)
On Error GoTo err:
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim strEmailTo As String, strEmailCC As String, strEmailBCC As String
Dim FNAME As String
Dim oRange As Range
Dim oChart As Chart
Dim oImg As Picture
strEmailTo = ""
strEmailCC = ""
strEmailBCC = ""
strEmailTo = "a#a.com"
strEmailCC = "b#b.com
If strEmailTo "" Then
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
olNs.Logon
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = strEmailTo
olMail.CC = strEmailCC
olMail.BCC = strEmailBCC
olMail.Subject = " My Subject"
Set oRange = Sheets(1).Range("A1:Z100")
Set oChart = Charts.Add
oRange.CopyPicture xlScreen, xlPicture
oChart.Paste
FNAME = Environ$("temp") & "\testPic.gif"
oChart.Export Filename:=FNAME, FilterName:="GIF"
olMail.Attachments.Add FNAME
olMail.HTMLBody = "" & _
""
olMail.Attachments.Add FNAME
olMail.Send
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Kill FNAME
Set olApp = Nothing
Set olNs = Nothing
Set oRange = Nothing
Set oChart = Nothing
Set oImg = Nothing
Exit Sub
err:
MsgBox err.Description
End Sub
This is a good question, Asaf. When I have built automated e-mail solutions, I've found it difficult to get the signature line in. It's possible, but not easy. Maybe it's updated in 2010, but I haven't checked yet.
What I do is place the entire body into a text file on a drive, complete with any html tags that I want for formatting. This gives me great flexibility in both making nicely formatted e-mails where I can assign variables as well.
I then access those files through the Microsoft Scripting Runtime library.
See below code snippets:
Option Explicit
Const strEmailBoiler As String = "\\server\path\folder\subfolder\email_text\"
Sub PrepMessage()
Dim strBody As String, strMon As String
strMon = range("Mon").Value
strFY = range("FY").Value
strBody = FileToString(strEmailBoiler, "reports_email_body.txt")
strBody = Replace(strBody, "[MONTH]", strMon)
strBody = Replace(strBody, "[YEAR]", Right(strFY, 2))
strBody = Replace(strBody, "[FILE PATH]", strFileName)
SendMail "firstname.lastname#xyz.com", "Subject Goes Here " & strMon & " YTD", strBody
End Sub
Function FileToString(ByVal strPath As String, ByVal strFile As String) As String
'requires reference to Microsoft Scripting Runtime Object Library (or late binding)
Dim ts As TextStream
Set fso = New FileSystemObject
Set ts = fso.OpenTextFile(strPath & strFile, ForReading, False, TristateUseDefault)
FileToString = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
End Function
Sub SendMail(strTo As String, strSubject As String, strHTMLBody As String, Optional strAttach As String, Optional strCC As String)
'requires reference to Microsoft Outlook X.X Object Library (or late binding)
Dim olApp As Outlook.Application
Dim olMI As Outlook.MailItem
Set olApp = CreateObject("Outlook.Application")
Set olMI = olApp.CreateItem(olMailItem)
With olMI
.To = strTo
.Subject = strSubject
.HTMLBody = strHTMLBody
If strAttach <> vbNullString Then .Attachments.Add strAttach
.Display 'using this because of security access to Outlook
'.Send
End With
End Sub
Then my reports_email_body.txt file will look like this:
<p>Hello Person,</p>
<p>The Reports file for [MONTH] FY[YEAR] has been saved in the following location:</p>
<p>[FILE PATH]</p>
<p>Best,</p>
<br>
Scott Holtzman
<br>My Address
<br>my title
<br>whatever else...
In Excel 2010 (and possibly 2007) you can add .HTMLBody to the end of your body string. For instance, use something like this:
.HTMLBody = "<br>" & strbody & .HTMLBody
' <br> is an HTML tag to turn the text into HTML
' strbody is your text from cell C9 on the mail tab
' .HTMLBody inserts your email signature
This will at least solve your signature line problem.
I am looking for a solution for the same problem: Inserting a range as a picture.