I am trying to add two attachments to an email.
Below is the code I'm using.
My msgbox pops up saying emails sent but the attachments are not attaching.
The paths where I identify where the files live are in columns F & G.
Sub Send_Multiple_Emails_Match45()
Dim sh As Worksheet, Issent As Boolean, i As Long, last_row As Long
Set sh = ThisWorkbook.Sheets("Match 45 Vendors Emails")
Dim OA As Object
Dim msg As Object
Set OA = CreateObject("Outlook.Application")
last_row = sh.Range("B" & Rows.Count).End(xlUp).Row
For i = 4 To last_row
Set msg = OA.createitem(0)
msg.To = sh.Range("B" & i).Value
msg.cc = sh.Range("C" & i).Value
msg.Subject = sh.Range("D" & i).Value
msg.body = sh.Range("E" & i).Value
If sh.Range("F" & "G" & i).Value <> "" Then
If Dir(sh.Range("F" & "G" & i).Value) <> "" Then
msg.Attachments.Add sh.Range("F" & "G" & i).Value
Else
Range("H" & i).Value = "Wrong attachment path"
GoTo NextMail
End If
End If
On Error Resume Next
msg.send
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
Issent = False
Else
On Error GoTo 0
Issent = True
End If
If Issent = True Then
Range("H" & i).Value = "Sent"
Else
Range("H" & i).Value = "Not Sent"
End If
NextMail:
Set msg = Nothing
Next i
MsgBox "Mails Sent"
End Sub
"F:G" & i is incorrect. You need to specify the row for both F and G. The code will not concatenate the two value for you. It would be best to add a helper variable for the filename. This will help make it easier to test your code.
Hi Guys i solve this by adding additional if condition for another attachment. below is my code for you. Enjoy the code
Sub Send_Mails()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Send_Mails")
Dim i As Integer
Dim OA As Object
Dim msg As Object
Set OA = CreateObject("outlook.application")
Dim last_row As Integer
last_row = Application.CountA(sh.Range("A:A"))
For i = 2 To last_row
Set msg = OA.createitem(0)
msg.to = sh.Range("A" & i).Value
msg.cc = sh.Range("B" & i).Value
msg.Subject = sh.Range("C" & i).Value
msg.body = sh.Range("D" & i).Value
If sh.Range("E" & i).Value <> "" Then
msg.attachments.Add sh.Range("E" & i).Value
End If
If sh.Range("F" & i).Value <> "" Then
msg.attachments.Add sh.Range("F" & i).Value
End If
msg.send
sh.Range("g" & i).Value = "Sent"
Next i
MsgBox "All the mails have been sent successfully, Thank u Syed"
End Sub
I figured out the problem, in case in the future anyone needs help with this. This is the updated code where it attaches two files and tells me if each attachment was sent or not sent or there was a wrong path.
Dim sh As Worksheet, Issent As Boolean, i As Long, last_row As Long
Set sh = ThisWorkbook.Sheets("Match 45 Vendors Emails")
Dim OA As Object
Dim msg As Object
Dim rngAttach1 As Range
Dim rngAttach2 As Range
Set OA = CreateObject("Outlook.Application")
last_row = sh.Range("B" & Rows.Count).End(xlUp).Row
Set rngAttach1 = sh.Range("F:F")
Set rngAttach2 = sh.Range("G:G")
For i = 4 To last_row
Set msg = OA.createitem(0)
msg.To = sh.Range("B" & i).Value
msg.cc = sh.Range("C" & i).Value
msg.Subject = sh.Range("D" & i).Value
msg.body = sh.Range("E" & i).Value
If rngAttach1(i).Value <> "" Then
If Dir(rngAttach1(i).Value) <> "" Then
msg.Attachments.Add rngAttach1(i).Value
Else
Range("H" & i).Value = "Wrong attachment path"
GoTo NextMail
End If
End If
If rngAttach2(i).Value <> "" Then
If Dir(rngAttach2(i).Value) <> "" Then
Attachments.Add rngAttach2(i).Value
Else
Range("I" & i).Value = "Wrong attachment path"
GoTo NextMail
End If
End If
On Error Resume Next
msg.send
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
Issent = False
Else
On Error GoTo 0
Issent = True
End If
If Issent = True Then
Range("H" & i).Value = "Sent"
Else
Range("H" & i).Value = "Not Sent"
End If
If Issent = True Then
Range("I" & i).Value = "Sent"
Else
Range("I" & i).Value = "Not Sent"
End If
NextMail:
Set msg = Nothing
Next i
MsgBox "Mails Sent"
End Sub
Related
I have made a code in excel which creates a mail using excel envelop. But this code creates a new email, instead, I want to reply to a particular mail which is saved in path ("C:\Users\dell\Desktop\me\Untitled (1).msg" ) so i want to write the mentioned path in cell in the excel file . Where should I make changes in my code? Please Help!!
Option Explicit
Sub Send_Mails()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Send_Mails")
Dim i As Integer
Dim OA As Object
Dim msg As Object
Set OA = CreateObject("outlook.application")
Dim last_row As Integer
last_row = Application.CountA(sh.Range("A:A"))
For i = 2 To last_row
Set msg = OA.CreateItem(0)
msg.to = sh.Range("A" & i).Value
msg.cc = sh.Range("B" & i).Value
msg.Subject = sh.Range("C" & i).Value
msg.body = sh.Range("D" & i).Value
If sh.Range("E" & i).Value <> "" Then
msg.attachments.Add sh.Range("E" & i).Value
End If
msg.Send
sh.Range("F" & i).Value = "Sent"
Next i
MsgBox "All the mails have been sent successfully"
End Sub
I found this code to send bulk emails to multiple recipients by Outlook with Excel VBA.
What should I add to it to send two attachments not one?
Sub Send_Multiple_Email()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet3")
Dim oa As Object
Dim msg As Object
Set oa = CreateObject("outlook.Application")
Dim i As Integer
Dim last_row As Integer
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
For i = 2 To last_row
Set msg = oa.createitem(0)
msg.to = sh.Range("A" & i).Value
msg.Subject = sh.Range("B" & i).Value
msg.body = sh.Range("c" & i).Value
If sh.Range("D" & i).Value <> "" Then
msg.attachments.Add sh.Range("D" & i).Value
End If
msg.display
Next i
MsgBox "mails sent"
End Sub
Add information to E2 till the end row and add there what you want to attach like , what is done with D.
And you can add more columns f G H I J K .. with more attachments
If the cell is empty, no attachment is added
If sh.Range("D" & i).Value <> "" Then
msg.attachments.Add sh.Range("D" & i).Value
End If
If sh.Range("E" & i).Value <> "" Then
msg.attachments.Add sh.Range("E" & i).Value
End If
msg.display
Trying to send emails using VBA however it keeps sending from my personal email address despite best efforts. Please can someone advise how to send from secondary email address?
Sub Send_Mail()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Send_Mail")
Dim I As Integer
Dim OA As Object
Dim msg As Object
Set OA = CreateObject("outlook.application")
Set OutAccount = OA.Session.Accounts.Item(2)
Dim last_row As Integer
last_row = Application.CountA(sh.Range("A:A"))
For I = 2 To last_row
Set msg = OA.CreateItem(0)
msg.SendUsingAccount = OutAccount
msg.To = sh.Range("B" & I).Value
msg.cc = sh.Range("D" & I).Value
msg.Subject = sh.Range("E" & I).Value
msg.body = sh.Range("F" & I).Value
If sh.Range("G" & I).Value <> "" Then
msg.attachments.Add sh.Range("G" & I).Value
End If
msg.send
sh.Range("H" & I).Value = "Sent"
Next I
MsgBox "All emails sent successfully"
End Sub
Thank you!
You can use .From to set the email account that you want to send it from.
strFrom = Name & "<" & Email & ">"
msg.From = strFrom
I'm using the below code to tell me when emails have been sent and display the text "sent" so I know there were no errors. But I was testing the code and I use a vlookup to display emails once I add the vendor name. My goal is to not let the macro debug and to let it keep going on to the next but at the same time let me know there was an error on one row either because that vendor did not have an email listed and I need to fill an email in. When I listed the vendors I left a cell blank to test code. Even tho I have valid emails and those emails sent the VBA displays "Not sent" to the ones that were sent out. Since the macro could not find an email due to one cell being blank it debugged and next to all the valid emails the text "Not sent" populates. What am I missing or doing wrong? I just want to avoid debugs to tell me there is an error and just tell me that one row was "not sent" and to just keep sending the rest and populate those that do send with a "sent" text.
Sub Send_Multiple_Emails()
dim sh as worksheet
set sh = thisworkbook.sheets("sheet1") <-- rename to what the tabs name is
dim OA as Object
Dim msg As object
set OA = createobject("Outlook.Application")
Dim i as integer
dim last_row As Integer
last_row = application.worksheetfunction.counta(sh.range("B:B"))
for i = 2 To last_row
Set msg = OA.createitem(0)
msg.to = sh.Range("B" & i).Value
msg.cc = sh.Range("C" & i).Value
msg.subject = sh.range("D" & i ).Value
msg.body = sh.Range("E" & i).Value
if sh.Range("F" & i).Value <> "" Then
msg.attachments.add sh.range("F" & i).Value
End If
msg.send
**If Issent = True Then
Range("G" & i).Value = "Sent"
Else
Range("G" & i).Value = "Not Sent"
End If**
next i
msgbox "Mails Sent"
End Sub
Try replacing of this code part, please:
msg.send
If Issent = True Then
Range("G" & i).Value = "Sent"
Else
Range("G" & i).Value = "Not Sent"
End If
with this one:
Dim Issent As Boolean
On Error Resume Next
msg.send
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
Issent = False
Else
On Error GoTo 0
Issent = True
End If
If Issent = True Then
Range("G" & i).Value = "Sent"
Else
Range("G" & i).Value = "Not Sent"
End If
Edited:
I do not think that the above inserted lines can bother your code smooth operation. Even if not this was the question, please try the next adapted code. It also deals with eventual wrong paths to documents to be attached:
Add a reference to Microsoft Outlook ... Object Library. Being in VBE (Visual Basic Editor), go: Tools (menu) -> References... Scroll down until you find the above mentioned reference. Check it and press OK.
Copy the next code instead of yours, or near it (I will change the Sub name) and run it:
Sub Send_Multiple_Emails_bis()
Dim sh As Worksheet, Issent As Boolean, i As Long, last_row As Long
Dim OA As New Outlook.Application, msg As Outlook.MailItem
Set sh = ActiveSheet ' ThisWorkbook.Sheets("sheet1")
last_row = sh.Range("B" & Rows.count).End(xlUp).row
For i = 2 To last_row
Set msg = OA.CreateItem(0)
With msg
.To = sh.Range("B" & i).Value
.cc = sh.Range("C" & i).Value
.Subject = sh.Range("D" & i).Value
.body = sh.Range("E" & i).Value
'.display 'un-comment if you want to see each mail sending window
End With
If sh.Range("F" & i).Value <> "" Then
If Dir(sh.Range("F" & i).Value) <> "" Then
msg.Attachments.aDD sh.Range("F" & i).Value
Else
Range("G" & i).Value = "Wrong attachment path"
GoTo NextMail
End If
End If
On Error Resume Next
msg.send
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
Issent = False
Else
On Error GoTo 0
Issent = True
End If
If Issent = True Then
Range("G" & i).Value = "Sent"
Else
Range("G" & i).Value = "Not Sent"
End If
NextMail:
Set msg = Nothing
Next i
MsgBox "Mails Sent"
End Sub
I would like to receive some feedback regarding its behavior...
I have to rewrite code which works on Win but doesn't on Mac.
When I run the code I got error:
Run-time error '429': ActiveX component can't create object
at line: Set iMsg = CreateObject("CDO.Message").
I already Google thru Internet.
Dim msgbox1
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim xRange As Range
Dim xCell As Long
Dim xCount As Long
Dim i As Long
' First run the checks that all needed info is there
' before we display the form
If frmEmail.fldSubject.TextLength < 5 Then
MsgBox "Please fill in a subject for the email", vbExclamation
Exit Sub
End If
If frmEmail.fldEmailBox.TextLength < 5 Then
MsgBox "Please put some information in the email body", vbExclamation
Exit Sub
End If
msgbox1 = MsgBox("Are you sure you want to email all selected users in this Directorate: " & _
vbCrLf & vbCrLf & Worksheets("Contact Info").Cells(12, 4), vbOKCancel + vbExclamation, "Attention! Attention!! Attention!!!")
If msgbox1 = vbOK Then
msgbox1 = MsgBox("Are you sure you want to email all users using the following SMTP server: " & _
vbCrLf & vbCrLf & Worksheets("ADMIN").Cells(25, 3), vbOKCancel + vbExclamation, "Attention! Attention!! Attention!!!")
If msgbox1 = vbOK Then
Rem msgbox1 = MsgBox("Place holder for email function")
'Here we go with emailing
Sheets("Users Details Form").Activate
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Trim(Worksheets("ADMIN").Range("c24").Value)
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
Set xRange = Worksheets("Users Details Form").Range("A1:A65536")
xCount = Application.CountIf(xRange, "x")
For i = 1 To xCount
strbody = frmEmail.fldEmailBox.Text
xCell = xRange.Find("x").Row
strbody = Replace(strbody, "%%user%%", Range("B" & xCell) & " " & Range("C" & xCell))
strbody = Replace(strbody, "%%username%%", Range("F" & xCell))
strbody = Replace(strbody, "%%password%%", Range("G" & xCell))
strbody = Replace(strbody, "%%role%%", Range("H" & xCell))
On Error Resume Next
With iMsg
Set .Configuration = iConf
.To = Range("D" & xCell).Value
.CC = ""
.BCC = ""
.From = "" & Worksheets("ADMIN").Range("C22").Value & "<" & Worksheets("ADMIN").Range("C23").Value & ">"
.Subject = frmEmail.fldSubject.Text
.TextBody = strbody
.Send
End With
If Err.Number <> 0 Then
Range("A" & xCell).Value = "F"
Range("A" & xCell).DisplayFormat.Interior.ColorIndex = iRed
Else
If frmEmail.btnNewUserEmail Then
Range("A" & xCell).Value = "N"
Range("A" & xCell).DisplayFormat.Interior.ColorIndex = Range("A1").DisplayFormat.Interior.ColorIndex
End If
If frmEmail.btnExistingUserEmail Then
Range("A" & xCell).Value = "E"
Range("A" & xCell).DisplayFormat.Interior.ColorIndex = Range("A1").DisplayFormat.Interior.ColorIndex
End If
If frmEmail.btnCustom Then
Range("A" & xCell).Value = "C"
Range("A" & xCell).DisplayFormat.Interior.ColorIndex = Range("A1").DisplayFormat.Interior.ColorIndex
End If
End If
On Error GoTo 0
Next
End If
End If
End
Check your references by going to Tools->References in the VBA editor, make sure none are marked as "missing".
If no references are missing, then typically this is due to a corrupt workbook.
The solution is to create a new workbook and copy your VBA code into it.
This means you will need to recreate any worksheets, formatting etc that might be in your corrupted workbook.