Our company recently migrated to from Exchange Server 2003 to Exchange Server
2007.

The following code had been working fine until the upgrade:

Any Ideas as to why it won't work after this upgrade?

Option Explicit

Sub CDO_Send_Selection_Or_Range_Body()
'Set rng = Sheets("YourSheet").Range("D412").SpecialCells(xlCellTypeVisible)
'Set rng = ActiveSheet.UsedRange
'Set rng = Sheets("YourSheet").UsedRange

Dim rng As Range
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim TempContactName As String

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/sendusing") = 2

..Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"FTWEV03.hca.corpad.net"

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


Set rng = Nothing
On Error Resume Next

'Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set rng = ActiveSheet.UsedRange

On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

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

With iMsg
Set .Configuration = iConf
'.To = "(E-Mail Removed)"
.To = "(E-Mail Removed)"
.CC = ""
.BCC = ""

'Remove special characters from contact name
TempContactName = Replace(Range("SubmitBy"), ".", "", 1, -1,
vbTextCompare)
TempContactName = Replace(TempContactName, ",", " ", 1, -1,
vbTextCompare)
.From = TempContactName & " <(E-Mail Removed)>"

.Subject = "New Implant Request " & Now() & " (by " &
Range("SubmitBy") & ")"
.HTMLBody = RangetoHTML(rng)
.Send
End With

MsgBox "Form has been submitted successfully"

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

End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") &
".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
"align=left xublishsource=")

'Close TempWB
TempWB.Close SaveChanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

This is the error I get when I run this code:

Run-time error '-2147220973 (80040213)':

The transport failed to connect to the server.


"Maldo" wrote:

> Our company recently migrated to from Exchange Server 2003 to Exchange Server
> 2007.
>
> The following code had been working fine until the upgrade:
>
> Any Ideas as to why it won't work after this upgrade?
>
> Option Explicit
>
> Sub CDO_Send_Selection_Or_Range_Body()
> 'Set rng = Sheets("YourSheet").Range("D412").SpecialCells(xlCellTypeVisible)
> 'Set rng = ActiveSheet.UsedRange
> 'Set rng = Sheets("YourSheet").UsedRange
>
> Dim rng As Range
> Dim iMsg As Object
> Dim iConf As Object
> Dim Flds As Variant
> Dim TempContactName As String
>
> 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/sendusing") = 2
>
> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
> "FTWEV03.hca.corpad.net"
>
> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
> .Update
> End With
>
>
> Set rng = Nothing
> On Error Resume Next
>
> 'Set rng = Selection.SpecialCells(xlCellTypeVisible)
> Set rng = ActiveSheet.UsedRange
>
> On Error GoTo 0
>
> If rng Is Nothing Then
> MsgBox "The selection is not a range or the sheet is protected" & _
> vbNewLine & "please correct and try again.", vbOKOnly
> Exit Sub
> End If
>
> With Application
> .EnableEvents = False
> .ScreenUpdating = False
> End With
>
> With iMsg
> Set .Configuration = iConf
> '.To = "(E-Mail Removed)"
> .To = "(E-Mail Removed)"
> .CC = ""
> .BCC = ""
>
> 'Remove special characters from contact name
> TempContactName = Replace(Range("SubmitBy"), ".", "", 1, -1,
> vbTextCompare)
> TempContactName = Replace(TempContactName, ",", " ", 1, -1,
> vbTextCompare)
> .From = TempContactName & " <(E-Mail Removed)>"
>
> .Subject = "New Implant Request " & Now() & " (by " &
> Range("SubmitBy") & ")"
> .HTMLBody = RangetoHTML(rng)
> .Send
> End With
>
> MsgBox "Form has been submitted successfully"
>
> With Application
> .EnableEvents = True
> .ScreenUpdating = True
> End With
>
> End Sub
>
>
> Function RangetoHTML(rng As Range)
> ' Changed by Ron de Bruin 28-Oct-2006
> ' Working in Office 2000-2007
> Dim fso As Object
> Dim ts As Object
> Dim TempFile As String
> Dim TempWB As Workbook
>
> TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") &
> ".htm"
>
> 'Copy the range and create a new workbook to past the data in
> rng.Copy
> Set TempWB = Workbooks.Add(1)
> With TempWB.Sheets(1)
> .Cells(1).PasteSpecial Paste:=8
> .Cells(1).PasteSpecial xlPasteValues, , False, False
> .Cells(1).PasteSpecial xlPasteFormats, , False, False
> .Cells(1).Select
> Application.CutCopyMode = False
> On Error Resume Next
> .DrawingObjects.Visible = True
> .DrawingObjects.Delete
> On Error GoTo 0
> End With
>
> 'Publish the sheet to a htm file
> With TempWB.PublishObjects.Add( _
> SourceType:=xlSourceRange, _
> Filename:=TempFile, _
> Sheet:=TempWB.Sheets(1).Name, _
> Source:=TempWB.Sheets(1).UsedRange.Address, _
> HtmlType:=xlHtmlStatic)
> .Publish (True)
> End With
>
> 'Read all data from the htm file into RangetoHTML
> Set fso = CreateObject("Scripting.FileSystemObject")
> Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
> RangetoHTML = ts.ReadAll
> ts.Close
> RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
> "align=left xublishsource=")
>
> 'Close TempWB
> TempWB.Close SaveChanges:=False
>
> 'Delete the htm file we used in this function
> Kill TempFile
>
> Set ts = Nothing
> Set fso = Nothing
> Set TempWB = Nothing
> End Function

