Send CDO emails from any client/server with Excel - vba

I'm trying to set up an .xlsm workbook to send emails to different email addresses with specific data from the spreadsheet.
I want that it doesn't matter what email client or server is used.
I'm currently trying to get it working for hotmail.
Here's my code:
Sub Button1_Click()
Dim CDO_Mail As Object
Dim CDO_Config As Object
Dim SMTP_Config As Variant
Dim strSubject As String
Dim strFrom As String
Dim strTo As String
Dim strCc As String
Dim strBcc As String
Dim strBody As String
strSubject = "SUBJECT"
strFrom = "******#hotmail.com"
strTo = "************#hotmail.com"
strCc = ""
strBcc = ""
strBody = "BODY TEXT HERE"
Set CDO_Mail = CreateObject("CDO.Message")
Set CDO_Config = CreateObject("CDO.Configuration")
CDO_Config.Load -1
Set SMTP_Config = CDO_Config.Fields
With SMTP_Config
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.live.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "******#hotmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With CDO_Mail
Set .Configuration = CDO_Config
End With
CDO_Mail.Subject = strSubject
CDO_Mail.From = strFrom
CDO_Mail.To = strTo
CDO_Mail.TextBody = strBody
CDO_Mail.CC = strCc
CDO_Mail.BCC = strBcc
CDO_Mail.Send
MsgBox ("Emails have been sent.")
End Sub
I get the following error:
Run-time error '-2147220975 (80040211)'
The message could not be sent to the SMTP server, The transport error code was 0x80040217. The server response was not available.
I've also tried changing the port from 25 to 587 and I get the error:
The transport failed to connect to the server.
I also initially didn't have the 2 following lines in there:
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
And when they weren't there I got the error:
The server rejected the sender address. The server response was: 530 5.7.0 Must issue a STARTTLS command first.

Related

How to get the e-mail addresses in the CC field?

I found code in How to get the sender’s email address from one or more emails in Outlook?.
I need to get the e-mail addresses of the CC field as well.
Sub GetSmtpAddressOfSelectionEmail()
Dim xExplorer As Explorer
Dim xSelection As Selection
Dim xItem As Object
Dim xMail As MailItem
Dim xAddress As String
Dim xFldObj As Object
Dim FilePath As String
Dim xFSO As Scripting.FileSystemObject
On Error Resume Next
Set xExplorer = Application.ActiveExplorer
Set xSelection = xExplorer.Selection
For Each xItem In xSelection
If xItem.Class = olMail Then
Set xMail = xItem
xAddress = xAddress & VBA.vbCrLf & " " & GetSmtpAddress(xMail)
End If
Next
If MsgBox("Sender SMTP Address is: " & xAddress & vbCrLf & vbCrLf & "Do you want to export the address list to a txt file? ", vbYesNo, "Kutools for Outlook") = vbYes Then
Set xFldObj = CreateObject("Shell.Application").BrowseforFolder(0, "Select a Folder", 0, 16)
Set xFSO = New Scripting.FileSystemObject
If xFldObj Is Nothing Then Exit Sub
FilePath = xFldObj.Items.Item.Path & "\Address.txt"
Close #1
Open FilePath For Output As #1
Print #1, "Sender SMTP Address is: " & xAddress
Close #1
Set xFSO = Nothing
Set xFldObj = Nothing
MsgBox "Address list has been exported to:" & FilePath, vbOKOnly + vbInformation, "Kutools for Outlook"
End If
End Sub
Function GetSmtpAddress(Mail As MailItem)
Dim xNameSpace As Outlook.NameSpace
Dim xEntryID As String
Dim xAddressEntry As AddressEntry
Dim PR_SENT_REPRESENTING_ENTRYID As String
Dim PR_SMTP_ADDRESS As String
Dim xExchangeUser As exchangeUser
On Error Resume Next
GetSmtpAddress = ""
Set xNameSpace = Application.Session
If Mail.sender.Type <> "EX" Then
GetSmtpAddress = Mail.sender.Address
Else
PR_SENT_REPRESENTING_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x00410102"
xEntryID = Mail.PropertyAccessor.BinaryToString(Mail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_ENTRYID))
Set xAddressEntry = xNameSpace.GetAddressEntryFromID(xEntryID)
If xAddressEntry Is Nothing Then Exit Function
If xAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Or xAddressEntry.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
Set xExchangeUser = xAddressEntry.GetExchangeUser()
If xExchangeUser Is Nothing Then Exit Function
GetSmtpAddress = xExchangeUser.PrimarySmtpAddress
Else
PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
GetSmtpAddress = xAddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
End If
End If
End Function
How could I adapt the code to include the e-mail addresses from the CC field as well?
I tried setting Recipients but couldn't get the desired outcome.
You need to replace the GetSmtpAddress function with your own where you could get the CC recipients in the following way (a raw sketch):
Function GetSmtpAddress(Mail As MailItem) as String
Dim emailAddress as String
Dim recipient as Outlook.Recipient
Dim recipients as Outlook.Recipients
Set recipients = Mail.Recipients
For Each recipient In recipients
If recipient.Type = olCC Then
If recipient.AddressEntry.Type = "EX" Then
emailAddress = emailAddress & " " & recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Else
emailAddress = emailAddress & " " & recipient.Address
End If
End If
Next
Return emailAddress
End Function
You may find the How To: Fill TO,CC and BCC fields in Outlook programmatically article helpful.
Loop through all recipients in the MailItem.Recipients collection, check that Recipient.Type = olCC. For each Recipient object use Recipient.Address. Note that you can end up with EX type addresses (instead of SMTP). Check that Recipient.AddressEntry.Type is "SMTP". If it is not, use Recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress instead (do check for nulls).

