Expert: Scottgem - 9/14/2009

Question
Hello,

I am looking for a software program, or method within Access and Outlook, that will help in sending out e-mails to managers with personal information on their Firm. For example, each month I would like to send out an e-mail notifying a manger on the last update we have received for the their fund or funds. Currently, I have to copy and paste the information from Access to Excel, and then filter the list. I then have to organize the data for the mailing function in Excel. This takes too long and is hard to customize for each fund with each manager. Any suggestions would be greatly appreciated. Thanks.

Answer
You caught me at a good moment. I just set this up for one of my clients. There are two modules to this process. The first can be kicked off by an event on a form. It prompts the user if they want to send to all managers or just the currently displayed one. If All is selected it loops through the manager table, grabs their e-mail address, populates a control on the form with the Mgr ID and generates an Excel file based on a query filtered for the current Mgr (by using the control  on the form to filter the query). For each Mgr it then processes the second module which generates the e-mail (Call SendLeadSS) .

'Send Leads spreadsheet to Mgr/Rep
Dim strAll As String, strSQL As String
Dim strEMail As String
Dim db As Database, rs As Recordset
Dim intEMCount As Integer

intEMCount = 0
strAll = ""

Do While strAll = ""
   'Check for current Mgr/Rep or All
   strAll = InputBox("Send to ALL Mgrs & Reps or just CURRENT Mgr/Rep?", "All or Current")
   If strAll = "All" Or strAll = "Current" Then
   Else
       MsgBox "Enter 'All' or 'Current'!", vbExclamation
       strAll = ""
   End If
Loop

If strAll = "Current" Then
   Me.txtToMgr = Me.ID 'Set Filter
   'Create Spreadsheet
   DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qryLeadSS", CurrDBDir & "Leads.xls"
   Call SendLeadSS(Me.EMail) 'Call mail proc
   intEMCount = 1
Else
   'Create recordset of all Mgrs/Reps
   strSQL = "SELECT DISTINCT MgrID FROM tblLeadMgr UNION Select RepID FROM tblLeadMgr;"
   Set db = CurrentDb()
   Set rs = db.OpenRecordset(strSQL)
   
   'Loop through listing sending e-mail with attached spreadsheet
   Do While Not rs.EOF
       Me.txtToMgr = rs.Fields("MgrID")
       strEMail = Nz(DLookup("[Email]", "tblManager", "[MgrID] = " & Me.txtToMgr), "")
       If strEMail <> "" Then
           DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qryLeadSS", CurrDBDir & "Leads.xls"
           Call SendLeadSS(strEMail)
           intEMCount = intEMCount + 1
       End If
       rs.MoveNext
   Loop
End If
MsgBox "E-Mail sent to " & intEMCount & " Mgrs/Reps!", vbInformation, "Notice"

Here is the SendLeadSS procedure
Public Sub SendLeadSS(strEM As String)
'Send E-mail with lead spreadsheet
On Error GoTo Err_SendLeadSS

Dim strTo As String
Dim strAttachmentFile As String
Dim strSubject As String
Dim strBody As String, strSQL As String
Dim strFilename As String, strReportName As String
Dim objOLA As Outlook.Application
Dim objOLMsg As Outlook.MailItem
Dim objOLRec As Outlook.Recipient
Dim objOLAttach As Outlook.Attachment
Dim wordApp As Word.Application, docNew As Word.Document
Dim rngRange As Word.Range
Dim db As Database
Dim rs As Recordset

Set db = CurrentDb()

'Set E-mail settings
strTo = strEM
strSubject = "Current Leads"
strBody = "Attached is current Leads assigned to you"

Set objOLA = CreateObject("Outlook.Application")
Set objOLMsg = objOLA.CreateItem(olMailItem)

'Create E-mail
With objOLMsg
   Set objOLRec = .Recipients.Add(strTo)
   objOLRec.Type = olTo
   .Subject = strSubject
   .Body = strBody
   .Importance = olImportanceHigh
   strAttachmentFile = CurrDBDir() & "Leads.xls"
   Set objOLAttach = .Attachments.Add(strAttachmentFile)
   .Display  'Only for testing
'    .Send
End With

'Cleanup
Set objOLMsg = Nothing
Set objOLA = Nothing

'Disable in test mode
'MsgBox "E-Mail sent!", vbInformation, "Notice"
   
Exit_SendLeadSS:
   Exit Sub

Err_SendLeadSS:
   MsgBox Err.Description
   Resume Exit_SendLeadSS
   
End Sub

Note: This is currently set to Display the e-mail for testing purposes. When you are satisfied it works, comment out .Display and uncomment .Send. You can set this code to run overnight if you have a large number of managers.

Hope this helps,
Scott<>
Microsoft Access MVP 2007
Author: Microsoft Office Access 2007 VBA