Option Compare Database
Option Explicit
Const cdoSendUsingPort = 2
Function CDOSend(ServerName As String, _
UserName As String, _
Password As String, _
ToRecipients As String, _
CCRecipients As String, _
BCCRecipients As String, _
Subject As String, _
Body As String, _
ParamArray Attachments() As Variant) As String
'ServerName: name or IP of the email server
'UserName: a valid email account
'Password: everone knows what that is
'ToRecipients: list of recipients, 'To' field
'CCRecipients: list of recipients, 'CC' field
'BCCRecipients: list of recipients, 'BCC' field
'Subject: whatever mail subject
'Body: some meaningless text
'Attachments: list of files to be attached, separated by comma
Const conRetries = 10
Dim intRetries As Integer
Dim strServer As String
Dim strUserName As String
Dim strPassword As String
Dim strFileName
Dim i As Integer
'========================================================
'====Uncomment the block if late binding does not work===
'========================================================
'Dim IMSG As New CDO.Message
'Dim ICONF As New CDO.Configuration
'=======================================================
'========================================================
'====Comment the block if late binding does not work=====
'========================================================
Dim IMSG As Object
Dim ICONF As Object
'========================================================
strServer = ServerName
strUserName = UserName
strPassword = Password
start:
On Error GoTo errhandler
Set IMSG = CreateObject("CDO.Message")
Set ICONF = CreateObject("CDO.Configuration")
With ICONF.Fields
' configuration information for SMTP server
' Specifie the method used to send messages.
.Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/sendusing")[/URL] = _
cdoSendUsingPort
' The name (DNS) or IP address of the machine
' hosting the SMTP service through which
' messages are to be sent.
.Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/smtpserver")[/URL] = _
strServer ' Or "mail.server.com"
' Specify the authentication mechanism
' to use.
.Item _
("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")[/URL] = _
1
' The username for authenticating to an SMTP server using basic (clear-text) authentication
.Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/sendusername")[/URL] = _
strUserName
' The password used to authenticate
' to an SMTP server using authentication
.Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/sendpassword")[/URL] = _
strPassword
' The port on which the SMTP service
' specified by the smtpserver field is
' listening for connections (typically 25)
.Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/smtpserverport")[/URL] = _
25
'Use SSL for the connection (False or True)
.Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/smtpusessl")[/URL] = _
False
' Set the number of seconds to wait for a valid socket to be established with the SMTP service before timing out.
.Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout")[/URL] = _
60
' Update configuration
.Update
End With
' Build HTML for message body.
' Apply the settings to the message.
With IMSG
Set .Configuration = ICONF
.To = ToRecipients 'Enter a valid email address.
.cc = CCRecipients
.bcc = BCCRecipients
.FROM = UserName & "@yourdomain.com" 'Enter a valid email address.
.Subject = Subject
'.Body = "<html><body><b>Hello World</b></body></html>"
.TextBody = Body
'strfilename = Dir(AttachFolder & "\*.*", vbNormal)
For i = 0 To UBound(Attachments)
On Error Resume Next
.AddAttachment Attachments(i)
Next
On Error GoTo errhandler
.Send
End With
exithere:
Set IMSG = Nothing
Set ICONF = Nothing
Exit Function
errhandler:
If intRetries < conRetries Then
intRetries = intRetries + 1
Resume start
Else
If strServer <> "AlternateServer" Then
strServer = "AlternateServer"
strUserName = "AlternateUser"
strPassword = "AlternatePassword"
intRetries = 0
Resume start
End If
End If
CDOSend = Err.Number & Err.Description
Resume exithere
End Function![[pipe]](/data/assets/smilies/pipe.gif "[pipe] [pipe]")
