I need to send a series of email notifications from an MS Access Database.
No third party dll's like Redemption
Cannot trip the outlook security warnings
The email will have a pdf attachment
I know to do this I need to use MAPI, but I can't seem to find a way to do this with VBA.
Any help would be appreciated
Thanks,
Scott
If you can live with requiring CDO to be present on the machine, and you don't mind a user-provided SMTP server, you can use that. Just google for some example code, but for you convenience I'll paste some below from www.rondebruin.nl :
Sub CDO_Mail_Small_Text()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
' Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
' = "Fill in your SMTP server here"
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
With iMsg
Set .Configuration = iConf
.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.From = """Ron"" <ron#something.nl>"
.Subject = "Important message"
.TextBody = strbody
.Send
End With
End Sub
Adding an attachment would be done using .AddAttachment "C:\files\filename.pdf" on the iMsg.
If the user has outlook installed:
Dim strErrMsg As String 'For Error Handling
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim oleGrf As Object
Dim strFileName As String
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olMail = olApp.CreateItem(olMailItem)
Set oleGrf = Me.OLEchart.Object
strFileName = "c:\temp\Graph.jpg"
oleGrf.Export FileName:=strFileName
With olMail
.To = "someone#somewhere.com"
.Subject = "Graph Info " & Format(Now(), "dd mmm yyyy hh:mm")
.Attachments.Add strFileName
.ReadReceiptRequested = False
.Send
End With
Kill strFileName
Also check out Tony Toews's Microsoft Access Email FAQ
See the page Microsoft Access Email FAQ - Directly via the Winsock I haven't tried those myself but you should be able to adapt the VB6 code to send the emails directly.
Related
I am using below query in Access VBA to import emails from outlook, however i am not able to find any details to capture email address instead of From or along with From. any help can be appricated.
Sub InboxImport()
Dim SqlString As String
Dim ConnectionString As String
Dim EmailTableName As String
Dim UserIdNum As String
Dim EmailAddr As String
Dim ol As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFol As Outlook.Folder
Set ol = CreateObject("Outlook.Application")
Set olNS = ol.GetNamespace("MAPI")
Set olFol = olNS.GetDefaultFolder(olFolderInbox)
EmailTableName = "MyInbox" 'My table name
UserIdNum = Environ("USERNAME")
EmailAddr = olFol.Parent.Name
ConnectionString = "Outlook 9.0;MAPILEVEL=Test#Me.com|;PROFILE=Default Outlook Profile;TABLETYPE=0;TABLENAME=Inbox;COLSETVERSION=12.0;DATABASE=C:\Users\ME\AppData\Local\Temp\"
SqlString = "SELECT [From] As [Sender], [Sender Name] As SenderName, [Subject Prefix] & [Normalized Subject] As Subject, [Contents] As [Body], [Received] As [ReceivedTime]" & _
" INTO [Copy Of APR_DATA]" & _
" From [" & ConnectionString & "].[Inbox]"
DoCmd.RunSQL SqlString
End Sub
Set a link to Outlook Inbox folder and will see From field showing either sender's email address or an alias but no other field with sender address. Possibly masked email address cannot be retrieved via query. It can be retrieved by reading SenderEmailAddress property of an email item. Consider:
' Procedure : Outlook_ExtractMessages
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Extract E-mail Listing
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Usage:
' ~~~~~~
' Call Outlook_ExtractMessages
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2019-07-15 Initial Release
'---------------------------------------------------------------------------------------
Sub Outlook_ExtractMessages()
Dim oOutlook As Object 'Outlook.Application
Dim oNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object 'Outlook.folder
Dim oItem As Object
Dim oPrp As Object
Const olFolderInbox = 6
Const olMail = 43
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
If Err.Number <> 0 Then 'Could not get instance, so create a new one
Err.Clear
Set oOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo Error_Handler
Set oNameSpace = oOutlook.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderInbox)
' Set oFolder = oOutlook.ActiveExplorer.CurrentFolder 'Process the currently selected folder
' Set oFolder = oNameSpace.PickFolder 'Prompt the user to select the folder to process
On Error Resume Next
For Each oItem In oFolder.Items
With oItem
If .Class = olMail Then
Debug.Print .SenderEmailAddress ' .body, .EntryID, .Subject, .Sender, .SentOn, .ReceivedTime
'For Each oPrp In .ItemProperties
' Debug.Print , oPrp.name, oPrp.Value
'Next oPrp
End If
End With
Next oItem
Error_Handler_Exit:
On Error Resume Next
If Not oPrp Is Nothing Then Set oPrp = Nothing
If Not oItem Is Nothing Then Set oItem = Nothing
If Not oFolder Is Nothing Then Set oFolder = Nothing
If Not oNameSpace Is Nothing Then Set oNameSpace = Nothing
If Not oOutlook Is Nothing Then Set oOutlook = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Outlook_ExtractMessages" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
I want to send a personalized email generated by Excel VBA.
The email contains personalized text followed by a html file that contains images.
I tried the following code but the images are not displayed.
Sub Mail_Outlook_With_Html_Doc()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim oFSO As Object
Dim oFS As Object
Dim sText As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.OpenTextFile("C:\....\invite.htm")
Do Until oFS.AtEndOfStream
sText = oFS.ReadAll()
Loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'strbody = personalized email body generated here
On Error Resume Next
With OutMail
.display
.To = ToAdd
.CC =
.BCC = ""
.Subject = "Test Email"
.ReadReceiptRequested = True
' the html file is appended here to the personalized email body generated
.HTMLBody = strbody & sText
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
The invite.htm referred above contains images which are not visible when the email is sent. Neither in the email messages sent nor in the email messages received.
Here ia an example that works for me you need to adapt it according to your needs.
This will embed the image in the body of the email and will attach it from what I remember. Please note you need to display the email first and then send it that is the only way to show on different device, i learn that the hard way. It can be done via code as the below example if you want to display and review the email just comment out the .Send after you are happy you can press manually send.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
I am using the below code. It works find without the attachment line of code. But once I add the attachment line if get an error and can not work out how to correct it:
Dim Email
Dim CC
Dim objOutlook As Object
Dim objEmail As Object
Dim db As Database
Dim rec As Recordset
'Export report in same folder as db with date stamp
todayDate = Format(Date, "MMDDYYYY")
fileName = Application.CurrentProject.Path & "\XXDispute_" & todayDate & ".pdf"
DoCmd.OutputTo acReport, "XXDispute", acFormatPDF, fileName, False
strItem = "http://schemas.microsoft.com/cdo/configuration/"
strFrom = "XX Disputes <asd#asd.com>"
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = CreateObject("CDO.Message")
With objEmail
.To = "asd#asd.com"
.CC = ""
.From = strFrom
.Subject = "XXDispute Report: " & Now()
.Textbody = "Your XX dispute has been reviewed and responded to:" & vbNewLine & vbNewLine
.Attachments Add = fileName
With .Configuration.Fields
.Item(strItem & "sendusing") = 2
.Item(strItem & "smtpserver") = "mailhost"
.Item(strItem & "smtpserverport") = 25
.Update
End With
.Send
End With
This is the particular line causing the problem:
.Attachments Add = fileName
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
This code is working in another Access db.
I just copy pasted the code but there is an error in the first line.
Public Function sendEmailOutlook()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
On Error GoTo ErrHandler:
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("sads")
'Set objOutlookRecip = .Recipients.Add("niticin#gmail.com")
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "This is an automatic confirmation"
.Body = "This is a confirmation of the" & Form_Booking.Event_Name.Value & vbCrLf & _
"Client: " & Form_Booking.FirstName.Value & vbCrLf & vbCrLf & _
"Start Time: " & Form_Booking.Actual_Start_Time.Value
.Importance = olImportanceHigh 'High importance
.Save
.Send
End With
'Set objOutlookMsg = Nothing
Set objOutlook = Nothing
Exit Function
ErrHandler:
MsgBox ("Make sure your Outlook is active and configured!")
End Function
Error on line
Dim objOutlook As Outlook.Application
compiler : user defined type not defined.
You're using early binding, so in the VBA Editor you need to click Tools -> References & tick Microsoft Outlook ?? Object Library in order to expose Outlook's object model to your code.