Hi Guys,
Hope you can help. I am using Access 2003. I have modified the attached code which was originally created to loop through a table and create a individual report based on a query and use the DoCmd.SendObject to send this report to a list of individual email addresses with the relevant report attached. The original code works fine for what I want it do and creates an email in outlook that when I send, it sends one email and then creates the next one in the same outlook Window ready to be sent.
Now I want to create an individual email with invidual account details and attach a pdf file from a shared drive. This all works fine except it creates each email in a new Outlook application (20 email addresses = 20 windows open etc). I cannot work out where I am going wrong - is the 'loop' in the wrong place or is the code 'set olkapps = New Outlook.Application' wrong.
Private Sub CmdSendBulkEmails_Click()
'**********************************
'Created by Roger Carlson *
'Roger.Carlson@spectrum-health.org*
'Rog3erc@aol.com *
'**********************************
'*** error trapping - execution goes to bottom on error
On Error GoTo Err_CmdSendBulkEmails_Click
Dim db As Database
Dim qdf As QueryDef
Dim strSQL As String
Dim rsNADEX_USER_TABLE As Recordset
Dim rsCriteria As Recordset
Dim strEmailTo As String
Dim strAttachment1 As String
Set db = CurrentDb
Set rsCriteria = db.OpenRecordset("Send_User_Acct_Table")
'*** the first record in the Criteria table ***
rsCriteria.MoveFirst
'*** loop to move through the records in Criteria table
Do Until rsCriteria.EOF
'*** create the Select query based on
' the first record in the Criteria table
strSQL = "SELECT * FROM NADEX_USER_TABLE WHERE "
strSQL = strSQL & "[CYMRU_ID] = '" & rsCriteria![CYMRU_ID] & "'"
'MsgBox strSQL
'*** delete the previous query
db.QueryDefs.Delete "NewQuery"
Set qdf = db.CreateQueryDef("NewQuery", strSQL)
strEmailTo = rsCriteria![CYMRU_MAIL]
Dim objNewMail
Dim strsubject As String
Dim strBody As String
strsubject = "NADEX User Account Details"
strBody = "Dear NADEX User, " & _
Chr(13) & Chr(13) & "You requested that we email you details of your new NADEX User account. They are as follows: " & Chr(13) & Chr(13) & "Username: " & rsCriteria![CYMRU_ID] & Chr(13) & Chr(13) & "Email Account Name: " & rsCriteria![CYMRU_MAIL] & " If you wish to do so please contact the IH Helpdesk " & Chr(13) & Chr(13) & "Please also see the attached Information leaflet and visit our Intranet for the latest up to date news at http://www.etc.co.uk/NADEX. " & Chr(13) & Chr(13) & "Regards," & Chr(13) & Chr(13) & "NADEX Team"
strAttachment1 = "S:\Online Forms\NADEX\Att1_NADEX PDF Leaflet.pdf"
'sets up the paramenters required for an email and then communicates with outlook
Dim olkapps As Outlook.Application 'set the application
Dim olknamespaces As Outlook.NameSpace
Dim objmailitems As Outlook.MailItem ' and that it will be an email
Set olkapps = New Outlook.Application
Set olknamespaces = GetNamespace("MAPI")
Set objmailitems = olkapps.CreateItem(olMailItem)
With objmailitems
.To = strEmailTo
.Subject = strsubject
.Body = strBody
.Attachments.Add (strAttachment1)
.Display ' display the email rather than just send it (.send if req'd)
End With
rsCriteria.MoveNext
'*** goto the next record in Criteria table
Loop
rsCriteria.Close
Set objmailitems = Nothing
Set olknamespaces = Nothing
Set olkapps = Nothing
Exit_CmdSendBulkEmails_Click:
Exit Sub
Err_CmdSendBulkEmails_Click: '*** if there is an error, execution goes here
'*** if the error is the table or query missing (3265)
' then skip the delete line and resume on the next line
' Error 2501 notifies you that the SendObject action
' has been cancelled. See the OnNoData Event of the report.
If Err.Number = 3265 Or Err.Number = 2501 Then
Resume Next
Else
'*** write out the error and exit the sub
MsgBox Err.Description
Resume Exit_CmdSendBulkEmails_Click
End If
End Sub
Grateful for your advice on this.
Cheers,
Hope you can help. I am using Access 2003. I have modified the attached code which was originally created to loop through a table and create a individual report based on a query and use the DoCmd.SendObject to send this report to a list of individual email addresses with the relevant report attached. The original code works fine for what I want it do and creates an email in outlook that when I send, it sends one email and then creates the next one in the same outlook Window ready to be sent.
Now I want to create an individual email with invidual account details and attach a pdf file from a shared drive. This all works fine except it creates each email in a new Outlook application (20 email addresses = 20 windows open etc). I cannot work out where I am going wrong - is the 'loop' in the wrong place or is the code 'set olkapps = New Outlook.Application' wrong.
Private Sub CmdSendBulkEmails_Click()
'**********************************
'Created by Roger Carlson *
'Roger.Carlson@spectrum-health.org*
'Rog3erc@aol.com *
'**********************************
'*** error trapping - execution goes to bottom on error
On Error GoTo Err_CmdSendBulkEmails_Click
Dim db As Database
Dim qdf As QueryDef
Dim strSQL As String
Dim rsNADEX_USER_TABLE As Recordset
Dim rsCriteria As Recordset
Dim strEmailTo As String
Dim strAttachment1 As String
Set db = CurrentDb
Set rsCriteria = db.OpenRecordset("Send_User_Acct_Table")
'*** the first record in the Criteria table ***
rsCriteria.MoveFirst
'*** loop to move through the records in Criteria table
Do Until rsCriteria.EOF
'*** create the Select query based on
' the first record in the Criteria table
strSQL = "SELECT * FROM NADEX_USER_TABLE WHERE "
strSQL = strSQL & "[CYMRU_ID] = '" & rsCriteria![CYMRU_ID] & "'"
'MsgBox strSQL
'*** delete the previous query
db.QueryDefs.Delete "NewQuery"
Set qdf = db.CreateQueryDef("NewQuery", strSQL)
strEmailTo = rsCriteria![CYMRU_MAIL]
Dim objNewMail
Dim strsubject As String
Dim strBody As String
strsubject = "NADEX User Account Details"
strBody = "Dear NADEX User, " & _
Chr(13) & Chr(13) & "You requested that we email you details of your new NADEX User account. They are as follows: " & Chr(13) & Chr(13) & "Username: " & rsCriteria![CYMRU_ID] & Chr(13) & Chr(13) & "Email Account Name: " & rsCriteria![CYMRU_MAIL] & " If you wish to do so please contact the IH Helpdesk " & Chr(13) & Chr(13) & "Please also see the attached Information leaflet and visit our Intranet for the latest up to date news at http://www.etc.co.uk/NADEX. " & Chr(13) & Chr(13) & "Regards," & Chr(13) & Chr(13) & "NADEX Team"
strAttachment1 = "S:\Online Forms\NADEX\Att1_NADEX PDF Leaflet.pdf"
'sets up the paramenters required for an email and then communicates with outlook
Dim olkapps As Outlook.Application 'set the application
Dim olknamespaces As Outlook.NameSpace
Dim objmailitems As Outlook.MailItem ' and that it will be an email
Set olkapps = New Outlook.Application
Set olknamespaces = GetNamespace("MAPI")
Set objmailitems = olkapps.CreateItem(olMailItem)
With objmailitems
.To = strEmailTo
.Subject = strsubject
.Body = strBody
.Attachments.Add (strAttachment1)
.Display ' display the email rather than just send it (.send if req'd)
End With
rsCriteria.MoveNext
'*** goto the next record in Criteria table
Loop
rsCriteria.Close
Set objmailitems = Nothing
Set olknamespaces = Nothing
Set olkapps = Nothing
Exit_CmdSendBulkEmails_Click:
Exit Sub
Err_CmdSendBulkEmails_Click: '*** if there is an error, execution goes here
'*** if the error is the table or query missing (3265)
' then skip the delete line and resume on the next line
' Error 2501 notifies you that the SendObject action
' has been cancelled. See the OnNoData Event of the report.
If Err.Number = 3265 Or Err.Number = 2501 Then
Resume Next
Else
'*** write out the error and exit the sub
MsgBox Err.Description
Resume Exit_CmdSendBulkEmails_Click
End If
End Sub
Grateful for your advice on this.
Cheers,