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

ag235

New Member
Joined
Apr 3, 2012
Messages
10
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 x:publishsource=", _
"align=left x:publishsource=")

'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
 

Forum statistics

Threads
1,081,425
Messages
5,358,604
Members
400,505
Latest member
JacquiT

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top