Attach a multiple files in VBA

Help to modify the following code to be able to attach two file paths as attachments to send mail using MailCDO object in MS Access. Currently it's only attaching first file path only.
I tried using comma, using & sign and nothing seems to work.
Dim sSubject As String
Dim sFrom As String
Dim sTo As String
Dim sCC As String
Dim sBCC As String
Dim sBody As String
Dim sAttach As String
Dim sFilePath As String
Dim MailCDO
sFrom = "abc#abccom"
sCC = ""
sBCC = ""
sTo = "def#def.com"
sFilePath = "E:\Reports\Report1.xlsx"
sAttach = sFilePath
' Want to attach the second sFilePath2
sFilepath2= sFilePath = "E:\Reports\Report2.xlsx"
sSubject = "Subject"
sBody = "<p>Email Body</p>"
Set MailCDO = CreateObject("CDO.Message")
MailCDO.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
MailCDO.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
= "smtp.xxxyyy.com"
MailCDO.Configuration.Fields.Update
MailCDO.Subject = sSubject
MailCDO.FROM = sFrom
MailCDO.To = sTo
MailCDO.CC = sCC
MailCDO.BCC = sBCC
MailCDO.HTMLBody = sBody
MailCDO.AddAttachment sAttach
MailCDO.Send
Set MailCDO = Nothing
End Sub
you should try the with block for clean code
dim sFilepath as string, sFilepath2 as string
sFilePath = "E:\Reports\Report1.xlsx"
sFilepath2= "E:\Reports\Report2.xlsx"
With MailCDO
.Subject = sSubject
.FROM = sFrom
.To = sTo
.CC = sCC
.BCC = sBCC
.HTMLBody = sBody
.Attachments.add sFilePath
.Attachments.add sFilepath2
End with
you can also use for each loop in a collection to attach multiple files just like braX Suggested.

.Body in Outlook VBA is not getting text of plain text email

