Automated mailing on VBA fails on second iteration - excel

I modified VBA code to send to X mail address X attachment. On the first iteration the code works perfectly, the mail is sent as is with the correct file. On the second iteration the code stops when attaching it's file (on objMail.Attachments.Add archivoFuente line) showing up this screen:
My code gets the main data from the first sheet which contains the mail address in the second column and the filename it's standardized from the name of the user and the file extension on the third column. With that done the filename it's attached to the directory, then I add body, subject and other things for the user to see on the mail, finally the mail is sent and I empty the strings variables to start the text iteration but then I encounter the error even with the file on the folder and with the same filename as standardized.
Sub bulkMail()
Dim outlookApp As Outlook.Application
Dim objMail As Outlook.MailItem
Dim archivoFuente, toMail, ccMail As String
Dim i, j As Integer
Dim fila As Long
fila = Cells(Rows.Count, 2).End(xlUp).Row
'On Error Resume Next
Set outlookApp = New Outlook.Application
Set objMail = outlookApp.CreateItem(olMailItem)
For i = 2 To fila
toMail = Cells(i, 2) ' & ";"
archivoFuente = "C:\Users\..." & Cells(i, 3)
objMail.Attachments.Add archivoFuente ' on the second iteration, stops here
ThisWorkbook.Save
'archivoFuente = ThisWorkbook.FullName
'objMail.Attachments.Add archivoFuente
objMail.To = toMail
objMail.Subject = "TEST"
objMail.Body = "LOREM," & vbNewLine & "IPSUM." & vbNewLine & "BYE."
objMail.Send
toMail = ""
archivoFuente = ""
Next i
MsgBox "DONE!"
End Sub
Appreciate any help!

Simple fix: move Set objMail = outlookApp.CreateItem(olMailItem) inside the loop.
You need a new mail item for each row. The code as is fails because you're trying to attach a file to an email you just sent (on the first iteration).
Other things you could fix:
Dim archivoFuente, toMail, ccMail As String - only ccMail is a String. You are looking for Dim archivoFuente As String, toMail As String, ccMail As String.
Dim i, j As Integer - should be Dim i As Long, j As Long. Excel has more rows than Integer can handle.

Related

Outlook messages read from a Windows folder are blank for certain values

