View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Steve Steve is offline
external usenet poster
 
Posts: 1,814
Default Email Using CDO - mixed results

I have successfully used the CDO code provided by Ron deBruin site. It works
great from my desktop computer directly connect to the web. However, when I
move it to my laptop, which uses my wireless router to access the web, it
fails on the ".send" with Run-time failure "-2147220973 (80040213)': The
transport failed to connect to the server.

Does anyone have a solution for this problem. I'd appreciate it! Code
follows:

Sub MailWorkbook(emailaddr, mbrpth, emailcontact)
'This procedure will mail the whole workbook
'You can't send a Workbook that is open with CDO.
'That's why it use SaveCopyAs to save it with another name and send that file.
'Working in 2000-2007
Dim wb As Workbook
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant

Set wb = ActiveWorkbook

If Val(Application.Version) = 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no
VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro
again.", vbInformation
Exit Sub
End If
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds

..Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True

..Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1

..Item("http://schemas.microsoft.com/cdo/configuration/sendusername") =
"

..Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") =
"africa99"

..Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"smtp.gmail.com"

..Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

..Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With

With iMsg
Set .Configuration = iConf
.To = emailaddr
.cc = ""
.BCC = ""
.From = """Peggy Newell"" "
.Subject = Range("EmailSubj")
If emailcontact = "" Then
.textbody = Range("EmailMsg") & Range("EmailClose")
Else
.textbody = Replace(Range("EmailMsg"), "Member,", emailcontact &
",") & Range("EmailClose")
End If
If mbrpth < "Skip" Then .AddAttachment mbrpth
.Send
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub