HTML/VBA Auto-Email at a Specific Time - html

I am trying to get my VBA/HTML to automatically send emails at a specific time, however as the time I have it set to test at comes and goes, nothing happens. When I go to activate it manually, the debugger highlights the time value and says "invalid outside procedure". I am new to VBA and was wondering if anyone could help?
Application.OnTime TimeValue("14:31:00"), Procedure = "RangetoHTML"
Function RangetoHTML(rng As Range)
' Working in Office 2000-2016
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
Sub AutoEmail()
' You need to use this module with the RangetoHTML subroutine.
' Working in Office 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Sheets("emailtest").Range("A10:E39").SpecialCells(xlCellTypeVisible) ' Change this
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
With OutMail
.To = Range("C6").Value ' Change this to the email addresses you want to send to
.CC = ""
.BCC = ""
.Subject = Date & " " & "Daily MCAPS Part Update" ' Add in a subject
.HTMLBody = Range("C5").Value
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Your function Function RangetoHTML(rng As Range) needs a parameter. So, it must be passed when it is called. But I do not have the knowledge to be possible to directly send an object like parameter and you must make a kind of trick. The function parameter must be declared As String and the range address will be sent and the range will be built inside the function. Something like this:
Function RangetoHTML(rngAdd As String)
Dim rng As Range
Set rng = Range(rngAdd)
'then use it like you need
End Function
And the function will be called in this way:
Application.OnTime TimeValue("14:31:00"), "'RangetoHTML """ & rng.address & "'"

Related

Keep Excel format when exporting data into Outlook template using VBA [duplicate]

The function of this code is to copy particular range of cells, each cell (having codes like 1ML-234-1R) and place it in the body of outlook mail (taken from Ron de Bruin Excel Automation code).
I want instead that the cells data goes into the subject of mail separated by comma (,) and does not leave any spaces before or after any cell data.
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Sheet1").Range("D1:D12").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
With OutMail
.To = "faizanfarooque#hotmail.com"
.CC = ""
.BCC = ""
.Subject = "Load Shed "
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I am new to VBA and have tried Subject = RangetoHTML(rng) but it showed me this in the subject html xmlns:o="urn:schemas-microsoft-com:office:office"
OK then:
'.....
.Subject = RangeToCSV(rng)
'.....
Function:
Function RangeToCSV(rng)
Dim s, sep, c As Range
For Each c In rng.Cells
If c.Value <> "" Then
s = s & sep & c.Value
sep = ","
End If
Next c
RangeToCSV = s
End Function

Range To HTML removing part of the string [duplicate]

