I've been researching this exact function for the past 3 days and find there is not much posted as a package solution. Here is an updated solution for Office 2010 / outlook version 14. Improvements may be possible but it seems to be working. I collected the following code from many different sites...
Using Access 2010:
1. Create an email using Outlook,
2. Send email,
3. Do not close Outlook until outbox is empty.
Access library objects referenced: visual basic for applications, MS Access 14.0 object library, OLE Automation, MS Office 14.0, MS Outlook 14.0 Object library
Option Compare Database
Private Declare Sub AppSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
Function test_send()
'send 10 test emails with attachment
Dim strfile As String
Dim i As Integer
Do While i < 10
i = i + 1
strfile = "c:\myfolder\myfile.xlsx"
SendOutlookMail strfile
Loop
Close_Outlook 'function that waits until outbox is empty before closing app
MsgBox "finished"
End Function
Sub SendOutlookMail(strfile As String)
Dim strSubject As String
Dim strBody As String
Dim strBCC As String
' check to see if the file path for attachment is valid.
If strfile <> "" And Dir(strfile) = "" Then
MsgBox "problem with file name"
Exit Sub
End If
'build the email subject
strSubject = Cre_Subject
'build the email body html code
strBody = Cre_Body
'build the bcc list
strBCC = Cre_BCC
'create the email by assembling the components
CreateOutlookItem strSubject, strBody, strBCC, strfile
End Sub
Public Function Cre_Subject()
Dim strSub As String
Dim strDate As String
strDate = Format(Date, "YYYY\MM\DD")
strSub = "Text of my email subject_" & strDate & "_more text if needed"
Cre_Subject = strSub
End Function
Public Function Cre_Body()
Dim strBody As String
strBody = "<HTML>"
strBody = strBody & "<body bgcolor=""powderblue"" text=""black"">"
strBody = strBody & "<br><br><font size=""+1""> Company Confidential </font>"
strBody = strBody & "<br><font> Some text.......... </font>"
strBody = strBody & "</body>"
strBody = strBody & "</html>"
Cre_Body = strBody
End Function
Public Function Cre_BCC()
Dim strBBClist As String
'Important: emails must be semicolon delimited
'you will need to create a procedure to build the bcc list.
'as a test use a fixed email string of a valid email account.
'in my code I loop through an Access table of emails using a recordset
Cre_BCC = strBBClist
End Function
Public Function CreateOutlookItem(ByVal sSubject As String, ByVal sBody As String, ByVal sRecip As String, ByVal sAttach As String) As Boolean
On Error GoTo Err_Handler
Dim oOutApp As Object
Dim oMail As Object
Dim oCont As Object
Dim intMail As Integer
Const cMailItem As Long = 0
'using late binding allows setting an instance of outlook for different versions.
Set oOutApp = GetOutlookObject()
On Error GoTo Err_Handler
Set oMail = oOutApp.CreateItem(cMailItem)
With oMail
'.Recipients.Add sRecip
.bcc = sRecip
'.To = sRecip
.Subject = sSubject
'use for standard body
'.body = sBody
'use for HTML body
.HTMLBody = sBody
.Importance = 1 'Importance Level 0=Low,1=Normal,2=High
If Len(sAttach) > 0 And Dir(sAttach) <> "" Then
.Attachments.Add sAttach
End If
'.display add if you don't want to autosend but want to view the email.
.Send
End With
Exit_Here:
Exit Function
Err_Handler:
sMsg = Err.Description
If sType = "Contact" Then sMsg = sMsg & " data=" & sBody
MsgBox sMsg, vbExclamation, "Error"
Resume Exit_Here
End Function
Public Function GetOutlookObject() As Object
'this procedure attempts to set the object to existing process of outlook.application
'and if the outlook process is not running it attempts to create it.
Dim oOutApp As Object
Dim sMsg As String
' We turn Error Handling OFF so we can attempt a call and test for errors.
On Error Resume Next
' If Outlook is already open, then use GetObject to set a reference to it.
' If you know version, then comment out the unneeded calls below.
Set oOutApp = GetObject(, "Outlook.Application")
If Err.Number > 0 Then ' Outlook 97 version
Err.Clear
Set oOutApp = GetObject(, "Outlook.Application.9")
End If
If Err.Number > 0 Then ' Outlook XP version
Err.Clear
Set oOutApp = GetObject(, "Outlook.Application.10")
End If
If Err.Number > 0 Then ' Outlook 2003 version
Err.Clear
Set oOutApp = GetObject(, "Outlook.Application.11")
End If
If Err.Number > 0 Then ' Outlook 2007 version
Err.Clear
Set oOutApp = GetObject(, "Outlook.Application.12")
End If
If Err.Number > 0 Then ' Outlook 2010 version
Err.Clear
Set oOutApp = GetObject(, "Outlook.Application.14")
End If
If Err.Number Then
Err.Clear
' If code failed to "Get" an instance of Outlook, then it isn't currently
' open and we must use CreateObject to open and set a reference.
Set oOutApp = CreateObject("Outlook.Application")
' If another error has occurred, then Outlook couldn't be opened.
' Inform user and abort.
If Err.Number > 0 Then
sMsg = "Could not open Outlook. " & vbCrLf & vbCrLf & _
"Either Outlook is not installed correctly, " & vbCrLf & _
"or there is a problem with the installation. " & vbCrLf & vbCrLf & _
"Try opening Outlook before running this utility. "
MsgBox sMsg, vbCritical, "Outlook Failed to Open"
Set oOutApp = Nothing
Exit Function
End If
End If
Set GetOutlookObject = oOutApp
End Function
Public Sub PauseApp(PauseInSeconds As Long)
'for the PauseApp to work you must put this string at the top in the options compare section of the module.... Private Declare Sub AppSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
'what I like about this procedure is that it is not demanding on cpu cycles when running.
Call AppSleep(PauseInSeconds * 1000)
End Sub
Sub Close_Outlook()
'this sub keeps access waiting for the outlook outbox to empty
Dim oOutApp As Object
Dim IsItSent As Integer
Dim objNameSpace As NameSpace
Dim objFolder As MAPIFolder
On Error GoTo Err_Handler
Set oOutApp = GetOutlookObject()
Set objNameSpace = oOutApp.GetNamespace("MAPI")
Set objFolder = objNameSpace.GetDefaultFolder(olFolderOutbox)
Set objRec = objNameSpace.CurrentUser
IsItSent = objFolder.Items.Count 'update the count to determine if we need to loop
Do While IsItSent > 0
IsItSent = objFolder.Items.Count 'update the count inside the loop
PauseApp 10
Loop
Set oOutApp = Nothing
Set oMail = Nothing
Set objNameSpace = Nothing
Set objFolder = Nothing
Set objRec = Nothing
Exit_Here:
Exit Sub
Err_Handler:
sMsg = Err.Description
If sType = "Contact" Then sMsg = sMsg & " data=" & sBody
MsgBox sMsg, vbExclamation, "Error"
Resume Exit_Here
End Sub
