Automate Emails 2

[lars7]

Hi,
Help needed.
I Got these modules, to automate emails, from a sample database and I'm trying to alter them to fit my database. I have them working but they are both called the same name "SeparateEmails()" so when I call the sub I get an "ambiguous name detected" also as I had to convert the sample database from access 97 to 2000 I was wondering if the code needed to be updated a little too. Also could someone explain to me why there is 2 of them, the first one seems to create the query and then send out a million emails to the same person but the second one will not start if the query does not exist and there's an annoying message box from outlook that I would need to say yes to for every email.. %-)

Module1:

Sub SeparateEmails()
'*** error trapping - execution goes to bottom on error
On Error GoTo Err_SeparateEmails

Dim db As Database
Dim qdf As QueryDef
Dim strSQL As String
Dim rstblAutoEmail As Recordset
Dim rsCriteria As Recordset

Set db = CurrentDb
Set rsCriteria = db.OpenRecordset("tblAutoEmail", dbOpenSnapshot)

'*** 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 tblAutoEmail WHERE "
strSQL = strSQL & "[PPlayerId] = " & rsCriteria![PPlayerId] & ""
'MsgBox strSQL
'*** delete the previous query
db.QueryDefs.Delete "QryAutoEmailReport"
Set qdf = db.CreateQueryDef("QryAutoEmailReport", strSQL)

DoCmd.SendObject acReport, "RptAutoEmailReport", "RichTextFormat(*.rtf)", rsCriteria![PPlayer], "", "", "This is a test", "I am testing a new idea for reports", False, ""
rsCriteria![Emailed] = True

'*** goto the next record in Criteria table
rsCriteria.MoveNext

Loop

rsCriteria.Close

Exit_SeparateEmails:
Exit Sub

Err_SeparateEmails: '*** 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_SeparateEmails
End If

End Sub


Module2

Sub SeparateEmails()
'*** error trapping - execution goes to bottom on error
On Error GoTo Err_SeparateEmails

Dim db As Database
Dim qdf As QueryDef
Dim strSQL As String
Dim rstblAutoEmail As Recordset
Dim rsCriteria As Recordset

Set db = CurrentDb
Set rsCriteria = db.OpenRecordset("tblPlayer2", dbOpenDynaset)

'*** 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 tblAutoEmail WHERE "
strSQL = strSQL & "[PPlayerId] = " & rsCriteria![PPlayerId] & ""
'strSQL = strSQL & " and [QPoints] = " & rsCriteria![PPlayerId2] & ""

'MsgBox strSQL
'*** delete the previous query
db.QueryDefs.Delete "QryAutoEmailReport"
Set qdf = db.CreateQueryDef("QryAutoEmailReport", strSQL)

DoCmd.SendObject acReport, "RptAutoEmailReport", "RichTextFormat(*.rtf)", rsCriteria![PPlayer], "", "", "This is a test", "I am testing a new idea for reports", False, ""
rsCriteria.Edit
rsCriteria![Emailed] = True
rsCriteria.Update

'*** goto the next record in Criteria table
ContinueToNext:
rsCriteria.MoveNext

Loop

rsCriteria.Close

Exit_SeparateEmails:
Exit Sub

Err_SeparateEmails: '*** 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 ContinueToNext
Else
'*** write out the error and exit the sub
MsgBox Err.Description
Resume Exit_SeparateEmails
End If

End Sub

 

[SeeThru]

On a very quick glance it looks like somone was testing something


Rename one of them to SeparateEmail1 to prevent the ambigous error.

What is the Outlook dialog box that comes up?

 

[lars7]

Hi SeeThru,

I have combined both the modules and removed all the duplication from them and will run the code from the on click of a command button. Here is the code:

Private Sub Command3_Click()
On Error GoTo Err_AutoEmails
Dim db As Database
Dim qdf As QueryDef
Dim strSQL As String
Dim rsCriteria As Recordset
Set db = CurrentDb

