I am trying to write a routine that will email from access using outlook. I have it working with a couple of issues. The first is that when emailing from a queried list in access, it needs to check to see if an attachment exists and then email it if it does. The attachments are excel files that follow a specific naming convention that could be worked into a statment I just don't know how to check if an excel file exists. The second issue is prior to emailing, it always gives me a warning about a program trying to send using outlook. Is there any way to turn this off or do I want to do that?
Here is my code:
Option Compare Database
Private Sub Command0___Click()
Dim aSubject As String
Dim abody As String
Dim RSSpecialist As Recordset
Dim strfolder As String
Dim strfile As String
Dim aattachments As String
Dim arecipients As String
Dim strSpecialistname As String
Dim qdf As DAO.QueryDef
Dim strsql As String
strfolder = Trim(Me!txtfolder)
If Right(strfolder, 1) <> "\" Then
strfolder = strfolder & "\"
End If
txtCurrProfile = Null
DoEvents
strsql = "SELECT distinct [FS Specialists].[FS Specialist], [FS Specialists].Manager, [FS Specialists].Email From [FS Specialists] Where [Program Status]= 'active';"
Set DB = CurrentDb
Set qdf = DB.CreateQueryDef("", strsql)
Set RSSpecialist = qdf.OpenRecordset
RSSpecialist.MoveFirst
Do Until RSSpecialist.EOF
strSpecialistname = RSSpecialist("FS Specialist")
strfile = "FS Specialist " & strSpecialistname & ".xlsx"
arecipients = RSSpecialist("Email") & ""
aSubject = "Data for Update"
abody = strSpecialistname & ", Please review the attached file and update past numbers as well as adding current."
aattachments = strfolder & "FS Specialist " & strSpecialistname & ".xlsx"
If Not IsNull(strSpecialistname) And Len(Trim(strfile)) < 19 Then
Call SendEmail(aSubject, arecipients, abody, aattachments, strfolder)
End If
RSSpecialist.MoveNext
If RSSpecialist.EOF Then Exit Do
Loop
Me!txtCurrProfile = "Email Complete..."
DoEvents
RSSpecialist.Close
DB.Close
Set xlapp = Nothing
Set RSSpecialist = Nothing
Set DB = Nothing
End Sub
Private Sub SendEmail(aSubject As String, arecipients As String, abody As String, aattachments As String, strfolder As String)
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = arecipients
' If Not IsNull(txtCCemail) Then
' .CC = strCCemail
' End If
.Subject = aSubject
.Body = abody
.Attachments.Add (aattachments)
.Send
End With
objOutlook.Quit
Set objEmail = Nothing
End Sub
Thanks!
Here is my code:
Option Compare Database
Private Sub Command0___Click()
Dim aSubject As String
Dim abody As String
Dim RSSpecialist As Recordset
Dim strfolder As String
Dim strfile As String
Dim aattachments As String
Dim arecipients As String
Dim strSpecialistname As String
Dim qdf As DAO.QueryDef
Dim strsql As String
strfolder = Trim(Me!txtfolder)
If Right(strfolder, 1) <> "\" Then
strfolder = strfolder & "\"
End If
txtCurrProfile = Null
DoEvents
strsql = "SELECT distinct [FS Specialists].[FS Specialist], [FS Specialists].Manager, [FS Specialists].Email From [FS Specialists] Where [Program Status]= 'active';"
Set DB = CurrentDb
Set qdf = DB.CreateQueryDef("", strsql)
Set RSSpecialist = qdf.OpenRecordset
RSSpecialist.MoveFirst
Do Until RSSpecialist.EOF
strSpecialistname = RSSpecialist("FS Specialist")
strfile = "FS Specialist " & strSpecialistname & ".xlsx"
arecipients = RSSpecialist("Email") & ""
aSubject = "Data for Update"
abody = strSpecialistname & ", Please review the attached file and update past numbers as well as adding current."
aattachments = strfolder & "FS Specialist " & strSpecialistname & ".xlsx"
If Not IsNull(strSpecialistname) And Len(Trim(strfile)) < 19 Then
Call SendEmail(aSubject, arecipients, abody, aattachments, strfolder)
End If
RSSpecialist.MoveNext
If RSSpecialist.EOF Then Exit Do
Loop
Me!txtCurrProfile = "Email Complete..."
DoEvents
RSSpecialist.Close
DB.Close
Set xlapp = Nothing
Set RSSpecialist = Nothing
Set DB = Nothing
End Sub
Private Sub SendEmail(aSubject As String, arecipients As String, abody As String, aattachments As String, strfolder As String)
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = arecipients
' If Not IsNull(txtCCemail) Then
' .CC = strCCemail
' End If
.Subject = aSubject
.Body = abody
.Attachments.Add (aattachments)
.Send
End With
objOutlook.Quit
Set objEmail = Nothing
End Sub
Thanks!