I am trying to use VBA in Excel to send a message to an AOL address. I can get Gmail and Comcast to work, but not AOL.
Error: -2147220973 - The transport failed to connect to the server.
My code originated here: https://www.makeuseof.com/tag/send-emails-excel-vba/
Thank you for your assistance!
Option Explicit
' Source from: https://www.makeuseof.com/tag/send-emails-excel-vba/
Sub Test_Email()
Dim sResult As String
sResult = Send_Emails("somebody#aol.com", "MyPWD", "smtp.aol.com")
MsgBox "Finished: " & vbTab & sResult
End Sub
Public Function Send_Emails(EmailAddress As String, PWD As String, SMTP As String) As String
Dim NewMail As CDO.Message
Dim mailConfig As CDO.Configuration
Dim fields As Variant
Dim msConfigURL As String
On Error GoTo Err:
Debug.Print "Send: " & EmailAddress & vbTab & PWD & vbTab & SMTP
Set NewMail = New CDO.Message
Set mailConfig = New CDO.Configuration
mailConfig.Load -1 'load all default configurations
Set fields = mailConfig.fields
With NewMail
.From = EmailAddress
.To = "myname#comcast.net"
.CC = ""
.BCC = ""
.Subject = "Send Email From an Excel Spreadsheet"
.TextBody = "This is the body of your email. And here is some added data:" & "XXXX"
.AddAttachment ThisWorkbook.path & "\" & "openexcel.txt" ' 'Optional file attachment; remove if not needed.
End With
msConfigURL = "http://schemas.microsoft.com/cdo/configuration"
With fields
.item(msConfigURL & "/smtpusessl") = True 'Enable SSL Authentication
.item(msConfigURL & "/smtpauthenticate") = 1 'SMTP authentication Enabled
.item(msConfigURL & "/smtpserver") = SMTP 'i.e. "smtp.aol.com"
.item(msConfigURL & "/smtpserverport") = 465 'Set the SMTP port Details
.item(msConfigURL & "/sendusing") = 2 'Send using default setting
.item(msConfigURL & "/sendusername") = EmailAddress ' full xxx&aol.com 'Your gmail address
.item(msConfigURL & "/sendpassword") = PWD 'Your password or App Password
.Update 'Update the configuration fields
End With
NewMail.Configuration = mailConfig
NewMail.send
MsgBox "Your email has been sent", vbInformation
Send_Emails = "Success!"
Exit_Err:
'Release object memory
Set NewMail = Nothing
Set mailConfig = Nothing
Exit Function
Err:
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " &
Err.Description
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " &
Err.Description
Case Else 'Report other errors
MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " &
Err.Description
End Select
Resume Exit_Err
Resume
End Function
Use the Outlook object model instead of CDO (not supported any longer).
Microsoft Outlook 2010 and later versions include many architectural changes to the client-side MAPI subsystem. Of particular concern are scenarios in which Outlook is configured to use multiple Exchange accounts. Also, CDO 1.2.1 is a 32-bit client library and will not operate with 64-bit versions of Outlook. Given all these factors, CDO 1.2.1 is not supported for use with Outlook 2010 or later versions, and MS does not recommend its use with Outlook 2010 and later versions.
Programs that use CDO should be redesigned to use other Application Programming Interfaces (APIs) instead of CDO. Starting with Outlook 2007, the Outlook object model was greatly expanded to provide functionality that was previously available only by using CDO 1.2.1. The Outlook 2010 and later versions object model includes some new features to expand on this more. For example, the Outlook object model has new functionality to operate correctly with multiple Exchange accounts. The Outlook object model also works for both 32-bit and 64-bit versions of Outlook. Developers should use the Outlook 2010 and later object model instead of CDO 1.2.1. Also, developers can still use Extended MAPI (which requires unmanaged C++) in some scenarios where CDO was required. However, if it is possible, we generally recommend that the Outlook object model is used instead of Extended MAPI.
See Collaboration Data Objects (CDO) 1.2.1 is not supported with Outlook 2010 and later versions for more information.
Related
I have a client that is using Access 2002 because it allows Replication. He is using this on Windows 10 with Outlook from Office 365.
The goal is to create a new email with all of the info filled in and attach a scanned proposal so that my client can review the email, make any changes that he wants and then send it.
In Access, the SendObject command creates and opens a plain text email and while this email is open my Outlook macro to scan a document and attach it to the email will not run.
So I would like to create a new Outlook email from Access that allows me to run my Outlook macro.
Or if I could get Access 2002 to create an email and attach the scanned document to it, I think I could get by with using msgboxes to verify specific items.
Below is the Access macro with the SendObject command followed by the Outlook macro.
Private Sub EmailProposal_Click()
'Access macro.
Dim stDocName As String
Dim stEmailAddress As String
Dim stSubject As String
Dim stMessage As String
stDocName = "rptProposal"
stEmailAddress = Forms!RequestForm!EmailAddress.Value
stSubject = "PROPOSAL"
stMessage = "Your proposal is attached." & vbCrLf & vbCrLf & "If you have any questions, please call us."
'Email the proposal.
DoCmd.SendObject acReport, stDocName, acFormatRTF, stEmailAddress, , , stSubject, stMessage
End Sub
Sub Scan()
'Outlook macro.
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
On Error Resume Next
Dim objCommonDialog As WIA.CommonDialog
Dim objImage As WIA.ImageFile
Dim strPath As String
Set objCommonDialog = New WIA.CommonDialog
'This shows the dialog box. I'd rather tell it what to do instead of having to manually choose each time.
Set objImage = objCommonDialog.ShowAcquireImage
strPath = Environ("TEMP") & "\TempScan.jpg" 'Save the scan.
If Not objImage Is Nothing Then
objImage.SaveFile strPath ' save into temp file
On Error GoTo ErrHandler
If TypeName(ActiveWindow) = "Inspector" Then
If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
ActiveInspector.WordEditor.Application.Selection.Inlineshapes.AddPicture strPath 'Insert into email. I want to attach it instead.
End If
End If
Kill strPath
Else
MsgBox "The Scan macro in Outlook did not find a document." & vbCrLf & vbCrLf & _
"Please place the proposal in the printer so it can be scanned.", vbOKOnly
End If
lbl_Exit:
Set objImage = Nothing
Set objCommonDialog = Nothing
Exit Sub
ErrHandler:
Beep
Resume lbl_Exit
End Sub
It seems you just need to automate Outlook for sending out emails with the required content set up. Take a look at the following articles that give you the basics of Outlook automation:
Automating Outlook from a Visual Basic Application
Automating Outlook from Other Office Applications
Sub Send_Mail_Outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "eugene#astafiev.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I've outlook 2010 at my work and linked my personal mail id as a primary account and the rest of the group shared mail id are linked at server level.
So when I send a new email from the group, it selects the personal mail id by default and user have to change it everytime.
I use the below macro to provide a warning pop up when the From is selected as my personal id however this macro warn even if the shared mail id is selected in From.
How to prevent this from warning if the From is not the primary id or personal id or is there a macro to automatically select the From when a new email is created based on the group shared mail id's?
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If InStr(LCase(Item.SendUsingAccount), "sara#example.com.") Then
Prompt$ = "You sending this from sara#example.com. Are you sure you want to send it?"
If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End If
End Sub
From corresponds to the SentOnBehalfOfName property. This is empty until mail is sent, unless you set it in code before sending. Not useful here as you want to verify if you forgot to set it.
Private Sub SetFrom()
Dim curritem As mailItem
Dim uPrompt As String
Set curritem = CreateItem(olMailItem)
curritem.Display
uPrompt = "This mail has not been sent." & vbCr & vbCr
uPrompt = uPrompt & "The SentOnBehalfOfName (From) property is empty unless set in the code." & vbCr & vbCr
uPrompt = uPrompt & "See between the quotes." & vbCr & vbCr
MsgBox uPrompt & Chr(34) & ActiveInspector.currentItem.SentOnBehalfOfName & Chr(34)
' Note: The From in the user interface does not populate the property."
curritem.SentOnBehalfOfName = "sharedmailbox#example.com"
' For demonstration purposes. Not necessary to display in real code.
curritem.Close olSave
curritem.Display
MsgBox "SentOnBehalfOfName set in the code." & vbCr & vbCr & _
"The SentOnBehalfOfName (From) is set to: " & curritem.SentOnBehalfOfName
ExitRoutine:
Set curritem = Nothing
End Sub
Your attempt to verify SendUsingAccount has likely failed due to having one account with many mailboxes where you want many accounts.
Sub Account_name()
Dim olAcct As account
Dim countAcc As Long
Dim i As Long
countAcc = Session.Accounts.count
For i = 1 To countAcc
Debug.Print "Account.....: " & i
Debug.Print " DisplayName: " & Session.Accounts.Item(i).DisplayName
Debug.Print " UserName : " & Session.Accounts.Item(i).userName
Debug.Print
Next
End Sub
If you find you have only one account see Add an email account to Outlook to to add accounts if you have the required permissions.
I want to save an attachment from a specific sender that has a specific file extension in the attachment. I'm having trouble with the If part of my loop. I receive Run-time error 438: Object doesn't support this property or method.
Sub GetAttachments()
Dim ns As NameSpace
Dim folder As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
If Item.SenderEmailAddress = "email#domain.com" Then
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
If Right(Atmt.FileName, 3) = ".py" Then
FileName = "C:\Users\bill\Desktop\TEST\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
End If
Next Item
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Users\bill\Desktop\TEST folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail." , vbInformation, "Finished!"
End If
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
The Folder can contain various types of items. Some of them don't provide the SenderEmailAddress property. Try to check out the item class first (or MessageCLass).
Also you may get a security issue if you automate Outlook from another application. See Outlook "Object Model Guard" Security Issues for Developers.
And don't interate over all items in the folder:
For Each Item In Inbox.Items
If Item.SenderEmailAddress = "email#domain.com" Then
You can use the Find/FindNext or Restrict methods of the Items class instead. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Also you may find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
See Advanced search in Outlook programmatically: C#, VB.NET for more information.
See this example
Filter = "[SenderEmailAddress] = 'email#domain.com'"
Set Items = Inbox.Items.Restrict(Filter)
ii = 0
For i = Items.Count To 1 Step -1
Set Item = Items.Item(i)
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
If Right(Atmt.FileName, 3) = ".py" Then
FilePath = "C:\Temp\"
FileName = Atmt.FileName
Atmt.SaveAsFile FilePath & FileName
ii = ii + 1
End If
Next Atmt
Next
I'm trying to look through a specific inbox for unread e-mails with .pdf files attached to them, and then save them into a specific folder.
I need to look through the inbox of certain account profile. My code only works if there is just one Inbox folder and one account profile.
Let's say I have two profiles;
One is xxxx#hotmail.com
The second zzzz#hotmail.com
How do I run the code on the Inbox of the second account?
(zzzz#hotmail.com)
The following is the code that I have so far;
Sub GetAttachments()
On Error GoTo GetAttachments_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Checks inbox for messages.
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in your Inbox.", vbInformation, _
"Nothing found"
Exit Sub
End If
' Checks inbox for unread messages.
If Inbox.UnReadItemCount = 0 Then
"Nothing found"
Exit Sub
End If
' Checks for unread messages with .pdf files attached to them, if yes then saves it to specific folder. _
Puts date and time from when the mail was created infront of the filename.
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Item.UnRead = True Then
If Right(Atmt.FileName, 3) = "pdf" Then
FileName = "C:\Users\XXX\Documents\Office Macro\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
End If
Next Atmt
Next Item
' Shows how many attached files there are if any are found.
If i > 0 Then
& vbCrLf & "Jag har sparat dem till C:\Users\XXX\Documents\Office Macro folder." _
& vbCrLf & vbCrLf & "Would you like to see your files?" _
vbQuestion + vbYesNo, "Finished!")
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Users\XXX\Documents\Office Macro\", vbNormalFocus
End If
Else
MsgBox "No attached files could be found.", vbInformation, _
"Finished!"
End If
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
GetAttachments_err:
MsgBox "An unkown ghost spooked the program." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
Exit Sub
End Sub
After further inspection of the mailboxes I see that there are some differences:
xxxx#hotmail.com is of the type "IMAP/SMTP"
zzzz#hotmail.com is of the type "Exchange ActiveSync"
I've also noticed that that the account ID I would need to use is 4, as seen in this code when sending a new message with a test-macro specifying what profile you want to send the mail from by assigning profile ID in the script:
Sub Mail_small_Text_Change_Account()
'Only working in Office 2007-2013
'Don't forget to set a reference to Outlook in the VBA editor
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "blabla#blabla.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
'SendUsingAccount is new in Office 2007
'Change Item(1)to the account number that you want to use
.SendUsingAccount = OutApp.Session.Accounts.Item(4) <<<< ACCOUNT ID
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
You get only the delivery store's inbox folder to find the items.
The Stores property of the Namespace class returns a Stores collection object that represents all the Store objects in the current profile. You can find the required store and then use the GetDefaultFolder method of the Store class instead. This method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile.
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
There is no need to create a new Outlook Application instance in Outlook VBA.
The Outlook object model provides the Find/FindNext or Restrict methods of the Items class. Also you may find the AdvancedSearch method of the Application class helpful.
Thanks for any help with this. I have a userform I've made that gathers criteria from the user and then when they hit submit it opens Outlook and emails that data to me.
I'm having 2 issues. The first is that when I try to use SENDKEYS method I'm running into the spell check feature stopping the email from actually sending without the user needing to go through it. Is there a way to bypass spell check and send the email?
Secondly, I couldn't find a way to actual send an email automatically without using SENDKEYS but I'm sure there is a better way out there to send the email rather than manipulating the window with TAB key strokes.
Private Sub SubmitButton_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim strBody, RequestName, ProductName, Month, TestName, Summary As String
If Me.RequesterNameTxt.Value <> "" And Me.ProductCombo.Value <> "" And Me.MonthCombo.Value <> "" And Me.TestNameCombo <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
RequestName = Me.RequesterNameTxt.Value
ProductName = Me.ProductCombo.Value
Month = Me.MonthCombo.Value
TestName = Me.TestNameCombo.Value
Summary = Me.SummaryTxt.Value
strBody = "<HTML><BODY>"
strBody = "Requester Name: " & RequestName & "<BR>" & "Product Name: " & ProductName & "<BR>" & "Month: " & Month & "<BR>" & _
"Test Name: " & TestName & "<BR>" & "<BR>" & "Summary of Request: " & Summary
strBody = strBody & "</BODY></HTML>"
On Error Resume Next
With OutMail
.To = "example#gmail.com;"
.CC = ""
.bcc = ""
.Subject = "QA Service Request"
.htmlBody = strBody
.send 'This fixed my issue. I had this as .Display which opens email up and doesn't send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.SendKeys ("%s")
Else: MsgBox "Please fill out all form data before submitting request. Thank you!"
End If
End Sub
You need to use the Send method of Outlook items instead. The Send method sends an item using the default account specified for the session. In a session where multiple Microsoft Exchange accounts are defined in the profile, the first Exchange account added to the profile is the primary Exchange account, and is also the default account for the session. To specify a different account to send an item, set the SendUsingAccount property to the desired Account object and then call the Send method.
Also I'd recommend using the Recipients property for adding recipients instead. The property returns a Recipients collection that represents all the recipients for the Outlook item.