Sending multiple and and different attachments through VBA and Outlook - vba

I'm by no means an expert and I want to send the multiple and different attachments (e.g. Person1 receives BOTH attch.1 and attach.2; Person2 receives attch.3 and attch. 5 etc).
My code:
Sub SendEmail(what_address As String, subject_line As String, mail_body As String)
Dim dlApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = what_address
olMail.Subject = subject_line
olMail.Body = mail_body
olMail.Send
End Sub
Sub SendMassEmail()
Dim mail_body_message As String
Dim title As String
row_number = 1
Do
DoEvents
row_number = row_number + 1
mail_body_message = Sheet1.Range("D2")
title = Sheet1.Range("B" & row_number)
mail_body_message = Replace(mail_body_message, "replace_name_here", title)
Call SendEmail(Sheet1.Range("A" & row_number), "This is a test", mail_body_message)
Loop Until row_number = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
End Sub

I think your code requires some work but the snippet below should help with adding multiple attachments. I have tried to add annotations that might be helpful.
Please note that the full path for each attachment must be known.
For example:
C:\TestFolder\TestSubfolder\TestFile.txt
You should be able to use the same looping concept to traverse across columns to handle multiple emails. It would be difficult to suggest the exact looping to be used without knowing the structure of your spreadsheet.
Sub GenerateEmails()
Dim OutApp As Object
Dim OutMail As Object
Dim myRange As Range
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = Outlook.Application.CreateItem(olMailItem)
'This will only generate a single email with multiple attachments.
'You will need another loop or something similar to process multiple emails the loop could
'be similar to the loop below that use offset to go down rows but instead
'you will offest across columns
With OutMail
'I have used hard coded cell ranges to define the values but you can use other
'methods.
.Subject = Range("A1").Value
.To = Range("A2").Value
.CC = Range("A3").Value
.Body = Range("A4").Value
'This is where you list of attachments will start
Set myRange = Range("A5")
'Keep going down one cell until no more attachment values are provided
Do Until myRange.Value = ""
'The value here needs to be the full attachment path including file name and extension
.Attachments.Add (myRange.Value)
'Set the range to be the next cell down
Set myRange = myRange.Offset(1, 0)
Loop
'This displays the email without sending.
.Display
'Once the code is correct you can use the .Send instead to actually send the emails.
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Related

Excel Add-In/Macro to send mass email

So I have a task to automate. We have a protected spreadsheet (users only have 'read' access to) that get's updated by admins from time to time in order to add/remove users from a paid subscription mailing list. I'm trying to make the process of sending these emails out simpler to speed up the process and eliminate the potential of human error getting involved.
So email addresses are listed under the 'C' column, lists can be as long as in the tens of thousands, or it may only be 1 or 2. The workbook has several sheets that specify the data set that the subscribers subscribe to. So I put something together that worked
'This function will grab the information the macro asks for
Function RangeToString(ByVal myRange As Range) As String
RangeToString = ""
If Not myRange Is Nothing Then
Dim myCell As Range
For Each myCell In myRange
RangeToString = RangeToString & "; " & myCell.Value
Next myCell
'Remove extra comma
RangeToString = Right(RangeToString, Len(RangeToString) - 1)
End If
End Function
Sub EmailTest1()
Dim OutApp As Object
Dim OutMail As Object
Dim strSubject As String
Dim myString As String
Dim rng As Range
Dim strCopy As String
'Sheet1 would be Sheet2/3/4/etc. depending on what list we're pulling from.
Set rng = Sheet1.Range("c2:c90000")
myString = RangeToString(rng)
strCopy = "internal.private#email.com; internal1.private#email.co;
internal2.private#email.co"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("\\Domain\EmailTemplate\oft\test1.oft")
On Error Resume Next
With OutMail
.BCC = myString + strCopy
.Display
'.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Then I had repeats of the second part that specify the different lists/email templates as individual macros within the Add-In. (.Send will not be commented out when I do finally get the results I want).
So this works perfectly, when the macro specifies and embeds a workbook into itself. So for a while, I thought that it was pulling everything fine, until I used a blank workbook, and it still pulled the data I wanted, so I checked and double checked that there was no reference to the original workbook, and then I discovered that the workbook was built into the macro. I tried rebuilding the add-in using the same code, and it just doesn't work.
So my question is, is there a way to build this macro so that it'll work on any active workbook? I imagine there has got to be a simple thing to click on or something else I'm overlooking. I'm working with Excel 2016.
first of all, why didn't you just make a macro-embedded template where you have a form that connects any active workbook.
dim ws as workbook
set ws=activeworkbook
so basically make a form that is modular then on a label click event put that code.
then an execute button so that you can determine if you connect the right workbook before you start the email sending automation
I think you can adapt this to suit your needs.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail6.htm

