Excel file updated and now VB macro won't activate custom function

[ag235]

Hello,
Your help would be really appreciated!

I have an excel file which reports corporate data and includes a macro.
The macro copies and pastes a range into the body of an email.
I've been using this code for over 3 years and this is the second time this happens in two separate files.

I update the report tool and change ranges that effect the macro, delete/add column, clean up the background coding and update the macro to reflect the change in ranges. Now all of a sudden the macro only goes as far as triggers an email message, populates the emails and the subject line but won't copy/paste the content in to the email. No error message, just an empty email. I open an older version and it works just fine.

I've included the code below. I've tested it in another blank file and it works just fine. For some reason, just the specific ones where the code originates don't work. Rebuilding the tool isn't really an option so I'm wondering if anyone would find/help with this error. Thanks in advance!


Sub Send_RWC_Validation()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim CRG_Email As String, Subj As String
Dim RWC_Email As String
Dim Country As String

Sheets("Country Position Overview").Unprotect Password:="CRGCPOTOOL"


CRG_Email = Cells(13, 42)
RWC_Email = Cells(13, 43)

Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Country Position Overview").Range("W1:AN65").SpecialCells(xlCellTypeVisible)
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


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
'Update email information
With OutMail
.To = CRG_Email
.CC = RWC_Email
.BCC = ""
.Subject = "CPO - RWC Validation Completed"
.HTMLBody = RangetoHTML(rng)
.Display
End With
On Error GoTo 0


Sheets("Country Position Overview").Protect Password:="CRGCPOTOOL"


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


Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Andrea Gardella February 3,2011
' Working in Office 2000-2010
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