The code below is the code I've been using to send emails from Access. It works fine. What I need to know is if it's possible to be able to add 1 or more attachments to it that are saved to a folder on my computer. Outlook does not have all of the user emails, as they are stored in Access and are always being added to/edited. Since I can't link Outlook to Access to keep it update with the client data that is Access it would be easier to use Access for the emails, esp. if they are bulk emails.
Thanks,
Leesha
Code: Select all
Dim strWhere As String
Dim strSQL As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strFilename As String
Dim outApp As Object
Dim outMsg As Object
Dim blnStart As Boolean
Dim arrNames As Variant
Dim i As Long
'checks to be sure reason for email is filled out
If IsNull(Me.Comment10) Then
MsgBox "There must be a description of the reason for the email before the emails can be sent."
Me.Comment10.SetFocus
Exit Sub
End If
If IsNull(Me.Subject) Then
MsgBox "The subject for the email must be entered before the emails can be sent."
Me.Subject.SetFocus
Exit Sub
End If
On Error Resume Next
' Try to get running instance of Outlook
Set outApp = GetObject(Class:="Outlook.Application")
If outApp Is Nothing Then
' If Outlook wasn't running, start it
Set outApp = CreateObject(Class:="Outlook.Application")
If outApp Is Nothing Then
' We failed to start Outlook, so get out
MsgBox "We can't start Outlook, sorry!", vbCritical
Exit Sub
End If
' Set a flag that we started Outlook
blnStart = True
End If
On Error GoTo ErrHandler
' Create the where-condition
strWhere = " WHERE EmailFaxSent = False"
strSQL = "SELECT ALL * FROM [qryEmailSpreadsheetBulkInsurance]" & strWhere
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL, dbOpenDynaset)
Do While Not rst.EOF
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
glngInvoiceID = rst!InvoiceID
strFilename = gstrPath & rst![WALMART NO] & "-" & _
rst!STORE_ID & "Insurance Info Request.pdf"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Create a new e-mail message
Set outMsg = outApp.CreateItem(0) ' olMailItem
With outMsg
' Use the e-mail address field
'Main Email
arrNames = Split(rst![FranchiseeEmail], ",")
For i = 0 To UBound(arrNames)
.Recipients.Add arrNames(i)
Next i
If Not IsNull(rst![Contact5Email]) Then
arrNames = Split(rst![Contact5Email], ",")
For i = 0 To UBound(arrNames)
' .Recipients.Add arrNames(i)
.Recipients.Add(arrNames(i)).Type = 2
Next i
End If
' Change the subject as needed
.Subject = rst![WALMART NO] & "-" & _
rst!STORE_ID & " Insurance Info Request"
.Body = Me.Comment1
.Send ' to send the message immediately
End With
'Set EmailFaxSent field to True, and EmailDateTimeSent to Now
rst.Edit
rst!EmailFaxSent = True
rst!EmailDateSent = Date
rst.Update
rst.MoveNext
Loop
MsgBox "Emails have been sent"
DoCmd.Close acForm, "frmOutputEmail"
ExitHandler:
On Error Resume Next
rst.Close
Set rst = Nothing
Set dbs = Nothing
If blnStart Then
outApp.Quit
End If
Set outMsg = Nothing
Set outApp = Nothing
Exit Sub
ErrHandler:
If Err = 2501 Then
Resume Next
Else
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End If