strSQL = "SELECT tblPlayer.PPlayerId AS PId, tblPlayer.PPlayer, tblfixtures.FTeam1, [GScore1] & ' v ' & [GScore2] AS Rst, tblfixtures.FTeam2, qryGameScore.QPoints " & _
"FROM (tblfixtures INNER JOIN qryGameScore ON tblfixtures.GameNo = qryGameScore.GGameNo) INNER JOIN tblPlayer ON qryGameScore.GPlayerId = tblPlayer.PPlayerId "

'*** Delete the old query then create the new one
db.QueryDefs.Delete "QryAutoEmailReport"
Set qdf = db.CreateQueryDef("QryAutoEmailReport", strSQL)


Set rsCriteria = db.OpenRecordset("tblPlayer2", dbOpenDynaset)

'*** the first record in the Criteria table ***
rsCriteria.MoveFirst

'*** loop to move through the records in Criteria table
Do Until rsCriteria.EOF

DoCmd.SendObject acReport, "RptAutoEmailReport", "RichTextFormat(*.rtf)", rsCriteria![PPlayer], "", "", "This is a test", "I am testing a new idea for reports", False, ""
rsCriteria.Edit
rsCriteria![Emailed] = True
rsCriteria.Update

'*** goto the next record in Criteria table
ContinueToNext:
rsCriteria.MoveNext

Loop

rsCriteria.Close

Exit_AutoEmails:
Exit Sub

Err_AutoEmails: '*** 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 ContinueToNext
Else
'*** write out the error and exit the sub
MsgBox Err.Description
Resume Exit_AutoEmails
End If

End Sub

The error message said "A program is trying to automatically send e-mail on your behalf. Do you want to allow this. If this is unexpected it may be a virus...."

I found this on Access Accessory:

"Finally, you'll see that when you use this code you get prompted to confirm that it's okay for your program to send an e-mail using Outlook. This is a virus-protection method introduced by Microsoft (read their KnowledgeBase article on this for more info) to prevent script-kiddies writing malicious code to send self-propagating mails to everyone in your address book. Using straight Outlook this is largely unavoidable, so you'll have to get used to clicking the "Yes" button (unless you want to consider Outlook Redemption as a freeware solution to this inconvenience, although that means getting away from straight Outlook). At least you get an option to allow your program access to Outlook for up to 10 minutes, which can be handy if you're about to generate a whole load of e-mails."

Do you know anything about Outlook Redemption?

 

[kjv1611]

I agree with SeeThru totally. That looks like somenoe was testing to see which worked better for them, that's why you have two.

For the Outlook message, there's no way outside of possibly changing some security settings to get rid of the email - it's best to leave that as-is. It didn't pop up before, but b/c of security threats of viruses sending emails out of themselves, Microsoft added in that feature.

Another option to SeeThru's suggestion would be to comment out one of the sub-procedures, and use the other, then comment out the one you used, and uncomment the first commented out procedure, and that way, you could see which you wanted to use, and either leave the other commented out or delete it.
WOW! That's a lot of comments!

 

[PHV]

Do a google search for outlook object model guard

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[hwkranger]

USE CDO instead of outlook.

Example