Ask your IT people

Maybe they block it or the firewall block it

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Maldo" <(E-Mail Removed)> wrote in message news:9AF7089B-540A-4513-AF55-(E-Mail Removed)...
> This is the error I get when I run this code:
>
> Run-time error '-2147220973 (80040213)':
>
> The transport failed to connect to the server.
>
>
> "Maldo" wrote:
>
>> Our company recently migrated to from Exchange Server 2003 to Exchange Server
>> 2007.
>>
>> The following code had been working fine until the upgrade:
>>
>> Any Ideas as to why it won't work after this upgrade?
>>
>> Option Explicit
>>
>> Sub CDO_Send_Selection_Or_Range_Body()
>> 'Set rng = Sheets("YourSheet").Range("D412").SpecialCells(xlCellTypeVisible)
>> 'Set rng = ActiveSheet.UsedRange
>> 'Set rng = Sheets("YourSheet").UsedRange
>>
>> Dim rng As Range
>> Dim iMsg As Object
>> Dim iConf As Object
>> Dim Flds As Variant
>> Dim TempContactName As String
>>
>> 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/sendusing") = 2
>>
>> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
>> "FTWEV03.hca.corpad.net"
>>
>> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
>> .Update
>> End With
>>
>>
>> Set rng = Nothing
>> On Error Resume Next
>>
>> 'Set rng = Selection.SpecialCells(xlCellTypeVisible)
>> Set rng = ActiveSheet.UsedRange
>>
>> On Error GoTo 0
>>
>> If rng Is Nothing Then
>> MsgBox "The selection is not a range or the sheet is protected" & _
>> vbNewLine & "please correct and try again.", vbOKOnly
>> Exit Sub
>> End If
>>
>> With Application
>> .EnableEvents = False
>> .ScreenUpdating = False
>> End With
>>
>> With iMsg
>> Set .Configuration = iConf
>> '.To = "(E-Mail Removed)"
>> .To = "(E-Mail Removed)"
>> .CC = ""
>> .BCC = ""
>>
>> 'Remove special characters from contact name
>> TempContactName = Replace(Range("SubmitBy"), ".", "", 1, -1,
>> vbTextCompare)
>> TempContactName = Replace(TempContactName, ",", " ", 1, -1,
>> vbTextCompare)
>> .From = TempContactName & " <(E-Mail Removed)>"
>>
>> .Subject = "New Implant Request " & Now() & " (by " &
>> Range("SubmitBy") & ")"
>> .HTMLBody = RangetoHTML(rng)
>> .Send
>> End With
>>
>> MsgBox "Form has been submitted successfully"
>>
>> With Application
>> .EnableEvents = True
>> .ScreenUpdating = True
>> End With
>>
>> End Sub
>>
>>
>> Function RangetoHTML(rng As Range)
>> ' Changed by Ron de Bruin 28-Oct-2006
>> ' Working in Office 2000-2007
>> Dim fso As Object
>> Dim ts As Object
>> Dim TempFile As String
>> Dim TempWB As Workbook
>>
>> TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") &
>> ".htm"
>>
>> 'Copy the range and create a new workbook to past the data in
>> rng.Copy
>> Set TempWB = Workbooks.Add(1)
>> With TempWB.Sheets(1)
>> .Cells(1).PasteSpecial Paste:=8
>> .Cells(1).PasteSpecial xlPasteValues, , False, False
>> .Cells(1).PasteSpecial xlPasteFormats, , False, False
>> .Cells(1).Select
>> Application.CutCopyMode = False
>> On Error Resume Next
>> .DrawingObjects.Visible = True
>> .DrawingObjects.Delete
>> On Error GoTo 0
>> End With
>>
>> 'Publish the sheet to a htm file
>> With TempWB.PublishObjects.Add( _
>> SourceType:=xlSourceRange, _
>> Filename:=TempFile, _
>> Sheet:=TempWB.Sheets(1).Name, _
>> Source:=TempWB.Sheets(1).UsedRange.Address, _
>> HtmlType:=xlHtmlStatic)
>> .Publish (True)
>> End With
>>
>> 'Read all data from the htm file into RangetoHTML
>> Set fso = CreateObject("Scripting.FileSystemObject")
>> Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
>> RangetoHTML = ts.ReadAll
>> ts.Close
>> RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
>> "align=left xublishsource=")
>>
>> 'Close TempWB
>> TempWB.Close SaveChanges:=False
>>
>> 'Delete the htm file we used in this function
>> Kill TempFile
>>
>> Set ts = Nothing
>> Set fso = Nothing
>> Set TempWB = Nothing
>> End Function