Cannot run my codes for sending email in other machine

I am helping my friend to develop her codes using VBA. I have successfully run these codes in my laptop yet she is encountering errors when we copy the codes to her machine.
Here's my code:
Sub Test()
Call sendingEmailWithChecklist("Book1.xlsm")
End Sub
Sub sendingEmailWithChecklist(workbookName As String)
Dim recipient As String
Dim cc As String
Dim subject As String
Dim body As Range
Dim greetings As String
Dim message As String
Dim signature As String
Dim ebody As String
Dim olApp As Outlook.Application
Dim olInsp As Outlook.Inspector
Dim wdDoc As Word.Document
Dim olEmail As Outlook.MailItem
Dim worksheetName As String
Dim content As Range
Set olApp = New Outlook.Application
Set olEmail = olApp.CreateItem(olMailItem)
Sheet2.Activate
recipient = Range("B3").Value
cc = Range("B4").Value
subject = Range("B5").Value
greetings = Range("B6").Value
message = Range("B7").Value
ebody = greetings & vbNewLine & vbNewLine & message & vbNewLine
signature = Range("B8").Value
'Workbooks(workbookName).Activate
worksheetName = "Sheet1"
With olEmail
.Display
.To = recipient
.cc = cc
.subject = subject
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Workbooks(workbookName).Worksheets(worksheetName).Activate
Workbooks(workbookName).Worksheets(worksheetName).Cells.Copy
'Range("A1:F17").Select
'Selection.Copy
End With
With olEmail
.Display
wdDoc.Range(1, 1).Paste
wdDoc.Range.InsertBefore ebody
'.Send
End With
End Sub
wdDoc.Range(1,1).Paste was her error. We have both declared same references from tools yet the error is still on this line. What could be the possible error why it doesn't run on her machine?
PS. She doesn't want to use HTMLbody.
Instead of
wdDoc.Range(1, 1).Paste
Try
wdDoc.Range.Paste
If you want to further control the way you paste your data in the body of mail you may want to use the Word Selection object (expression) instead of Range. Something like:
wdDoc.Application.Selection.PasteAndFormat wdFormatOriginalFormatting
Above paste the copied item with its original formatting. You may select other PasteAndFormat options depending on your expected outcome.

Email Multiple Recipients VBA Error

Looking for help with sending emails to a list of people. My code has a simple loop and grabs the value each time through of where to send the email. While testing, the first email will always get sent. After that, the 2nd time through I get error on ".To"
Run-time error - '-2147221238 (8004010a):
The item has been moved or deleted.
This is puzzling to me because the code does accurately grab the next email value?
The emails need to be sent one by one, instead of adding the recipients to a list of bcc. Is this possible with VBA? Thanks in advance!
Sub TestingAgain()
'Setting up the Excel variables.
Dim outApp As Object
Dim outMailItem As Object
Dim iCounter As Integer
Dim sDest As String
Dim sName As String
'Create the Outlook application and the empty email.
Set outApp = CreateObject("Outlook.Application")
Set outMailItem = outApp.CreateItem(0)
With outMailItem
sDest = ""
For i = 2 To WorksheetFunction.CountA(Columns(1))
If i <> "" Then
'Grab first name and email
sDest = Cells(i, 5).Value
sName = Cells(i, 1).Value
'Send each email
.To = sDest
.Subject = "FYI"
.htmlbody = "Some stuff"
.Send
Else
MsgBox ("Error")
End If
Next i
End With
'Clean up the Outlook application.
Set outMailItem = Nothing
Set outApp = Nothing
End Sub
When you send the e-mail, the mailItem instance is done and not available anymore. Refactor your code like :
Sub TestingAgain()
'Setting up the Excel variables.
Dim outApp As Object
Dim outMailItem As Object
Dim iCounter As Integer
Dim sDest As String
Dim sName As String
'Create the Outlook application and the empty email.
Set outApp = CreateObject("Outlook.Application")
sDest = ""
For i = 2 To WorksheetFunction.CountA(Columns(1))
If i <> "" Then
'/ Create the mail item instance.
Set outMailItem = outApp.CreateItem(0)
With outMailItem
'Grab first name and email
sDest = Cells(i, 5).Value
sName = Cells(i, 1).Value
'Send each email
.To = sDest
.Subject = "FYI"
.htmlbody = "Some stuff"
.send
'/ Once sent, mail item is no more available.
End With
Else
MsgBox ("Error")
End If
Next
'Clean up the Outlook application.
Set outMailItem = Nothing
Set outApp = Nothing
End Sub

