Bulk Email Loop Problem - I think?

BillyMac

Registered User.
Local time
Yesterday, 22:25
Joined
Feb 27, 2004
Messages
24
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,
 
PHP:
Dim olkapps As Outlook.Application 'set the application
there's your problem. dim the application before you get into the loop, not AFTER you're in it. that's the reason for your 20 windows, and I'm surprised your computer hasn't crashed yet too!
 
PHP:
Dim olkapps As Outlook.Application 'set the application
there's your problem. dim the application before you get into the loop, not AFTER you're in it. that's the reason for your 20 windows, and I'm surprised your computer hasn't crashed yet too!

I had similar problem. Solution was to Open Outlook in main routine, then just get outlook in a procedure that was called many times.

Here is a snippet from the procedure:
Code:
...
  Dim OUTLK As Object
    Dim omsg As Outlook.MailItem
    '**
    '** OUTLOOK MUST BE OPEN
    '**
   On Error GoTo SendEmailWithAttachment_Error

    Set OUTLK = GetObject(, "Outlook.Application")
    Set omsg = OUTLK.CreateItem(olMailItem)
....
..
 
Thanks Adam,

I sort of understand what you are saying but have tried placing the
Dim olkapps As Outlook.Application 'set the application
elsewhere in the code but it dfosen't seem to work. Could you tell me wher to place it?

Cheers,

BillyMac
 

Users who are viewing this thread

Back
Top Bottom