This question already has answers here:
How to keep formats when I copy a range from Excel to outlook
(2 answers)
Closed 3 years ago.
All,
I have been using the below code to generate an email which compiles a range into an HTML body of an email.
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lastrow As Long
Dim sht As Worksheet
Dim StrBody As String
Set rng = Nothing
Sheets("HTML Loop").Activate 'Change
Set sht = ActiveSheet
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Range
On Error Resume Next
Set rng = sht.Range("A1:A" & lastrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If sht.Range("A1").Value = "" Then
Exit Sub
End If
StrBody = "All," & "<br>" & "<br>" & _
"The Robot has completed its daily check of the FX3 Site and has created " & lastrow & " new folder location(s)." & "<br>" & "<br>" & _
"*Please review the files located here:"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Sean.B#xxx.co.uk"
.CC = ""
.BCC = ""
.Subject = "Daily FX3 Notification Email " & Now()
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & "<br>" & "<br>" & "Thanks" & "<br>" & "<br>" & "Gary"
.Display
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutA
End sub
Function RangetoHTML(rng As Range)
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
The issue I am having is when the email is generated, the strings within the range is cut at 9 Characters long.
The range consists of file paths like the below:
\csdatg09\financial systems\Automation\Pega Projects\Tax\FIN_TAX_GARY\Bristol\TEST TEST 108 EastCott Hill
\csdatg09\financial systems\Automation\Pega Projects\Tax\FIN_TAX_GARY\Exeter\TEST TEST 108 EastCott Hill
I would like to understand why the output is like the screenshot attached.
All, this is a duplicate question the answer I was looking for can be found here:
How to keep formats when I copy a range from Excel to outlook
Specific Code:
TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
'.Cells(1).PasteSpecial xlPasteValues, , False, False
'.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

MS Access 2016 can't find my function / module

I'm still new to VBA, but I'm having an issue trying to automate some function. Namely, I can't seem to be able to run it in immediate (Ctrl+G), and when I try to call it in a Macro, I get the can't find the named function error.
It works when I run the code with no variables, like emailPaste(), and this code is taken from here: http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
I tried leaving it as emailPaste() and then calling the function in immediate/macro RunCode but still the same issue.
I have named the Module: EmailWithPaste
Current code:
Option Compare Database
Sub emailPaste(exFile As String, exSheet As String, EmailSubject As String, _
To_Field As String, Optional CC_Field As String)
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim ApXL As Object
Set ApXL = CreateObject("Excel.Application")
ApXL.Workbooks.Open (exFile)
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets(exSheet).Range("A1:D12").SpecialCells(xlCellTypeVisible)
'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 ApXL.Application
.EnableEvents = False
.ScreenUpdating = False
End With
Call OpenOutlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = To_Field
.CC = CC_Field
.Subject = EmailSubject
.HTMLBody = RangetoHTML(rng)
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
On Error GoTo 0
With ApXL.Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
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
TempWB.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
Subs are either called without parentheses, or with the deprecated Call keyword. Only functions are called with parentheses, hence the Expected function or variable.
Also, RunCode runs functions, not subs.
An easy workaround is to change the code to be a function, even though it returns nothing:
Public Function emailPaste(exFile As String, exSheet As String, EmailSubject As String, _
To_Field As String, Optional CC_Field As String)
'The code
End Function
And, because it returns nothing, it still should be called as a sub in the immediate window:
emailPaste "C:\Users\KF\Desktop\TestExcelExport.xlsx","Sheet2","Test","test","cc"

Reading htm file to .HTMLBody VBA

I'm attempting to automate an email using an Excel worksheet and VBA. I'm able to copy the desired range into the email, but I want to use a htm file for the HTML formatting.
How do I read a htm file and add it to the .HTMLBody of my email?
Here's my code, which sends an email with the correct worksheet, but does not include the HTML formatting that is added with the test(path) function:
Sub Send_To_Outlook()
Dim AWorksheet As Worksheet
Dim Sendrng As range
Dim rng As range
Dim text As String
Dim textline As String
Dim sPath As String
sPath = "H:\My Documents\email.htm"
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the Worksheet/range you want to mail
Set Sendrng = Worksheets("Email").range("C6:L244")
'Remember the activesheet
Set AWorksheet = ActiveSheet
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.To = "myemail#email.com"
.CC = ""
.BCC = ""
.Subject = "My subject"
.HTMLBody = test(sPath)
.Send
End With
End With
'select the original ActiveCell
rng.Select
End With
'Activate the sheet that was active before you run the macro
AWorksheet.Select
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
End Sub
Function test(sPath As String)
Dim oFSO As Object
Dim oFS As Object, sText As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.OpenTextFile(sPath)
test= oFS.ReadAll()
End Function
Any suggestions or advice on why this isn't working would be awesome!
PS I also need to display the message instead of send, but this isn't as important of an issue.
Your function doesn't return any value.
Try this:
Function test(sPath As String)
test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function
When you say that your code doesn't work, does that mean that you get an error or that the code executes but the email body is empty?
I would first check to see if your "test" Function is returning a null string:
Function test(sPath As String)
Dim oFSO As Object
Dim oFS As Object, sText As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.OpenTextFile(sPath)
' I don't think you need to loop until EOF with .ReadAll
sText = oFS.ReadAll
' This will print sText to the Immediate Window; if it is 0, then sText is null
Debug.Print ("sText string has a length of: " & Len(sText))
End Function
My guess is that sText is null. If it is reading the .htm successfully, I would next check to make sure that the .htm is valid .html syntax.
I solved my problem. There was an issue when using html coupled with sending the worksheet range in the above code. I decided to covert the worksheet into html, export the chart into an image and insert it into the rest of the html for the email.
Sub Mail_Sheet_Outlook_Body()
Dim rng1 As range
Dim rng2 As range
Dim OutApp As Object
Dim OutMail As Object
Dim newimage As Action
Dim aPath As String
Dim bPath As String
Dim sPath As String
'Name the variables for your the needed paths
sPath = "C:\Chart1.png"
aPath = "C:\email1.htm"
bPath = "C:\email2.htm"
'Export your chart as an image
Call ExportChart("Chart1")
'Select the range your desired tables are in
Set rng1 = Worksheets("Email").range("C6:L32")
Set rng2 = Worksheets("Email").range("C45:L244")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Create the email
On Error Resume Next
With OutMail
.To = "myemail#email.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
' Place your tables in the correct location of your html for the email
.HTMLBody = test(aPath) & RangetoHTML(rng1) & "<img src=" & "'" & sPath & "'" & "width=888; height=198>" & RangetoHTML(rng2) & test(bPath)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function ExportChart(sChartName As String)
' Export a selected chart as a picture
Const sSlash$ = "/"
Const sPicType$ = ".png"
Dim sPath$
Dim sBook$
Dim objChart As ChartObject
On Error Resume Next
' Test if there are even any embedded charts on the activesheet
' If not, let the user know
Set objChart = ActiveSheet.ChartObjects(1)
If objChart Is Nothing Then
MsgBox "No charts have been detected on this sheet", 0
Exit Function
End If
' Test if there is a single chart selected
If ActiveChart Is Nothing Then
MsgBox "You must select a single chart for exporting ", 0
Exit Function
End If
Start:
' chart is exported as a picture, Chart1.png in the same
' folder location as the workbook
sBook = ActiveWorkbook.path
sPath = sBook & sSlash & sChartName & sPicType
ActiveChart.Export Filename:=sPath, FilterName:="PNG"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
End Function
Function RangetoHTML(rng As range)
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
Function test(sPath As String)
'Returns a string after reading the contents of a given file
test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function
Thanks for all of your help! :)

