Look through tables and send email to many recipients

[Juanna_v]

Hi to all. I need your help to do something that it's a bit complicated for me.
Some days before in this forum with the precious help of pbaldy I managed to use the code below which is very useful to send a different email to all recipients in a table. Now I was asked if it is possible to change the code so it can look through 7 different tables with dif structure but with common value the "BranchID", selects all branches with the same ID, exports their data into an xls file within a separate sheet for each table and then send the email. I hope I make it clear and I hope you can help me on this also. Thanks !!

Here is the code I use:
https://www.accessforums.net/reports...html#post48778
Dim qdf As DAO.QueryDef
Dim dbs As DAO.Database
Dim rstMgr As DAO.Recordset
Dim strSQL As String, strTemp As String, strMgr As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim DisplayMsg As Boolean
Dim varTo As Variant
Dim stWhere As String

On Error GoTo Err_SendMessage

Const strQName As String = "zExportQuery"

Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("q_temp")

strSQL = "SELECT DISTINCT ManagerID, ManagerEmail FROM EmployeesTable;"
Set rstMgr = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)

Do While rstMgr.EOF = False

strMgr = DLookup("ManagerID", "ManagersTable", _
"ManagerID = " & rstMgr!ManagerID.Value)

strSQL = "SELECT * FROM EmployeesTable WHERE " & _
"ManagerID = " & rstMgr!ManagerID.Value & ";"


qdf.SQL = strSQL
qdf.Close


' Replace C:\FolderName\ with actual path
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"q_temp", "C:\AccessAp\" & strMgr & Format(Now(), _
"ddMMMyyy_hhnn") & ".xls"

' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

With objOutlookMsg
' Set the Subject, Body, and Importance of the message.
.Subject = "Subject"
.Body = "Message"
.To = rstMgr!ManagerEmail
'.Importance = olImportanceHigh 'High importance

Set objOutlookAttach = .Attachments.Add("C:\AccessAp\" & strMgr & Format(Now(), _
"ddMMMyyy_hhnn") & ".xls")
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next

.Display

End With

rstMgr.MoveNext
Loop

Exit_SendMessage:

Set qdf = Nothing
Set objOutlook = Nothing
rstMgr.Close
Set rstMgr = Nothing
dbs.Close
Set dbs = Nothing
Exit Sub

Err_SendMessage:
MsgBox Error$
Resume Exit_SendMessage

[Juanna_v]

pls anyone

[aelissaw]

I have had this problem for long time, till i found that code in one of the forums, use the instruction in the comment section. hopefully this will help.




Sub SendMail()
Dim loRef As Access.Reference
Dim intCount As Integer
Dim intX As Integer
Dim blnBroke As Boolean
Dim strPath As String

' add code to send mail ------

'"writing SMTP control" - sample project, based on OstroSoft SMTP component
'written by Igor Ostrovsky (OstroSoft)
'
'OstroSoft SMTP component is available for download at
'http://www.ostrosoft.com/download/smtp_component.zip
'email questions, suggestions, comments to info@ostrosoft.com
'
'reregister DAO - regsvr32 "C:\Program Files\Common Files\Microsoft Shared\DAO\DAO350.dll"
'register OSSMTP.dll than add as a reference

'THIS IS WAHT KARL DID TO GET THIS TO WORK
'IT HAS TO BE DONE ON THE COMPUTER THAT THIS RUNS ON
'download this zip file
'http://www.ostrosoft.com/download/smtp_component.zip
'extract OSSMTP.dll from zip into C:\WINDOWS
'go to start run and enter 'cmd'. then key in 'regsvr32 OSSMTP.dll'
'open this 'Public Sub SendMail()' module and navigate to Tools\References and check the box next to 'OstroSoft SMTP component'

Dim oSMTP As New OSSMTP.SMTPSession
oSMTP.MailFrom = senderemail@add.com
oSMTP.Server = "Server.com"
oSMTP.Port = 25
'this one is for testing oSMTP.SendTo = "email00@add.com"
' seperate multiple names by a ,
oSMTP.SendTo = "email@add.com1, email2@add.com, email3@add.com"

'oSMTP.SendTo = "email@add.com1, email2@add.com, email3@add.com"


' seperate multiple names by a ,
'oSMTP.SendTo = "Your Email address"
' seperate multiple names by a ,
oSMTP.MessageSubject = "Daily Chrysler Invoices"
oSMTP.MessageText = "Please see attachment."
oSMTP.Attachments.Add ("S:\PURCHASE\USERS\AEl-lissawi\Auto_Email\OE_Reports\ChryslerInvoices.xls ")
oSMTP.SendEmail



'MsgBox "Email has been sent ..."


End Sub