[AccessD] Email problem. Again

Max,

The problem with CDO is that it may not be there.  That's the reason we started using Redemption years ago.  CDO is no longer installed with Windows or with Office.  If the user doesn't take steps to install it, it won't be available.

Charlotte Foust

-----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