vba 将html转换excel,如何用VBA将邮件内容HTML化

Function GetBoiler(ByVal sFile As String) As String

'作者：Dick Kusleika

Dim fso As Object

Dim ts As Object

Set fso = CreateObject("Scripting.FileSystemObject")

Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)

GetBoiler = ts.readall

ts.Close

End Function

Sub Mail_Outlook_With_Signature_Html()

' 别忘记在模块中加上GetBoiler函数

' 可以在Office 2000-2010版本中通用

Dim OutApp As Object

Dim OutMail As Object

Dim strbody As String

Dim SigString As String

Dim Signature As String

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

strbody = "

尊敬的XXX

" & _

"我是正文.
" & _

"所以你看见了我,说明宏正确地运行了.
" & _

"ExcelHome" & _

"Regards"

'建立新邮件.htm(以html格式保存的附件)，请查看自己系统中签名是什么，再替换“建立新邮件”这五个字。

'签名保存在windows的每个用户appdata目录下的文件，每个人都不同。具体是

'Win7中Outlook的签名位置

'C:\用户\你的大名\AppData\Roaming\Microsoft\Signatures

'WinXP中Outlook的签名位置

'C:\Documents and Settings\你的大名\Application Data\Microsoft\Signatures

'获取方式是使用Environ函数，并指定appdata作为需要搜索的系统文件夹

SigString = Environ("appdata") & _

"\Microsoft\Signatures\建立新邮件.htm"

'但是，如果签名中有图片，必须做以下改动才能使图片不显示大叉，必须将“建立新邮件.html”文件中的图片地址改为绝对地址

'因为Oultlook保存签名时，html文件是使用如2行引用了相对地址作为图片超链接的

'src = "建立新邮件_files/image001.png

'src = "建立新邮件_files/image001.jpg

'你可以使用记事本打开“建立新邮件.html”，关键字为你的图片文件名称，"/"前的内容要替换为""，即绝对地址是

'Win7用户

'src = "C:\用户\你的大名\AppData\Roaming\Microsoft\Signatures\建立新邮件_files\image001.png

'src = "C:\用户\你的大名\AppData\Roaming\Microsoft\Signatures\建立新邮件_files\建立新邮件_files/image001.jpg

'WinXP用户

'src = "C:\Documents and Settings\你的大名\Application Data\Microsoft\Signatures\建立新邮件_files\image001.png

'src = "C:\Documents and Settings\你的大名\Application Data\Microsoft\Signatures\建立新邮件_files\建立新邮件_files/image001.jpg

'就能正常地在签名中显示图片了

'调用GetBoiler函数对Signature变量进行赋值

If Dir(SigString) <> "" Then

Signature = GetBoiler(SigString)

Else

Signature = ""

End If

On Error Resume Next

With OutMail

.To = "Test@office.com;billgates@microsoft.com" '主送

.CC = ""                                        '抄送

.BCC = ""                                       '密送

.Subject = "我是主题"                           '主题

.HTMLBody = strbody & "
" & Signature    'html格式正文

.display                                        '在Outlook界面显示该封待发送邮件

'.Attachments.Add ("C:\test.txt")               '附件

'.save                                          '保存到草稿箱

'.send                                          '直接发送

End With

On Error GoTo 0

Set OutMail = Nothing

Set OutApp = Nothing

End Sub