The below code sends emails from my Excel file.
However I do not know where to add the .sentonbehalfof line to send from a specific shared mailbox that I have permission to send from.
Sub send_email()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Statements")
Dim OA As Object
Dim msg As Object
Set OA = CreateObject("Outlook.Application")
Dim each_row As Integer
Dim last_row As Integer
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
For each_row = 2 To last_row
Set msg = OA.createitem(0)
msg.To = sh.Range("A" & each_row).Value
first_name = sh.Range("B" & each_row).Value
last_name = sh.Range("C" & each_row).Value
msg.cc = sh.Range("D" & each_row).Value
msg.Subject = sh.Range("E" & each_row).Value
msg.body = sh.Range("F" & each_row).Value
date_to_send = sh.Range("H" & each_row).Value
date_to_send = Format(date_to_send, "dd/mm/yyyy")
Status = sh.Range("I" & each_row).Value
current_date = Format(Date, "dd/mm/yyyy")
If date_to_send = current_date Then
If sh.Range("G" & each_row).Value <> "" Then
msg.attachments.Add sh.Range("G" & each_row).Value
Cells(each_row, 9).Value = "Sent"
Content = Replace(msg.body, "<>", first_name + " " + last_name)
msg.body = Content
msg.send
Else
Cells(each_row, 9).Value = "Sent"
Content = Replace(msg.body, "<>", first_name + " " + last_name)
msg.body = Content
msg.send
End If
End If
Next each_row
End Sub
Try adding
msg.SentOnBehalfOfName = "Your shared email address"
above this line
msg.cc = sh.Range("D" & each_row).Value
It worked for me!
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
Managed to get this sending using Excel with SMTP.
When sending one e-mail at a time, the first one has the signature displayed where it should be.
Second e-mail sent has the signature but adds the signature as an attachment.
Third e-mail sent has the signature but adds the signature as an attachment twice, and it will repeat the the cycle adding more signature images as attachments.
TLDR:
1 e-mail sent = 0 attachment
2 e-mails sent = 1 attachment
3 e-mails sent = 2 attachments
I don't want any attached files.
Sub SendMail()
Set MyEmail = CreateObject("CDO.Message")
Path = "C:\Users\Users1\Desktop\Signature\"
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
Dim nDateTime As Date, oDateTime As Date
nDateTime = Now
oDateTime = nDateTime - 3
Dim last_row As Integer
last_row = Application.CountA(sh.Range("A:A"))
For i = 2 To last_row
Set emailConfig = MyEmail.Configuration
With MyEmail
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername")
= redacted
emailConfig.Fields.Update
MyEmail.Configuration.Fields.Update
End With
mail_body_message = sh2.Range("D2")
serial_number = sh.Range("A" & i).Value
mail_body_message = Replace(mail_body_message, "replace_serial_here", serial_number)
Attachment = Path + Filename
signaturelogo = "userSignature.png"
With MyEmail
Attachment = Path + Filename
signaturelogo = "userSignature.png"
Path = "C:\Users\Users1\Desktop\Signature\"
.Subject = "Hello there (HTTPS) Serial: " & serial_number
.From = "redacted"
.To = sh.Range("B" & i).Value
.HTMLBody = mail_body_message
.Attachments.Add Path & signaturelogo, 0
End With
If sh.Range("C" & i).Value <= oDateTime Then
MyEmail.Send
End If
Next i
End Sub
Because you are re-using the same object just attach the logo once at the start.
Option Explicit
Sub SendMyMail()
Const LOGO = "C:\Users\Users1\Desktop\Signature\userSignature.png"
Const DAYS = 3
Const SCHEMA = "http://schemas.microsoft.com/cdo/configuration/"
' configure email
Dim MyEmail As Object
Set MyEmail = CreateObject("CDO.Message")
With MyEmail
With .Configuration.Fields
.Item(SCHEMA & "sendusing") = 2
.Item(SCHEMA & "smtpserver") = "smtp.#.com"
.Item(SCHEMA & "smtpserverport") = 465
.Item(SCHEMA & "smtpauthenticate") = 1
.Item(SCHEMA & "sendusername") = "###"
.Item(SCHEMA & "sendpassword") = "#"
.Item(SCHEMA & "smtpusessl") = 1
.Update
End With
' add logo
.AddAttachment LOGO
End With
Dim sh As Worksheet, sh2 As Worksheet
Dim serialno As String, n As Long, i As Long, last_row As Long
Set sh = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
With sh
last_row = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To last_row
If sh.Range("C" & i).Value <= Now - DAYS Then
serialno = sh.Range("A" & i).Value
With MyEmail
.Subject = "Hello there (HTTPS) Serial: " & serialno
.From = "redacted"
.To = sh.Range("B" & i).Value
.HTMLBody = Replace(sh2.Range("D2"), "replace_serial_here", serialno)
' send
On Error Resume Next
.Send
If Err.Number = 0 Then
n = n + 1
Else
MsgBox Err.Description, vbExclamation, "Error Row " & i
End If
On Error GoTo 0
End With
Else
'Debug.Print "Skipped row " & i & " = " & sh.Range("C" & i)
End If
Next
MsgBox n & " emails sent", vbInformation
End Sub
Ended up removing .Attachments.Add Path & signaturelogo, 0
For .HTMLBody = mail_body_message
Changed to below, (the fix)
.HTMLBody = mail_body_message & " "
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 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