[AccessD] Email problem. Again

Max:

Thanks for the code.  I may use that instead of the existing code as it
looks like the problem may not have been my code or CDO but authentication.
Using the vbSendMail that Dan pointed me to, I was able to raise the error
event and it appeared to be an authentication problem.  If so, then the
network guy should have some input for us.

I see in your code, however, a comment on what the authentication constants
are.  The original CDO code used Basic.  I'm wondering if one of the others
might work.

Rocky
 

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Max Wanadoo
Sent: Wednesday, March 03, 2010 2:40 AM
To: Access Developers discussion and problem solving
Subject: Re: [AccessD] Email problem. Again

Here are THREE examples that work using CDO.  Nothing to Register, just
replace the examples with real data.

Max

Option Compare Database
Option Explicit
' intServerPort could be 587  or 465 but usually 25 ' intAuthenticate can be
0 = Anonymous, 1 = Basic 2= cdoNTLM, 3 = cdoMessage Sub SendVia1()
    Call pfEmailByCDO( _
         strFrom:="Server <Server at myserver.com>", _
         strSubject:="My Subject", _
         strBody:="My Body", _
         strTo:="my.client at client.com;secretary at client.com", _
         strCC:="", _
         strBCC:="", _
         strSMTPServer:="mail.myserver.com", _
         strSMTPUserName:="server at myserver.com", _
         strSMTPPwd:="mysecretpassword", _
         strUsesSSL:="False", _
         bDisplay:=True, _
         intPort:=2, _
         intServerPort:=25, _
         intAuthenticate:=1, _
         intSecs2Wait:=60, _
         strAttachment:="c:\MyTest.txt") End Sub Sub SendVia2()
    Call pfEmailByCDO( _
         strFrom:="Developer <great.stuff at developers.com>", _
         strSubject:="My Subject", _
         strBody:="My Body", _
         strTo:="my.client at client.com", _
         strCC:="", _
         strBCC:="", _
         strSMTPServer:="smtp.developers.com", _
         strSMTPUserName:="great.stuff at developers.com", _
         strSMTPPwd:="mysecretpassword", _
         strUsesSSL:="False", _
         bDisplay:=True, _
         intPort:=2, _
         intServerPort:=25, _
         intAuthenticate:=1, _
         intSecs2Wait:=60, _
         strAttachment:="c:\MyTest.txt") End Sub Sub SendViaGoogle()
    Call pfEmailByCDO( _
         strFrom:="My Google <me.google at googlemail.com>", _
         strSubject:="My Google Subject", _
         strBody:="My Body", _
         strTo:="my.client at client.com", _
         strCC:="", _
         strBCC:="", _
         strSMTPServer:="smtp.gmail.com", _
         strSMTPUserName:="me.google", _
         strSMTPPwd:="mysecretpassword", _
         strUsesSSL:="true", _
         bDisplay:=True, _
         intPort:=2, _
         intServerPort:=465, _
         intAuthenticate:=1, _
         intSecs2Wait:=60, _
         strAttachment:="c:\MyTest.txt") End Sub

Public Function pfEmailByCDO(strFrom As String, strSubject As String,
strBody As String, _
                             strTo As String, strCC As String, strBCC As
String, _
                             strSMTPServer, strSMTPUserName, strSMTPPwd,
strUsesSSL, _
                             intPort, intServerPort, intAuthenticate,
intSecs2Wait, _
                             bDisplay As Boolean, Optional strAttachment As
String)
    On Error GoTo errhandler
    Const conErr1 As String = "The SMTP server rejected one or more
recipient addresses. Response was: 550 "
    Const conErr2 As String = "The SMTP server rejected one or more
recipient addresses. Response was: 501 bad address syntax: <"
    Const ConErrX As String = "The transport failed to connect to the SMTP
server"
    Dim strErr As String
    Dim objMessage
    Set objMessage = CreateObject("CDO.Message")    ' Create the message
object.
    objMessage.from = strFrom
    objMessage.To = strTo
    objMessage.cc = strCC
    objMessage.bcc = strBCC
    objMessage.Subject = strSubject
    ' Now for the Message Options Part.
    objMessage.TextBody = strBody
    objMessage.AddAttachment strAttachment
    objMessage.Configuration.Fields.Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPServer
    objMessage.Configuration.Fields.Item("
http://schemas.microsoft.com/cdo/configuration/sendusername") =
strSMTPUserName
    objMessage.Configuration.Fields.Item("
http://schemas.microsoft.com/cdo/configuration/sendpassword") = strSMTPPwd
    objMessage.Configuration.Fields.Item("
http://schemas.microsoft.com/cdo/configuration/smtpusessl") = strUsesSSL
    objMessage.Configuration.Fields.Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport") =
intServerPort
    objMessage.Configuration.Fields.Item("
http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") =
intAuthenticate
    objMessage.Configuration.Fields.Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = intPort
    objMessage.Configuration.Fields.Item("
http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") =
intSecs2Wait
    objMessage.Configuration.Fields.Update    ' Update configuration
    If bDisplay Then
        MsgBox objMessage.GetStream.ReadText  ' Use to show the message.
    End If
    objMessage.Send  ' Send the message.
    DoEvents
exithere:
    Exit Function
errhandler:
    strErr = "pfEmailByCDO - Send Errors " & Err.Description
    If InStr(strErr, ConErrX) > 0 Then
        strErr = strErr & " No Email Sent"
    End If
    Debug.Print strErr
    MsgBox strErr
    GoTo exithere
End Function
Private Function fFileContents(strFilePath As String) As String 'These
constants are defined to make the code more readable
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim fso, f
    Set fso = CreateObject("Scripting.FileSystemObject")
    'Open the file for reading
    Set f = fso.OpenTextFile(strFilePath, ForReading)
    'The ReadAll method reads the entire file
    fFileContents = f.ReadAll
    f.Close    'Close the file
    Set f = Nothing
    Set fso = Nothing
End Function
--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com