'REQUIRES MICROSOFT CDO LIBRARY INCLUSION
Public Function SendOneEMailViaCDO(strBody As String, _
                                        strTo As String, _
                                        strFrom, _
                                        strBCC, _
                                        strSubject As String, _
                                        bolHighImportance As Boolean) As Boolean
   
    Const ROUTINE_NAME = "SendOneEMailViaCDO"
    
    Dim bolResults As Boolean
    Dim strServerName As String
    
    strServerName = "PUT YOUR STMP SERVER NAME HERE"
    
    bolResults = True
    
   
    Dim objCDOMsg As CDO.Message
    Dim objCDOConfiguration As CDO.Configuration
   
    
    
    Set objCDOMsg = CreateObject("CDO.Message")
    Set objCDOConfiguration = CreateObject("CDO.Configuration")
    
    With objCDOConfiguration
        
        .Fields.Item("urn:schemas:mailheader:X-Mailer") = "Microsoft CDO for Windows 2000"

        .Fields(cdoSendUsingMethod) = 2    'cdoSendUsingPort
        .Fields(cdoSMTPServer) = strServerName
        .Fields(cdoSMTPAuthenticate) = 0 'cdoAnonymous
        .Fields(cdoSMTPServerPort) = 25
        .Fields(cdoSMTPConnectionTimeout) = 10
        
        'message headers
        '.Fields.Item("urn:schemas:mailheader:date") = "Tue, 6 Oct 2005 11:15:08 -0700"
        '.Fields("Date") = "Tue, 6 Oct 2005 11:15:08 -0700"
        '.Fields.Update
        '.Fields.Resync
        
        
        If bolHighImportance = True Then
          .Fields(cdoImportance) = cdoHigh 'cdoHigh   'High importance
          .Fields("urn:schemas:mailheader:X-MSMail-Priority") = "High" 'cdoHigh
          .Fields("urn:schemas:mailheader:X-Priority") = 2
        Else
          .Fields(cdoImportance) = cdoNormal  'High importance
          .Fields("urn:schemas:mailheader:X-MSMail-Priority") = cdoNormal
          .Fields("urn:schemas:mailheader:X-Priority") = 5
        End If
        .Fields.Update
    End With
    
    Set objCDOMsg.Configuration = objCDOConfiguration

   With objCDOMsg
         .MimeFormatted = False
         .AutoGenerateTextBody = False
         .To = strTo
                     
         .From = strFrom
         .Subject = strSubject
         .HTMLBody = strBody
            
         If bolHighImportance = True Then
             '.Fields(cdoImportance) = cdoHigh
         Else
             '.Fields(cdoImportance) = cdoNormal
         End If
         .Fields.Update
         
         .Send
   End With
   
    Set objCDOMsg = Nothing
    Set objCDOConfiguration = Nothing
   
ExitRoutine:

   
End Function

Randall Vollen
National City Bank Corp.

 

[lars7]

Hi there,
Sorry for the delay but I was away for a few days.


Hwkranger:

I put my STMP server in but how do I get it to send my email.

PHV,

I downloaded "Outlook Redemption" but I think that I need to make some sort of reference to it in my code as I am still getting the messsage from outlook. I have seen some examples on the web page

http://www.dimastr.com/redemption/objects.htm

like this:

set Application = CreateObject("Outlook.Application")

set Namespace = Application.GetNamespace("MAPI")

Namespace.Logon

dim SafeItem, oItem
set SafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem
set oItem = Application.CreateItem(0) 'Create a new message
SafeItem.Item = oItem 'set Item property
SafeItem.Recipients.Add "somebody@somewhere.com"
SafeItem.Recipients.ResolveAll
SafeItem.Subject = "Testing Redemption"
SafeItem.Send

But when i try them I get 'object required messsage'

 

[kjv1611]

You probably are missing a reference. Try Tools -> References, and check "Microsoft Outlook 10.0 (or 11.0) Object Library"

If not that, then "Microsoft Office 10.0 (or 11.0 - whichever you have) Object Library"

 

[PHV]

I get 'object required messsage'
And which line of code is highlighted when in debug mode ?

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[lars7]

Hi PHV and kjv,

Sorry I was working from memory when I posted last night the message was "Method or data member not found"
and it is this ".GetNamespace" that is highlighted from this line "Set Namespace = Application.GetNamespace("MAPI")" also I had the "Microsoft Outlook 11.0 Object Library" ticked and added the "Microsoft Office 11.0 Object Library" but still the same.

the whole code is:

Private Sub Command3_Click()
On Error GoTo Err_Command3_Click
Dim db As Database
Dim qdf As QueryDef
Dim strSQL As String
Dim rsCriteria As Recordset
Set db = CurrentDb
Set Application = CreateObject("Outlook.Application")

Set Namespace = Application.GetNamespace("MAPI")

Namespace.Logon