Issue with reading data from specific cells in Excel VBA

I'm attempting to send an email containing an Excel workbook from within the document using the built in VB macros. There is data in one of the sheets, which are relevant to sending the email (Subject, recipient etc). I am trying to access these using the Sheets object like so
Sub Button1_Click()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim cell As Object
Dim count As Integer
count = 0
For Each cell In Selection
count = count + 1
Next cell
If count <> 1 Then
MsgBox ("You must select exactly one cell, which shall be the e-mail address of the recipient")
Wscript.Quit
Else
recipient = ActiveCell.Value
End If
On Error Resume Next
With OutMail
.To = recipient
.CC = ""
.BCC = ""
.SentOnBehalfOfName = This.Sheets("MailContent").Range("A2").Value
.Subject = This.Sheets("MailContent").Range("A4").Value
.Body = This.Sheets("MailContent").Range("A6").Value & vbNewLine & This.Sheets("MailContent").Range("A7") & vbNewLine & vbNewLine & "Næste gang senest den " + This.Sheets("MailContent").Range("A10") & vbNewLine & vbNewLine & This.Sheets("MailContent").Range("A8")
.Attachments.Add ActiveWorkbook.Name
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I've also been able to replicate the same error with this small snippet
Sub Button1_Click()
Dim subjectCell As Range
subjectCell = This.Sheets("MailContent").Range("A2")
MsgBox (subjectCell.Value)
End Sub
I've tried using WorkSheets, Sheets, ActiveWorkbook to access the cells, but I'm sure it's just a problem of how I assign the data, since I'm not used to languages with syntax like VB. Any help is much appreciated, and if you need more info leave me a comment.
You need to use the 'Set' keyword to assign to a range.
Set subjectCell = ThisWorkbook.Sheets("MailContent").Range("A2")
This still catches me out on an irritatingly regular basis.

multiple recipients email mismatch in VBA

I am trying to add multiple recipients' emails that are on a range of cells.
I am able to select the range of emails on the sheet.
However, I kept getting this mismatch error and I have no idea how to solve it.
I have been looking around for solutions and did the same steps.
Please pardon me, i am new to VBA.
I would very much appreciate your help.
My code is below,
Private Sub CommandButton1_Click()
Dim olapp As Object
Dim olmail As Object
Dim recip As String
lastr = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
'this is for the range of data to be copied on the body but have yet to do it
lastr2 = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 7).End(xlUp).Row
recip = ThisWorkbook.Sheets("Sheet1").Range("G3:G" & lastr2).Value
'mismatch after this step
Set olapp = CreateObject("Outlook.Application")
Set olmail = olapp.CreateItem(0)
With MItem
.to = recip
.Subject = "hello"
.Body = "whats up"
.display
End With
Any idea why is this happening?
You're trying to assign an array (a range of multiple cells is an Array) to a string variable. WIthout testing, I know you can resolve this with a For Each loop, as Jaycal's comment suggested:
Dim cl as Range
For each cl in ThisWorkbook.Sheets("Sheet1").Range("G3:G" & lastr2).Cells
recip = recip & ";" & cl.Value
Next
But you could simplify by using the string Join function. The Join function effectively performs this loop on an array of strings, so it saves you an unnecessary loop. I modify to use a range variable for legibility:
Dim sendRange as Range
Set sendRange = ThisWorkbook.Sheets("Sheet1").Range("G3:G" & lastr2)
recip = Join(Application.Transpose(sendRange.Value), ";")
Whichever method you use, you will be able to use the same With block.
With MItem
.to = recip
.Subject = "hello"
.Body = "whats up"
.display
End With