ISSUE: Outlook Automation fails at [Outlook Application].Recipients.Add ("Jon Grande")
Error message:
Runtime Error 438: "Object does not support this property or method.
MS example: https://learn.microsoft.com/en-us/office/vba/api/Outlook.Recipients
Line that fails: Set MailRecip = App.Recipients.Add("Jon Grande")
Private Sub cmdEmail_Contact_Click()
Call TestOutlookIsOpen 'AUTHOR: Ron Debruin> https://www.rondebruin.nl/win/s1/outlook/openclose.htm
Call GetAppExePath("msaccess.exe") 'AUTHOR: Daniel Pineault, CARDA Consultants Inc.
' IsAppRunning ("Outlook.Application") 'https://www.devhut.net/createobjectoutlook-application-does-not-work-now-what/
' GetAppExePath("firefox.exe") 'AUTHOR: Daniel Pineault, CARDA Consultants Inc.
' GetAppExePath ("outlook.exe") 'AUTHOR: Daniel Pineault, CARDA Consultants Inc.
Dim App As Object 'Outlook.Application
Dim Mail As Object 'Outlook.MailItem
Dim MailRecip As Object 'Outlook.Recipient
Const olMailItem = 0
Set App = CreateObject("Outlook.application")
Set Mail = OutlookApp() '<<<<<<<<<<< See Sub Macro MyMacroThatUseOutlook in TestTheCode Module
With Mail
Set MailRecip = App.Recipients.Add("Jon Grande")
**Set MailRecip = App.Recipients.Add("Jon Grande")**
Set MailRecip = App.Recipients.Add("Graham Smithwick#yahoo.com")
MailRecip.Type = 1 'Designates the above is TO recipients
.Subject = "5105088005#tmomail.net"
.Body = "<a href='tel:19254511573'> To Call CaolePepe (925-451-1573)</a> "
For Each MailRecip In .Recipients
If Not MailRecip.Resolve Then
Mail.Display
End If
Next
.Send 'this sends the mail
End With
Set MailRecip = Nothing
Set Mail = Nothing
Set App = Nothing
End Sub
First of all, you need to use the mail object instead of App to be able to call the Recipients property:
With Mail
Set MailRecip = .Recipients.Add("Jon Grande")
**Set MailRecip = .Recipients.Add("Jon Grande")**
Set MailRecip = .Recipients.Add("Graham Smithwick#yahoo.com")
MailRecip.Type = 1 'Designates the above is TO recipients
.Subject = "5105088005#tmomail.net"
.Body = "<a href='tel:19254511573'> To Call CaolePepe (925-451-1573)</a> "
If Not myRecipients.ResolveAll Then
Mail.Display
End If
.Send 'this sends the mail
End With
Also there is no need to iterate over all Recipients in the code and checking the Resolve method call results:
For Each MailRecip In .Recipients
If Not MailRecip.Resolve Then
Mail.Display
End If
Next
Instead, you could use the Recipients.ResolveAll method which attempts to resolve all the Recipient objects in the Recipients collection against the Address Book.
Read more about that in the How To: Fill TO,CC and BCC fields in Outlook programmatically article.
You are trying to add recipients to the Application object, which makes no sense.
Try the updated code below. (off the top of my head):
Call TestOutlookIsOpen 'AUTHOR: Ron Debruin> https://www.rondebruin.nl/win/s1/outlook/openclose.htm
Call GetAppExePath("msaccess.exe") 'AUTHOR: Daniel Pineault, CARDA Consultants Inc.
' IsAppRunning ("Outlook.Application") 'https://www.devhut.net/createobjectoutlook-application-does-not-work-now-what/
' GetAppExePath("firefox.exe") 'AUTHOR: Daniel Pineault, CARDA Consultants Inc.
' GetAppExePath ("outlook.exe") 'AUTHOR: Daniel Pineault, CARDA Consultants Inc.
Dim App As Object 'Outlook.Application
Dim Mail As Object 'Outlook.MailItem
Dim MailRecip As Object 'Outlook.Recipient
Const olMailItem = 0
Set App = CreateObject("Outlook.application")
Set Mail = App.CreateItem(0)
With Mail
Set MailRecip = .Recipients.Add("Jon Grande")
Set MailRecip = .Recipients.Add("Graham Smithwick#yahoo.com")
MailRecip.Type = 1 'Designates the above is TO recipients
.Subject = "5105088005#tmomail.net"
.Body = "<a href='tel:19254511573'> To Call CaolePepe (925-451-1573)</a> "
For Each MailRecip In .Recipients
If Not MailRecip.Resolve Then
Mail.Display
End If
Next
.Send 'this sends the mail
End With
Set MailRecip = Nothing
Set Mail = Nothing
Set App = Nothing
Got it!
Set App = CreateObject("Outlook.application")
Dim msgRecipient As String
msgRecipient = "****************#gmail.comt"
Dim oMail As Object
Set oMail = App.CreateItem(0)
Set MailRecip = oMail.Recipients.Add(msgRecipient)
With oMail
Set MailRecips = oMail.Recipients
MailRecip.Type = 1 'Designates the above is TO recipients
.Subject = Me.[Company]
.Body = "<a href='tel:1925***-****'> To Call(925-***-*****)</a> "
If Not MailRecips.ResolveAll Then
oMail.Display
End If
.Send
'MailRecip.send 'this sends the mail
End With
Set MailRecip = Nothing
Set oMail = Nothing
Set App = Nothing
Related
I send an email through Outlook. I am trying to put an email address link within the body of the email, so that one can click on it and an email opens.
E.g. "If you have any questions, please contact us at ABC", where the "ABC" is the link that represents email address, ABC#gmail.com (not the real address).
I understand, from scouring the web, this is the syntax:
<a href="mailto:ABC#gmail.com\>ABC\</a>
I borrowed code that uses HTML to format a message in the body of an email, and replaced a line with what I wanted.
I received a Compile Error (which I think is actually a syntax error in this case?).
When debugging, the "mailto" text was highlighted.
My insertion:
ABC mailbox
.HTMLBody = "\<HTML\>\<BODY\>\<a href="mailto:ABC#gmail.com"\>ABC mailbox\</a>\</BODY\>\</HTML\>"
Sub SendEmailformattext()
'Update by Extendoffice.com
Dim xRg As Range
Dim xRgEach As Range
Dim xRgVal As String
Dim xAddress As String
Dim OutlookApp As Object
Dim MItem As Object
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select email address range", "KuTools For Excel", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set OutlookApp = CreateObject("Outlook.Application")
Set MItem = OutlookApp.CreateItem(olMailItem)
Set xRg = xRg.SpecialCells(xlCellTypeConstants, xlTextValues)
For Each xRgEach In xRg
xRgVal = xRgEach.Value
If xRgVal Like "?*#?*.?\*" Then
Set MItem = xOutApp.CreateItem(olMailItem)
With MItem
.Display
.To = xRgVal
.Subject = "Test"
.HTMLBody = "\<HTML\>\<BODY\>\<a href="mailto:ABC#gmail.com"\>ABC mailbox\</a>\</BODY\>\</HTML\>"
'.Send
End With
End If
Next
Set xMailOut = Nothing
UNCLASSIFIED
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub
The original code worked so I know the mailto text is the problem.
Use the Chr(34) function if you need to use double quotes in the string:
.HTMLBody = "\<HTML\>\<BODY\>\**<a href="& Chr(34) & "mailto:ABC#gmail.com" & Chr(34) & "\>ABC mailbox\</a>**\</BODY\>\</HTML\>"
I have an Access 2016 database with tables that hold student data. I have managed to successfully send an email to each recipient using VBA-Outlook (the code works), however, it looks to have sent the the email to the same recipients multiple times (random duplicate of 1 to 4 emails per recipient).
I can confirm that there are no duplicate [E-mail Address] whatsoever contained within the Student table.
When I use .Display instead of .Send in my oEmailItem, there does not appear to be any duplicates. Perhaps I should include a waiting period of 1 second in the loop?
On Error Resume Next is used to bypass the null value returned by blank email fields; not everyone has an [E-mail Address] in this table
Why is this code sending random duplicate email to recipients?
Private Sub SendEmail_Click()
Dim rS As DAO.Recordset
Dim dbS As DAO.Database
Dim Filepath As String
Dim Folderpath As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim myemail As String
Dim Subjectline As String
Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
"We need a Subject Line!")
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("SELECT * FROM Students")
Do While Not rS.EOF
On Error Resume Next
myemail = rS![E-mail Address]
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
'Set the email template
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
With oEmailItem
.To = [myemail]
.Subject = Subjectline$
.Send
End With
'End of emailing
rS.MoveNext
Loop
Set oEmailItem = Nothing
Set oOutlook = Nothing
Set rS = Nothing
Set dbS = Nothing
End Sub
Update:
Thanks HiPierr0t. Your answer showed me that I wasn't emptying the variable at the end of the loop; thus assigning the previously used [E-mail Address] when met with a null or blank email field.
I did have to keep
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
inside the loop however (strange, must be a MS thing).
I ended up removing On Error Resume Next as it does create more problems, and used
myemail = Nz(rS![Email Address], vbNullString)
to change any null or blank fields into "". That way, I don't need to empty to variable each time as the lookup changes it to "" if it's null anyway. The If..Else takes care of the rest.
Do While Not rS.EOF
'On Error Resume Next
myemail = Nz(rS![Email Address], vbNullString)
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
If myemail = "" Then
rS.MoveNext
Else
With oEmailItem
.To = [myemail]
.Subject = Subjectline$
.Display
End With
'End of my emailing report
rS.MoveNext
End If
Loop
On Error Resume Next tends to create more problems than it solves.
If no email exists, your code goes on. However your variable myemail is still filled with the previous email you sent an email to.
1- Make sure to empty your variable after the email is sent with myemail = "" or myemail = vbNullString.
2- Before sending the email, check that myemail is not empty with an If statement.
3- You may want to place your code below outside of the loop. It won't make a big difference but there is no need to process this part of code every time.
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
'Set the email template
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
Please check if you’ve emptied the myemail before sending e-mail.
Also you need to add “rS.Close dbS.Close” after the Loop.
Here is complete code:
Private Sub SendEmail_Click()
Dim rS As DAO.Recordset
Dim dbS As DAO.Database
Dim Filepath As String
Dim Folderpath As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim myemail As String
Dim Subjectline As String
Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
"We need a Subject Line!")
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("SELECT * FROM Students")
Do While Not rS.EOF
On Error Resume Next
myemail = ""
myemail = rS![E-mail Address]
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
'Set the email template
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
With oEmailItem
.To = [myemail]
.Subject = Subjectline$
.Send
End With
'End of emailing
rS.MoveNext
Loop
rS.Close
dbS.Close
Set oEmailItem = Nothing
Set oOutlook = Nothing
Set rS = Nothing
Set dbS = Nothing
End Sub
I am trying to send a fax from Outlook using a different Outlook address than mine which is the one that it defaults to. Below is my code.
Thank you.
Private Sub FaxDoctor() ' Faxes the doctor with the letter
On Error GoTo Error_Handler
Dim fso
Dim olApp As Object
' Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olfolder As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists("\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf") Then ' If the filename is found
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olfolder = olNS.GetDefaultFolder(olFolderInbox)
Set olMailItem = olfolder.Items.Add("IPM.Note")
olMailItem.display
With olMailItem
.Subject = " "
.To = "[fax:" & "Dr. " & Me.[Prescriber First Name] & " " & Me.[Prescriber Last Name] & "#" & 1 & Me!Fax & "]" ' Must be formatted exactly to be sent as a fax
'.Body = "This is the body text for the fax cover page" ' Inserts the body text
.Attachments.Add "\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf" ' attaches the letter to the e-mail/fax
'.SendUsingAccount = olNS.Accounts.Item(2) 'Try this to change email accounts
End With
Set olMailItem = Nothing
Set olfolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Else
GoTo Error_Handler
End If
Exit_Procedure:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox ("No Letter found" & vbCrLf & "If you are certain the letter is saved with the correct filename then close down Outlook and try again.") ' This often crashes because the letter is not found or because outlook has crashed. In which case every Outlook process should be closed and Outlook should be restarted.
Exit Sub
End Sub
You can change the outlook account by using the 'SendUsingAccount' property of the mail item. This needs to be set to an account object.
You can set the account for a given name using something like this where 'AccountName' is the address you're sending from.
Dim olAcc as Outlook.Account
For Each olAcc In Outlook.Session.Accounts
If outAcc.UserName = 'AccountName' Then
olMailItem.SendUsingAccount = outAcc
Exit For
End If
Next
Try using ".SendOnBehalfOfName"
I found this function online, so just follow its lead:
Function SendEmail()
Dim Application As Outlook.Application
Dim NameSpace As Outlook.NameSpace
Dim SafeItem, oItem ' Redemption
Set Application = CreateObject("Outlook.Application")
Set NameSpace = Application.GetNamespace("MAPI")
NameSpace.Logon
Set SafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem
Set oItem = Application.CreateItem(0) 'Create a new message
SafeItem.Item = oItem 'set Item property
SafeItem.Recipients.Add "customer#ispprovider.com"
SafeItem.Recipients.ResolveAll
SafeItem.Subject = "Testing Redemption"
SafeItem.SendOnBehalfOfName = "Invoices#companyname.com"
SafeItem.Send
End Function
Is there any way to send a mail in HTML format (and if possible with attachments) when your default mail client isn't Outlook?
Many thanks for any solution.
You should be able to use CDO (Collaboration Data Objects). The code will look something like this:
Option Compare Database
Option Explicit
Sub cdoHtmlTest()
Const urlPrefix = "http://schemas.microsoft.com/cdo/configuration/"
Dim msg As Object ' CDO.Message
Set msg = CreateObject("CDO.Message") ' New CDO.Message
With msg.Configuration.Fields
.Item(urlPrefix & "sendusing") = 2 ' cdoSendUsingPort
.Item(urlPrefix & "smtpserver") = "smtp.example.com"
.Item(urlPrefix & "smtpserverport") = 25
.Item(urlPrefix & "smtpauthenticate") = 1 ' cdoBasic
.Item(urlPrefix & "sendusername") = "mySmtpUserName"
.Item(urlPrefix & "sendpassword") = "mySmtpPassword"
.Item(urlPrefix & "smtpusessl") = False
.Update ' remember to do this step!
End With
With msg
.To = "gord#example.com"
.From = "gord#example.com"
.Subject = "HTML message test"
.HTMLBody = "This is a <strong>TEST</strong>."
.Send
End With
Set msg = Nothing
End Sub
For more examples (including how to send attachments), look here.
I have some code that creates a Mail object (Outlook), attaches a file and sends it.
Dim mobjOutlook, mobjActiveExp, mobjNewMail As Object
'Create Outlook objects
Set mobjOutlook = CreateObject("Outlook.Application")
Set mobjActiveExp = mobjOutlook.ActiveExplorer
Set mobjNewMail = mobjOutlook.CreateItem(olMailItem)
'Setup and send email
With mobjNewMail
.To = "someone#test.com"
.Subject = "theSubject"
.Body = "some text"
.Attachments.Add "C:/The/File/Path.doc"
'*I need to check here if the above line worked*
.Send
End With
How can I test if the attachment works before sending? Is this possible? For some reason even if it doesn't, it still sends the email without the attachment.
I was thinking of somehow utilizing the '.Save' option.
Any thoughts or suggestions are much appreciated,
thanks.
You could just test the number of attachments in the email were > 0
Also
Dim mobjOutlook, mobjActiveExp, mobjNewMail As Object
will dim the first two variables as variants, so I have recut this below
Sub Test()
Dim mobjOutlook As Object
Dim mobjActiveExp As Object
Dim mobjNewMail As Object
'Create Outlook objects
Set mobjOutlook = CreateObject("Outlook.Application")
Set mobjActiveExp = mobjOutlook.ActiveExplorer
Set mobjNewMail = mobjOutlook.CreateItem(olMailItem)
'Setup and send email
With mobjNewMail
.To = "someone#test.com"
.Subject = "theSubject"
.Body = "some text"
.attachments.Add "C:\temp\step1.png"
If .attachments.Count > 0 Then
.Send
Else
MsgBox "No attachment", vbCritical
End If
End With
End Sub