[英]Reading htm file to .HTMLBody VBA
I'm attempting to automate an email using an Excel worksheet and VBA. 我正在尝试使用Excel工作表和VBA自动处理电子邮件。 I'm able to copy the desired range into the email, but I want to use a htm file for the HTML formatting. 我可以将所需范围复制到电子邮件中,但是我想将htm文件用于HTML格式。
How do I read a htm file and add it to the .HTMLBody of my email? 如何阅读htm文件并将其添加到电子邮件的.HTMLBody中?
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: 这是我的代码,该代码发送带有正确工作表的电子邮件,但不包括通过test(path)函数添加的HTML格式:
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. PS我还需要显示消息而不是发送消息,但这并不是问题的重要。
Your function doesn't return any value. 您的函数不返回任何值。 Try this: 尝试这个:
Function test(sPath As String)
test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function
I solved my problem. 我解决了我的问题。 There was an issue when using html coupled with sending the worksheet range in the above code. 使用html并在上述代码中发送工作表范围时出现问题。 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. 我决定将工作表转换为html,将图表导出为图像,然后将其插入电子邮件的html其余部分。
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! 感谢您所有的帮助! :) :)
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. 我的猜测是sText为null。 If it is reading the .htm successfully, I would next check to make sure that the .htm is valid .html syntax. 如果它成功读取了.htm,我接下来将检查以确保.htm是有效的.html语法。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.