Left Align embedded range in Email

I'm having trouble getting a range that is embedded in an email to left align. I've tried several things but the embedded portion still centers in the email. Here is my code, which ironically, works just fine in other spreadsheets. I've tried adding HTML tags, changing the function(s), all to no avail. Any help would be appreciated. This is on W7x64 and Office 2010. In this report I am embedding a pivot table instead of a regular range.
Thanks.
Option Explicit
SalesSub Mail_RegionalRANGE()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
'On Error Resume Next
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.SentOnBehalfOfName = "SalesAnalytics#company.us"
.Display
.Subject = "Sales Report"
.To = "mike.marshall#company.us"
'.CC =
'.BCC =
'.Attachments.Add "\\filesrv1\department shares\Sales Report\Sales Report.xlsx"
.HTMLBody = "<br>" _
& "Attached is the Sales Report. Please reach out to me with any questions." _
& "<br><br>" _
& "<p align=left>" & fncRangeToHtml("RegAEPctg", "B2:P67") & "<p>" _
& .HTMLBody
.Display
'.Send
End With
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
Private Function fncRangeToHtml( _
strWorksheetName As String, _
strRangeAddress As String) As String
Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
Dim strFilename As String, strTempText As String
Dim blnRangeContainsShapes As Boolean
Set objTextstream = Nothing
Set objFilesytem = Nothing
'Kill strFilename
strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=strWorksheetName, _
Source:=strRangeAddress, _
HtmlType:=xlHtmlStatic).Publish True
Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
objTextstream.Close
strTempText = Replace(strTempText, "align=center x:publishsource=", "align=left x:publishsource=")
For Each objShape In Worksheets(strWorksheetName).Shapes
If Not Intersect(objShape.TopLeftCell, Worksheets( _
strWorksheetName).Range(strRangeAddress)) Is Nothing Then
blnRangeContainsShapes = True
Exit For
End If
Next
If blnRangeContainsShapes Then _
strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
fncRangeToHtml = strTempText
Set objTextstream = Nothing
Set objFilesytem = Nothing
Kill strFilename
End Function
Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
Const HTM_START = "<link rel=File-List href="
Const HTM_END = "/filelist.xml"
Dim strTemp As String
Dim lngPathLeft As Long
lngPathLeft = InStr(1, strTempText, HTM_START)
strTemp = Mid$(strTempText, lngPathLeft, InStr(lngPathLeft, strTempText, ">") - lngPathLeft)
strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
strTemp = strTemp & "/"
strTempText = Replace(strTempText, strTemp, Environ$("temp") & "\" & strTemp)
fncConvertPictureToMail = strTempText
End Function
I'm not a 100% sure but this seems to be cause by your rng to html function.
I had a similar problem with an older range to html I was using, so my solution is a kind of workaround, by rewriting the function you are using.
Can't comment for lack of rep, so please take it with a grain of salt.
I'd suggest using this range_to_html function and expanding it with a workbook open/activate call for your workbook/sheet:
Function RangetoHTML(rng As Range) ' converts a range into html for email-sendout'
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 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 workbook to receive the data.
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 an .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 the RangetoHTML subroutine.
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.
Kill TempFile
Set ts = Nothing
Set FSO = Nothing
Set TempWB = Nothing
End Function
I've used this for everything range related and no matter what it picked out it was always in line with the general email format.
Source: http://www.mrexcel.com/forum/excel-questions/485720-ron-de-bruin-rangetohtml.html
Since you are reading directly from the file the html might contain the allign command for the code. This one here does copying, and republishing which should circumvent the issue.
I'm also not sure how this code handles shapes, so it might not work for ranges with shapes.
Also if I misunderstood and the problem is that the text in the cells is left aligned lemme know, that would be easier to identify and fix.