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\>"
Related
I am trying to send separate Employees a PDF/page of their section/report. The information is based on their EmployeeID (which is text not long number). So each person has their balance information on a page then there's a page break, and then next page shows the next person's details. With the code below, it does email each of the employees one page but it so happens to only email the first person's page to EVERYONE. Is it possible to somehow automate each week so that each user is emailed his/her individual page of the report?
Another error is that the email pop up one by one so I have to press send each time for over 200 people, and that the email seems to be sending to the email but then followed by #mailto:the email# for example email#email.com#mailto:email#email.com#
I just started Access and have been copying and scraping code off of places I have found online. Many thanks in advance, if you can assist!
Have a great day!
Private Sub cmdSendAll_Click()
Dim rsAccountNumber As DAO.Recordset
Dim strTo As Variant
Dim strSubject As String
Dim strMessageText As String
Set rsAccountNumber = CurrentDb.OpenRecordset("SELECT DISTINCT EmployeeID, [Email] FROM [queAutoUpdate]", dbOpenSnapshot)
Debug.Print strTo
With rsAccountNumber
Do Until .EOF
DoCmd.OpenReport "test", _
acViewPreview, _
WhereCondition:="EmployeeID = '" & !EmployeeID & "'", _
WindowMode:=acHidden
strTo = ![Email]
strSubject = "Updated Balance "
strMessageText = "Text Here"
DoCmd.SendObject ObjectType:=acSendReport, _
ObjectName:="test", _
OutputFormat:=acFormatPDF, _
To:=strTo, _
Subject:=strSubject, _
MESSAGETEXT:=strMessageText, _
EditMessage:=True
DoCmd.Close acReport, "Unaffirmed Report", acSaveNo
.MoveNext
Loop
.Close
End With
End Sub
Your opening a report called test and then closing another report called "Unaffirmed Report". You need to open and close the same report, in this case "test".
DoCmd.Close acReport, "test", acSaveNo. This should fix the employee data not updating, since the report remains open on the first employee.
To directly send the message you need change EditMessage:=True to EditMessage:=False.
Check the docs:
https://learn.microsoft.com/en-us/office/vba/api/access.docmd.sendobject
Also if you need to test this, set outlook in Offline mode, and run your code, check the messages in your Outbox to see if they're as expected. You can delete the messages from the Outbox to prevent them from being sent. Once you're finished with testing you can set Outlook back to Online Mode.
Regarding the email address issue, this comes automatically when using hyperlinks in your controls. You'll need to strip the extra part out with strTo = Left(![Email],InStr(![Email],"#")-1). Check your data if this will be valid for all email addresses. For a more advanced solution you can look at this post https://codekabinett.com/rdumps.php?Lang=2&targetDoc=access-hyperlink-data-type.
Code provided as reference, please see the post for the explanation.
'copied from https://codekabinett.com/rdumps.php?Lang=2&targetDoc=access-hyperlink-data-type
Public Function GetHyperlinkFullAddress(ByVal hyperlinkData As Variant, Optional ByVal removeMailto As Boolean) As Variant
Const SEPARATOR As String = "#"
Dim retVal As Variant
Dim tmpArr As Variant
If IsNull(hyperlinkData) Then
retVal = hyperlinkData
Else
If InStr(hyperlinkData, SEPARATOR) > 0 Then
' I append 4 separators at the end, so I don't have to worry about the
' lenght of the array returned by Split()
hyperlinkData = hyperlinkData & String(4, SEPARATOR)
tmpArr = Split(hyperlinkData, SEPARATOR)
If Len(tmpArr(1)) > 0 Then
retVal = tmpArr(1)
If Len(tmpArr(2)) > 0 Then
retVal = retVal & "#" & tmpArr(2)
End If
End If
Else
retVal = hyperlinkData
End If
If Left(retVal, 7) = "mailto:" Then
retVal = Mid(retVal, 8)
End If
End If
GetHyperlinkFullAddress = retVal
End Function
Consider using the MS Outlook object library to send emails. Whereas DoCmd.SendObject is a convenience handler, you control more of the process with initializing an Outlook application object and creating an Outlook email object setting all needed elements.
However, with this approach you need to first export your filtered report to PDF and then attach to email for final send. See inline comments for specific details.
Dim rsAccountNumber As DAO.Recordset
' CHECK Microsoft Outlook #.# Object Library UNDER Tools/References
Dim olApp As Outlook.Application, olEmail As Outlook.MailItem
Dim fileName As string, todayDate As String, strEmail As String
todayDate = Format(Date, "YYYY-MM-DD")
Set rsAccountNumber = CurrentDb.OpenRecordset("SELECT DISTINCT EmployeeID, [Email] FROM [queAutoUpdate]", dbOpenSnapshot)
Set olApp = New Outlook.Application
With rsAccountNumber
Do Until .EOF
' SETTING FILE NAME TO SAME PATH AS DATABASE (ADJUST AS NEEDED)
fileName = Application.CurrentProject.Path & "\Balance_Report_" & !EmployeeID & "_" & todayDate & ".pdf"
' OPEN AND EXPORT PDF TO FILE
DoCmd.OpenReport "test", acViewPreview, "EmployeeID = '" & !EmployeeID & "'"
' INTENTIONALLY LEAVE REPORT NAME BLANK FOR ABOVE FILTERED REPORT
DoCmd.OutputTo acReport, , acFormatPDF, fileName, False
DoCmd.Close acReport, "test"
' CREATE EMAIL OBJECT
strEmail = ![Email]
Set olEmail = olApp.CreateItem(olMailItem)
With olEmail
.Recipients.Add strEmail
.Subject = "Updated Balance"
.Body = "Text Here"
.Attachments.Add fileName ' ATTACH PDF REPORT
.Send ' SEND WITHOUT DISPLAY TO SCREEN
End With
Set olEmail = Nothing
.MoveNext
Loop
.Close
End With
MsgBox "All emails successfully sent!", vbInformation, "EMAIL STATUS"
Set rsAccountNumber = Nothing: Set olApp = Nothing
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
I am trying to load an HTML file into an email that gets sent by my Microsoft Access database. The email gets sent when the user clicks a button (Command109)
Here is my code that sends the email:
Private Sub Command109_Click()
'Start of code
Dim strEmail, strBody As String
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
'Creates an instance of Outlook
Set objOutlook = CreateObject("Outlook.Application")
DoEvents
Set objEmail = objOutlook.CreateItem(olMailItem)
DoEvents
'Creates string with email address
strEmail = PayeeEmail
strBody = "WHAT SHOULD I PUT HERE TO LOAD AN EXTERNAL HTML FILE?"
DoEvents
'Creates and sends email
With objEmail
DoEvents
.To = strEmail
DoEvents
.Subject = "Your Distribution from " & COMPANY & " has been processed."
DoEvents
.HTMLBody = strBody
DoEvents
DoEvents
.Send
End With
Set objEmail = Nothing
'Closes Outlook. Remove if you do not want to close Outlook
'objOutlook.Quit
Exit Sub
End Sub
I have this other code that allows me to load an HTML file into Outlook, but I'm not sure how to combine the code - so that the HTML file gets loaded into the BODY of the email being sent by Access.
Here is the code I have for a macro that will load an HTML file into Outlook:
Sub insertHTML()
Dim insp As Inspector
Set insp = ActiveInspector
If insp.IsWordMail Then
Dim wordDoc As Word.Document
Set wordDoc = insp.WordEditor
wordDoc.Application.Selection.InsertFile "C:\Users\me\Desktop\emailtemplate.html",
, False, False, False
End If
End Sub
Can anyone help me figure this out? Thank you for your time!
To concatenate strings on multiple lines you must have a space between the '&' and '_' as they are separate operators.
strBody = "<html><p> some of my html text here" & _ 'Note the spaces
"more formatted html text here" & _
"even more formatted html text here" & _
"don't forget your closing html brackets</p></html>"
with objEmail
.to = strTo
.subject = strSubject
.HTMKBody = strBody
.send
end with
For ease of readability in the code you can even create a seperate module with just the email string, just make sure it's public so that it can be called.
public strBody as string = your string here
I'm not sure about importing an HTML file directly, however in the past I have just placed the HTML code straight into the module. This is possible because you're using the .HTMLBody instead of .Body. You can also insert variable into the HTML code this way.
Straight HTML string
strBody = "<html> YOUR HTML CODE HERE </html>"
HTML using VBA variables
strBody = "<html><p> This is an email from " & COMPANY & ". We value your business</p></html>"
Obviously this isn't ideal if the template will change frequently. When I've done this in the past I've just made a template in outlook, copied the HTML code into VBA and then inserted variables where I wanted them.
There is likely a better way to do this though.
Currently I have this code for sending an email based on criteria from another form. The department I'm building this for has specified more than one person may receive the email. How do i get Access to look at a query that i have built. Which looks at the user table checks to see who can receive these emails and email the the list of emails from the query?
Select Case Forms!FRM_CallDetails!Model.Value
Case "SM", "TW", "LM", "LV", "SV"
On Error Resume Next
DoCmd.OutputTo acOutputForm, "FRM_CallDetails", acFormatXLS, "C:\temp\WatchList.xls", False
'Get Outlook if it's running
Set oApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn 't running, start it from code
Set oApp = CreateObject("Outlook.Application")
Started = True
End If
Set oItem = oApp.CreateItem(olMailItem)
With oItem
.To = "google#google"
.Subject = "AutoEmail"
.Body = " this is the body of the email... this is a test email "
.Attachments.Add "C:\temp\WatchList.xls"
'Send the email
.Send
End With
Set oItem = Nothing
If Started Then
oApp.Quit
End If
'Display message to the user
MsgBox "A model that is on the watch list has been selected. An Automatic Email has been sent.", vbOKOnly
'Message Body Here
Case Else
'no email
End Select
Here is the SQL for the query i'm using which I have called Mail_List
SELECT TBL_Users.Email_Address
FROM TBL_Users
WHERE (((TBL_Users.EW_Email)="Y"));
you could replace your With block with the following:
With oItem
s = " SELECT TBL_Users.Email_Address" & _
" FROM TBL_Users " & _
" WHERE (((TBL_Users.EW_Email)='Y'));"
Set rs = CurrentDb.OpenRecordset(s)
listOfMails = ""
While Not rs.EOF
listOfMails = listOfMails & rs(0) & ";"
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
.To = listOfMails
.Subject = "AutoEmail"
.Body = " this is the body of the email... this is a test email "
.Attachments.Add "C:\temp\WatchList.xls"
'Send the email
.Send
End With
Add a declaration for the three variables used as well :
Dim rs As Recordset
Dim s As String, listOfMails as String
This does not actually use your premade query but rather generates it on the spot, but it gets the trick done.