Did you ever figure out the problem?

> On Tuesday, November 11, 2008 7:19 PM Mald wrote:

> Our company recently migrated to from Exchange Server 2003 to Exchange Server
> 2007.
>
> The following code had been working fine until the upgrade:
>
> Any Ideas as to why it won't work after this upgrade?
>
> Option Explicit
>
> Sub CDO_Send_Selection_Or_Range_Body()
> 'Set rng = Sheets("YourSheet").Range("D412").SpecialCells(xlCellTypeVisible)
> 'Set rng = ActiveSheet.UsedRange
> 'Set rng = Sheets("YourSheet").UsedRange
>
> Dim rng As Range
> Dim iMsg As Object
> Dim iConf As Object
> Dim Flds As Variant
> Dim TempContactName As String
>
> 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/sendusing") = 2
>
> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
> "FTWEV03.hca.corpad.net"
>
> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
> .Update
> End With
>
>
> Set rng = Nothing
> On Error Resume Next
>
> 'Set rng = Selection.SpecialCells(xlCellTypeVisible)
> Set rng = ActiveSheet.UsedRange
>
> On Error GoTo 0
>
> If rng Is Nothing Then
> MsgBox "The selection is not a range or the sheet is protected" & _
> vbNewLine & "please correct and try again.", vbOKOnly
> Exit Sub
> End If
>
> With Application
> .EnableEvents = False
> .ScreenUpdating = False
> End With
>
> With iMsg
> Set .Configuration = iConf
> '.To = "(E-Mail Removed)"
> .To = "(E-Mail Removed)"
> .CC = ""
> .BCC = ""
>
> 'Remove special characters from contact name
> TempContactName = Replace(Range("SubmitBy"), ".", "", 1, -1,
> vbTextCompare)
> TempContactName = Replace(TempContactName, ",", " ", 1, -1,
> vbTextCompare)
> .From = TempContactName & " <(E-Mail Removed)>"
>
> .Subject = "New Implant Request " & Now() & " (by " &
> Range("SubmitBy") & ")"
> .HTMLBody = RangetoHTML(rng)
> .Send
> End With
>
> MsgBox "Form has been submitted successfully"
>
> With Application
> .EnableEvents = True
> .ScreenUpdating = True
> End With
>
> End Sub
>
>
> Function RangetoHTML(rng As Range)
> ' Changed by Ron de Bruin 28-Oct-2006
> ' Working in Office 2000-2007
> Dim fso As Object
> Dim ts As Object
> Dim TempFile As String
> Dim TempWB As Workbook
>
> TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") &
> ".htm"
>
> 'Copy the range and create a new workbook to past the data in
> rng.Copy
> Set TempWB = Workbooks.Add(1)
> With TempWB.Sheets(1)
> .Cells(1).PasteSpecial Paste:=8
> .Cells(1).PasteSpecial xlPasteValues, , False, False
> .Cells(1).PasteSpecial xlPasteFormats, , False, False
> .Cells(1).Select
> Application.CutCopyMode = False
> On Error Resume Next
> .DrawingObjects.Visible = True
> .DrawingObjects.Delete
> On Error GoTo 0
> End With
>
> 'Publish the sheet to a htm file
> With TempWB.PublishObjects.Add( _
> SourceType:=xlSourceRange, _
> Filename:=TempFile, _
> Sheet:=TempWB.Sheets(1).Name, _
> Source:=TempWB.Sheets(1).UsedRange.Address, _
> HtmlType:=xlHtmlStatic)
> .Publish (True)
> End With
>
> 'Read all data from the htm file into RangetoHTML
> Set fso = CreateObject("Scripting.FileSystemObject")
> Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
> RangetoHTML = ts.ReadAll
> ts.Close
> RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
> "align=left xublishsource=")
>
> 'Close TempWB
> TempWB.Close SaveChanges:=False
>
> 'Delete the htm file we used in this function
> Kill TempFile
>
> Set ts = Nothing
> Set fso = Nothing
> Set TempWB = Nothing
> End Function


>> On Wednesday, November 12, 2008 12:44 PM Mald wrote:

>> This is the error I get when I run this code:
>>
>> Run-time error '-2147220973 (80040213)':
>>
>> The transport failed to connect to the server.
>>
>>
>> "Maldo" wrote:


>>> On Wednesday, November 12, 2008 1:22 PM Ron de Bruin wrote:

>>> Ask your IT people
>>>
>>> Maybe they block it or the firewall block it
>>>
>>> --
>>>
>>> Regards Ron de Bruin
>>> http://www.rondebruin.nl/tips.htm


>>> Submitted via EggHeadCafe
>>> Twitter Search API with jQuery and JSONP
>>> http://www.eggheadcafe.com/tutorials...and-jsonp.aspx