.Body of Mailitem is not returning anything
I am using the entryID to get access to the inbound email and set the object using Application.Session.GetItemFromID
strID = olitem.EntryID
Set olitem = Application.Session.GetItemFromID(strID)
Once I set olitem
Set olitem = Application.Session.GetItemFromID(strID)
it shows the email has been accessed, but when sText = olitem.Body is run stext ends up empty.
Here is the entire code that is fired from an Outlook Rule.
Sub ParseEPDMRequest(olitem As Outlook.MailItem)
Dim arr() As String
Dim ECONum As String
Dim ReqID As String
Dim sText As String
Dim strID As String
strID = olitem.EntryID
Set olitem = Application.Session.GetItemFromID(strID)
sText = olitem.Body
arr = Split(olitem.Body, ":")
arr = Split(arr(15), " ")
ECONum = GetECONum(arr(8))
sText = olitem.Subject
ReqID = GetReqId(sText)
Call TEAMtoEPDMPush(ECONum & ".xml", ReqID)
End Sub
Under certain circumstances the message can have no plain text body. You have to check the format of the body (see BodyFormat property):
strID = olitem.EntryID
Set olitem = Application.Session.GetItemFromID(strID)
If olitem.BodyFormat=OlBodyFormat.olFormatPlain Then
sText = olitem.Body
...
ElseIf olitem.BodyFormat=OlBodyFormat.olFormatHTML Then
...

How to send e-mail through VBA without Outlook

I'm trying to send email through SMTP in VBA, but is returning error.
Dim CDOmsg As CDO.Message
Set CDOmsg = New CDO.Message
With CDOmsg.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "myemail#gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "mypass"
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Update
End With
' build email parts
With CDOmsg
.Subject = "the email subject"
.From = "myemail#gmail.com"
.To = "mailto#gmail.com"
.CC = ""
.BCC = ""
.TextBody = "the full message body goes here. you may want to create a variable to hold the text"
End With
CDOmsg.Send
Set CDOmsg = Nothing
The error is on CDOmsg.Send. I've tried to send with Gmail and Yahoo Mail, but I get this same error.
Error code: -2147220973(80040213)
Error description: The transport failed to connect to the server
You can try the following but don't forget to tick the checkbox for 'Microsoft CDO for Windows 2000 Library'
Function email(ByVal sender_email As String, _
ByVal email_message As String, _
ByVal email_message2 As String, _
ByVal reply_address As String, _
ByVal sender_name As String)
Dim Mail As New Message
Dim Cfg As Configuration
Set Cfg = Mail.Configuration
'SETUP MAIL CONFIGURATION FIELDS
Cfg(cdoSendUsingMethod) = cdoSendUsingPort
Cfg(cdoSMTPServer) = 'SMTP
Cfg(cdoSMTPServerPort) = 'SMTPport
Cfg(cdoSMTPAuthenticate) = cdoBasic
Cfg(cdoSMTPUseSSL) = True
Cfg(cdoSendUserName) = 'sender_email
Cfg(cdoSendPassword) = 'password
Cfg.Fields.Update
'SEND EMAIL
With Mail
.From = 'sender_name & sender_email
.ReplyTo = 'reply_address
.To = 'receiver
.CC = 'carbonCopy
.BCC = 'blindCopy
.Subject = 'SubjectLine
.HTMLBody = 'email_message & email_message2
.Attachments.Add attFilePath
.Send
End With

VBA Excel Macro won't email out - error

I have the following code to test to email out to specified email addresses. At present it won't work.
It says "Label not defined".
Sub GHF()
Dim CDO_Mail As Object
Dim CDO_Config As Object
Dim SMTP_Config As Variant
Dim strSubject As String
Dim strFrom As String
Dim strTo As String
Dim strCc As String
Dim strBcc As String
Dim strBody As String
Set ws = Sheets("Feedback")
ws.Select
strSubject = " Assessment Centre Feedback"
strFrom = "test#email.com"
strTo = Value & Range("M4").Value
strCc = ""
strBcc = ""
strBody = "Dear" & Value & Range("M4").Value & "Thank you for attending assesssment Centre. Please find attached your feedback from the day. Kind Regards, Employer"
Set CDO_Mail = CreateObject("CDO.Message")
On Error GoTo Error_Handling
Set CDO_Config = CreateObject("CDO.Configuration")
CDO_Config.Load -1
Set SMTP_Config = CDO_Config.Fields
With SMTP_Config
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "fermat.axiomtech.co.uk"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item.Configuration.Fields.Update
End With
With CDO_Mail
Set .Configuration = CDO_Config
End With
End Sub
The name of the spreadsheet where the data sits is called "Feedback" and the Workbook is called "Feedback with Email"
Can anyone help with identifying what's up?
From address & Password
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xyz#Email.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "123456"