CDO email procedure produces error

[evenlater]

I have a procedure in Access that sends an email via CDO using a gmail
account. 90% of the time it works, but some of my users are getting
this error message: "The message could not be sent to the SMTP server.
The transport error code was 0x80040217. The server response was not
available."

I've heard this message sometimes occurs if the server has disabled
your account for spamming because you've sent 1500+ mails, but that's
not the case here. The user's email distribution list is between 3 and
10 addresses.

Here's my code in case that helps:
-------------------------------------------------------------------------------------------------------------------------------------
Public Function SendCDOEmail(strTo As String, strFrom As String,
strSubject As String, _
strBody As String, strReplyTo As String, Optional strCC As String, _
Optional strBcc As String, Optional strAttachments As String) As
Boolean
On Error GoTo Err_SendCDOEmail
Dim iMsg As Object
Dim iconf As Object
Dim flds As Object
Dim schema As String
Dim strList As String
Dim intSemicolon As Integer

DoCmd.Hourglass True

Set iMsg = CreateObject("CDO.Message")
Set iconf = CreateObject("CDO.Configuration")
Set flds = iconf.Fields

' send one copy with Google SMTP server (with authentication)
schema = "http://schemas.microsoft.com/cdo/configuration/"
flds.Item(schema & "sendusing") = 2
flds.Item(schema & "smtpserver") = "smtp.gmail.com"
flds.Item(schema & "smtpserverport") = 465
flds.Item(schema & "smtpauthenticate") = 1
flds.Item(schema & "sendusername") = "add...@gmail.com"
flds.Item(schema & "sendpassword") = "password"
flds.Item(schema & "smtpusessl") = 1
flds.Update

With iMsg
.To = strTo
.CC = strCC
.BCC = strBcc
.FROM = strFrom & " <add...@gmail.com>"
.Subject = strSubject
.TextBody = strBody
.Sender = strFrom
.Organization = "My Company"
.ReplyTo = strReplyTo
Set .Configuration = iconf

'If the email contains any attachments...
If Len(strAttachments) > 0 Then

'Loop through the string of attachments as long as there
is still at least one semicolon,
'Adding each attachment one by one.
Do While strAttachments Like "*;*"
intSemicolon = InStr(strAttachments, ";")
.AddAttachment Trim(Mid(strAttachments, 1,
intSemicolon - 1))
strAttachments = Mid(strAttachments, intSemicolon + 1)
Loop

'After we're past all the semicolons, attach the last
attachment in the string.
.AddAttachment Trim(strAttachments)

End If

'Send the email.
.Send
SendCDOEmail = True
End With

Exit_SendCDOEmail:
Set iconf = Nothing
Set iMsg = Nothing
Set flds = Nothing
DoCmd.Hourglass False
Exit Function

Err_SendCDOEmail:
If Err.Number = -2147024894 Then
MsgBox "Invalid attachment.", vbCritical, "Can't Send"
Else
MsgBox "Err #" & Err.Number & ": " & Err.Description
SendCDOEmail = False
Resume Exit_SendCDOEmail
End If
End Function
-------------------------------------------------------------------------------------------------

[John Mishefske]

evenlater wrote:
> I have a procedure in Access that sends an email via CDO using a gmail
> account. 90% of the time it works, but some of my users are getting
> this error message: "The message could not be sent to the SMTP server.
> The transport error code was 0x80040217. The server response was not
> available."

I couldn't find anything that differs from working code I have other
than setting a longer connection timeout:

flds.Item(schema & "smtpconnectiontimeout") = 180

--
John Mishefske, Microsoft MVP 2007 - 2009
UtterAccess Editor
Tigeronomy Software
web: http://www.tigeronomy.com
email: sales ~at~ tigeronomy.com