Given a directory containing several thousands Outlook MSG files, I want to use Excel to read certain pieces of the message metadata and map it to a worksheet. However, VBA returns certain fields as blank, such as Sender.
I expect one attachment per email. I'm trying:
Sub SaveOlAttachments()
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim fpath As String
Dim outPath As String
Dim writeRow As Long
fpath="some\path"
outPath="some\path"
writeRow = 2
strFile = Dir(fpath & "\" & "*.msg")
Do While Len(strFile) > 0
Set Msg = objOL.Session.OpenSharedItem(fpath & "\" & strFile)
If Msg.Attachments.Count > 0 Then
For Each att In Msg.Attachments
att.SaveAsFile outPath & "\" & att.Filename
Cells(writeRow, 1).Value = Msg.Subject
Cells(writeRow, 2).Value = att.Filename
Cells(writeRow, 3).Value = Msg.SentOn
Next
End If
writeRow = writeRow + 1
strFile = Dir
Loop
End Sub
However, when looking at Msg in my Locals window, I get blank values for SenderEmailAddress, BCC, Body, Recipients.
I know this is wrong immediately upon opening any one of the emails.
It turns out that copying the files from my network drive into a folder in my Outlook inbox brought the values back to where I could see them again in Outlook.
Instead of making a workbook in Excel, I used the below method in Outlook's VBE to map the data I needed from each email into a csv that I could then save.
Sub read_drta()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.folders("my_email#address.com")
Set objFolder = objFolder.folders("Inbox")
Set objFolder = objFolder.folders("imports")
fpath = "C:\Users\Email_Tasker"
my_csv = fpath & "\data.csv"
Open my_csv For Output As #1
For Each Item In objFolder.Items
myLine = Item.Subject & "," & Item.SentOn & "," & Item.SenderEmailAddress & "," & Item.Attachments(1).FileName
Print #1, myLine
Next Item
Close #1
End Sub
The "Item" object contained everything in Outlook VBA, but oddly it still kept the same fields empty in Excel.

Impossible Excel-VBA Email Loop

If someone could help me from going insane, my mother would appreciate it.
I have a long list of email addresses (many repeats) with associated Audit Locations. Basically I need to create one email for each email address and populate said email body with a list of all the associated Audit Locations.
e.g.
Column One (Email Address) | Column 2 (Audit Location)
Yoda1#lightside.org | Coruscant
Yoda1#lightside.org | Death Star
Yoda1#lightside.org | Tatooine
Vader#Darkside.org | Death Star
Vader#Darkside.org | Coruscant
Jarjar#terrible.org | Yavin
So far I have created a CommandButton Controlled vba that takes Column One and makes it unique in a new worksheet.
Then I have another sub that creates an email for each unique email address. But I am stuck on the "If...Then" statement. Essentially, I want to add the information in Column 2 (Audit Location) if the Recipient of the email is the email address in Column One and then continue to append to the email body until the email address no longer equals the recipient email address. Any guidance would be huge.
Private Sub CommandButton1_Click()
Call MakeUnique
Call EmailOut
End Sub
Sub MakeUnique()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
'Put the data in an array
vaData = Sheet1.Range("A:A").Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheets.Add.Name = "Unique"
ActiveSheet.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
Sub EmailOut()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Dim cell As Range
For Each cell In Worksheets("Unique").Columns("a").Cells.SpecialCells(xlCellTypeConstants)
recip = cell.Value
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
For Each org In Columns("b").Cells.SpecialCells(xlCellTypeConstants)
If org.Value Like recip Then
xMailBody = "Body content" & vbNewLine & vbNewLine & _
"This is line 1" & " " & cell.Offset(0, 3).Value & vbNewLine & _
[B5] & vbNewLine & _
"This is line 2"
End If
Next org
On Error Resume Next
With xOutMail
.To = recip
.CC = ""
.BCC = ""
.Subject = cell.Offset(0, 2).Value & " " & cell.Offset(0, 3).Value & " " & "Remittance Advice"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
Next
End Sub
Based on your example I quickly wrote the following:
Option Explicit
Public Sub SendEmails()
Dim dictEmailData As Object
Dim CurrentWorkBook As Workbook
Dim WrkSht As Worksheet
Dim rngToLookUp As Range
Dim lngLastRow As Long, i As Long
Dim arryEmailData As Variant
Dim objOutlookApp As Object, objOutlookEmail As Object
Dim varKey As Variant
Application.ScreenUpdating = False
Set CurrentWorkBook = Workbooks("SomeWBName")
Set WrkSht = CurrentWorkBook.Worksheets("SomeWSName")
lngLastRow = WrkSht.Cells(WrkSht.Rows.Count, "A").End(xlUp).Row 'Find last row with data
Set rngToLookUp = WrkSht.Range("A2:B" & lngLastRow) 'set range for last row of data
arryEmailData = rngToLookUp.Value2 'Get the email data from the sheet into an array
Set dictEmailData = CreateObject("Scripting.Dictionary") 'set the dicitonary object
On Error GoTo CleanFail
For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
varKey = UCase(Trim(arryEmailData(i, 1)))
If Not dictEmailData.Exists(varKey) Then
dictEmailData(varKey) = vbNewLine & vbNewLine & Trim(arryEmailData(i, 2))
Else
dictEmailData(varKey) = dictEmailData(varKey) & vbNewLine & Trim(arryEmailData(i, 2))
End If
varKey = Empty
Next i
'for each unique key in the dicitonary
'get the corresponding item
'created in the loop above
Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object
Dim Msg As String, MailBody As String
For Each varKey In dictEmailData.Keys
Msg = dictEmailData.Item(varKey)
Set objOutlookEmail = objOutlookApp.CreateItem(0)
MailBody = "Dear Colleague," & Msg
With objOutlookEmail
.To = varKey
.Subject = "Remittance Advice"
.Body = MailBody
.Send
End With
Set objOutlookEmail = Nothing
Msg = Empty: MailBody = Empty
Next
MsgBox "All Emails have been sent", vbInformation
CleanExit:
Set objOutlookApp = Nothing
Application.ScreenUpdating = True
Exit Sub
CleanFail:
Resume CleanExit
End Sub
Add the first occurrence of a varKey = email address to the dictionary dictEmailData along with its corresponding item dictEmailData(varKey) = Email body. On the next occurrence of the email address, append to the Email body. Once the dictionary is built, loop through it and send the emails
Printing to the immediate window yields:

(VBA) Send Mails with multiple attachements, duplicate mail addresses in list

I have an Excel Sheet (let's call it "Sheet2") with let's say 200 Names in column [A] and the attachement for the Name in the column next to it [B].
There is another Sheet ("Sheet1") with the mail addresses for each Name. Important! -> This Sheet1-list is longer than the first list with the 200 Names.
It appears, that there are duplicate entries in the Sheet "Sheet2" (column [A]) but with different attachments.
I would like to only send out one mail with all necessary attachements for a user, somehow I cannot manage to do so...
The loop I got creates mails for every user in the list "Sheet1", but I only need mails for the users in list "Sheet2".
Hope to find an answer here. Thanks!
My code:
Sub Mails()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim FileName As Variant
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Set wksDest = ThisWorkbook.Worksheets("Sheet2")
Set wksSource = ThisWorkbook.Worksheets("Sheet1")
Dim LastRowSource As Long
LastRowSource = wksSource.Cells(wksSource.Rows.Count, "A").End(xlUp).Row
Dim LastRowDest As Long
LastRowDest = wksDest.Cells(wksDest.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowSource
Dim OutApp As Object
Dim OutMail As Object
Dim CC As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim TC_User As String
Dim TC_Attachement As String
Dim TC_File As String
TC_User = ""
CC = ""
TC_User = wksSource.Range("A" & i)
TC_USer_mail = wksSource.Range("B" & i)
TC_Attachement = ""
With OutMail
.To = TC_USer_mail
.BCC = ""
.Importance = 2
.Subject = "for you"
.HTMLBody = "<body style='font-family:arial;font-size:13'>" & _
"<b>############################################<br>" & _
"Diese Mail wurde automatisch erstellt<br>" & _
"############################################</b><br><br>" & _
"Hallo " & TC_User & "," & "<br><br>" & _
"blabla.<br><br>" & _
"</body>"
For g = 2 To LastRowDest
If wksDest.Range("A" & g) = TC_User Then
TC_File = wksDest.Range("B" & g)
TC_Attachement = "C:\Users\bla\Documents" & "\" & TC_File
If Dir(TC_Attachement) <> "" Then
.Attachments.Add TC_Attachement
'GoTo nextvar
Else
End If
End If
'nextvar:
Next g
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Ende:
End Sub
Ok, I found my solution. Maybe it's not that elegant, but it works.
I wrote this code right before the "With OutMail" - Statement.
This will check whether the User-ID from the mail database is actually in the list with the receipients, if not this User-ID will be skiped.
For j = 2 To LastRowSource
If TC_User = wksDest.Range("A" & j) Then
GoTo weiter_j
End If
Next j
GoTo Ende:
weiter_j:
So there are a unknown number of attachments for each name (ie., not necessarily one) and you need them grouped together? (and it sounds like a one-time thing?)
Just copy and paste one table below the other so that the name columns lines up, and then simply go Sort the list (Data → Sort) and then the names will be grouped together.
From here there are a few ways you could arrange the list to automate the sending process. By the sounds of it, most of the names have one attachment, so send those like you were going to, and send the additional ones manually.
Handling a one-off task manually can often be quicker and easier than trying to automate it.
If this is going to be a recurring task, then try to find a better way to organize the source data (like a simple Access table.)

Create Email from Excel by Row with Attachments Based on Recipients Matching in Each Row

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.

Outlook / Excel integration ?

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

Resources