Dim SafeItem, oItem
Set SafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem
Set oItem = Application.CreateItem(0) 'Create a new message
SafeItem.Item = oItem 'set Item property
SafeItem.Recipients.Add "somebody@somewhere.com"
SafeItem.Recipients.ResolveAll
SafeItem.Subject = "Testing Redemption"
SafeItem.Send

strSQL = "SELECT tblPlayer.PPlayerId AS PId, tblPlayer.PPlayer, tblfixtures.FTeam1, [GScore1] & ' v ' & [GScore2] AS Rst, tblfixtures.FTeam2, qryGameScore.QPoints, Left([PPlayer],InStr([PPlayer],'@')-1) AS UserName " & _
"FROM (tblfixtures INNER JOIN qryGameScore ON tblfixtures.GameNo = qryGameScore.GGameNo) INNER JOIN tblPlayer ON qryGameScore.GPlayerId = tblPlayer.PPlayerId "

'*** Delete the old query then create the new one
db.QueryDefs.Delete "QryAutoEmailReport"
Set qdf = db.CreateQueryDef("QryAutoEmailReport", strSQL)


Set rsCriteria = db.OpenRecordset("tblPlayer", dbOpenDynaset)

'*** the first record in the Criteria table ***
rsCriteria.MoveFirst

'*** loop to move through the records in Criteria table
Do Until rsCriteria.EOF

DoCmd.SendObject acReport, "rptAutoEmail", "SnapshotFormat(*.snp)", rsCriteria![PPlayer], "", "", "This is a test", "I am testing a new idea for reports", False, ""
rsCriteria.Edit
rsCriteria![Emailed] = True
rsCriteria.Update

'*** goto the next record in Criteria table
ContinueToNext:
rsCriteria.MoveNext

Loop


rsCriteria.Close

Exit_Command3_Click:
Exit Sub

Err_Command3_Click:
MsgBox Err.Description
Resume Exit_Command3_Click
End Sub

 

[PHV]

Application is a reserved word in VBA !

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[lars7]

Hi again,
I tried this one instead and got a different message "Array index out of bounds":

Dim SafeContact, oContact
Set SafeContact = CreateObject("Redemption.SafeContactItem") 'Create an instance of Redemption.SafeContactItem
Set oContact = Outlook.Session.GetDefaultFolder(10).Items(1) 'Get a contact item from Outlook
SafeContact.Item = oContact 'set Item property of a SafeContact to an Outlook contact item
MsgBox SafeContact.Email1Address 'access Email1Address property from SafeContact, no warnings are displayed

can you see anything wrong here.

 

[kjv1611]

Hmm, should you have your variables dimmed as this?

Dim SafeContact as Object, oContact as Object

 

[PHV]

Again, which line raises the error ?
The following seems suspect:
Set oContact = Outlook.Session.GetDefaultFolder(10).Items(1)

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[lars7]

Hi kjv,
I tried this but the same message.

Dim SafeContact As Object, oContact As Object
Set SafeContact = CreateObject("Redemption.SafeContactItem") 'Create an instance of Redemption.SafeContactItem
Set oContact = Outlook.Session.GetDefaultFolder(10).Items(1) 'Get a contact item from Outlook
SafeContact.Item = oContact 'set Item property of a SafeContact to an Outlook contact item
MsgBox SafeContact.Email1Address 'access Email1Address property from SafeContact, no warnings are displayed

 

[lars7]

Hi again,
You where right PHV it was that line but I tried this which also has the same line but it stoped the line after with this message: "User-defined type not defined":

Dim Contact As Object, oContact As Object
Set oContact = Outlook.Session.GetDefaultFolder(10).Items(1)
[COLOR=red yellow]Set Contact = New Redemption.SafeContactItem [/color]
Contact.Item = oContact 'never use "Set" when setting the Item property
MsgBox Contact.Email1Address

 

[lars7]

Hi,

Found a small programe here:

http://www.contextmagic.com/express-clickyes/

there is 2 versions of it one is free (It works great) and the full version for servers and stuff is about £10

Thanks to all who replyed to this post.