将Excel表导出为HTML
我正在运行一个代码,它从Excel工作表中获取数据,将其转换为HTML并作为电子邮件发送出去。下面是该方法使用:将Excel表导出为HTML
'replace html body'
htmlString = Replace(htmlString, "#FIELD1#", ws.Range("D5").value)
htmlString = Replace(htmlString, "#FIELD2#", ws.Range("C6").value)
现在我有,我想复制粘贴到HTML格式同一个完整的表(边框,字体等)
能有人帮如何做到这一点?
答案在某种程度上取决于您的邮件客户端。 Outlook与VBA紧密集成。如果您使用的是通用邮件客户端,则仍应能完成此任务,但可能会遇到问题。
如果您想从Excel中复制并粘贴为HTML中的Outlook,则已经解答:Copying values from excel to body of outlook email vb.net。
如果您想使用通用电子邮件发送请参阅下面的答案。我相信这对HTML来说可以很好地工作。 (如果您的邮件客户端对传递的HTML不满意,您可以将其转换为另存为文本文件,对于文本文件,您可以从开发人员功能区录制自己的宏,只需开始录制并使用另存为即可保存为文本文件)。
下面有3个子/功能。我测试了HTMLExport,这是我的代码。 SendEMail正好来自Chip Pearson的网站,并且应该可以正常工作。我没有测试ExcelToHTMLToEMail,这只是调用前2
Sub ExcelToHTMLToEMail(BodyRngName as string,
Subject As String, _
FromAddress As String, _
ToAddress As String, _
SMTP_Server As String, _
Optional Attachments As Variant = Empty)
Dim BodyFileName As String
BodyFileName = "C:\temp.htm"
HTMLExport RngName, BodyFileName
SendEMail Subject, _
FromAddress, _
ToAddress, _
"", _
SMTP_Server, _
BodyFileName, _
Optional Attachments
End Sub
Sub HTMLExport(RngName as string, _
HtmlFileName as String, _
Optional PageTitle as string = "")
'
' HTMLExport Macro
'
Range(RngName).Select
With ActiveWorkbook.PublishObjects.Add(xlSourceRange, HtmlFileName , _
"Sheet1 (7)", RngName, xlHtmlStatic, , "MyPageTitle")
.Publish (True)
.AutoRepublish = False
End With
End Sub
你可以找到来自芯片皮尔逊从Excel发送电子邮件代码:http://www.cpearson.com/Excel/EMail.aspx。该网站包含一个巨大的Excel VBA代码存储库。 简介
从您的应用程序添加发送电子邮件的功能并不困难。如果您只想发送工作簿,只有主题但没有内容,则可以使用ThisWorkbook.SendMail。但是,如果要在邮件正文中包含文本或将附加文件包含为附件,则需要一些VBA代码。该页面描述了一个名为SendEmail的函数,该函数将详细信息包装在一个漂亮的,适用于VBA的函数中。你可以在这里下载代码文件。
函数的定义是:
Function SendEMail(Subject As String, _
FromAddress As String, _
ToAddress As String, _
MailBody As String, _
SMTP_Server As String, _
BodyFileName As String, _
Optional Attachments As Variant) As Boolean
哪里 主题是电子邮件的主题行。
FromAddress是您的电子邮件地址。
ToAddress是电子邮件将发送到的地址。您可以通过用分号分隔电子邮件地址来向多个收件人发送邮件。
MailBody是要成为消息正文的文本。如果将其留空并且BodyFileName将其命名为文本文件,则该消息的主体将是由BodyFileName命名的文件中的所有文本。如果BodyFileName和MailBody都为空,则消息将不带主体发送。
SMTP_Server是您的发送邮件服务器的名称。
BodyFileName是将用作消息正文的文本文件的名称。如果MailBody不为空,则忽略此参数,并且不会将该文件用作主体。如果MailBody和BodyFileName都不为空,则将使用MailBody的内容作为主体并忽略BodyFileName。
附件是一个文件名或附加到邮件的文件名数组。如果附加其中一个文件时出现错误,则继续处理其余文件并发送电子邮件。
该函数如果成功则返回True,如果发生错误则返回False。
代码需要参考Microsoft CDO for Windows 2000 Library。该文件的典型文件位置是C:\ Windows \ system32 \ cdosys.dll。此组件的GUID是{CD000000-8B95-11D1-82DB-00C04FB1625D},与主要= 1和次要= 0
SectionBreak
守则
的代码如下所示。你可以在这里下载代码文件。
Function SendEMail(Subject As String, _
FromAddress As String, _
ToAddress As String, _
MailBody As String, _
SMTP_Server As String, _
BodyFileName As String, _
Optional Attachments As Variant = Empty) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SendEmail Function
' By Chip Pearson, [email protected] www.cpearson.com 28-June-2012
'
' This function sends an email to the specified user.
' Parameters:
' Subject: The subject of the email.
' FromAddress: The sender's email address
' ToAddress: The recipient's email address or addresses.
' MailBody: The body of the email.
' SMTP_Server: The SMTP-Server name for outgoing mail.
' BodyFileName: A text file containing the body of the email.
' Attachments A single file name or an array of file names to
' attach to the message. The files must exist.
' Return Value:
' True if successful.
' False if failure.
'
' Subject may not be an empty string.
' FromAddress must be a valid email address.
' ToAddress must be a valid email address. To send to multiple recipients,
' use a semi-colon to separate the individual addresses. If there is a
' failure in one address, processing terminates and messages are not
' send to the rest of the recipients.
' If MailBody is vbNullString and BodyFileName is an existing text file, the content
' of the file named by BodyFileName is put into the body of the email. If
' BodyFileName does not exist, the function returns False. The content of
' the message body is created by a line-by-line import from BodyFileName.
' If MailBody is not vbNullString, then BodyFileName is ignored and the body
' is not created from the file.
' SMTP_Server must be a valid accessable SMTP server name.
' If both MailBody and BodyFileName are vbNullString, the mail message is
' sent with no body content.
' Attachments can be either a single file name as a String or an array of
' file names. If an attachment file does not exist, it is skipped but
' does not cause the procedure to terminate.
'
' If you want to send ThisWorkbook as an attachment to the message, use code
' like the following:
' ThisWorkbook.Save
' ThisWorkbook.ChangeFileAccess xlReadOnly
' B = SendEmail(_
' ... parameters ...
' Attachments:=ThisWorkbook.FullName)
' ThisWorkbook.ChangeFileAccess xlReadWrite
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Required References:
' --------------------
' Microsoft CDO for Windows 2000 Library
' Typical File Location: C:\Windows\system32\cdosys.dll
' GUID: {CD000000-8B95-11D1-82DB-00C04FB1625D}
' Major: 1 Minor: 0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim MailMessage As CDO.Message
Dim N As Long
Dim FNum As Integer
Dim S As String
Dim Body As String
Dim Recips() As String
Dim Recip As String
Dim NRecip As Long
' ensure required parameters are present and valid.
If Len(Trim(Subject)) = 0 Then
SendEMail = False
Exit Function
End If
If Len(Trim(FromAddress)) = 0 Then
SendEMail = False
Exit Function
End If
If Len(Trim(SMTP_Server)) = 0 Then
SendEMail = False
Exit Function
End If
' Clean up the addresses
Recip = Replace(ToAddress, Space(1), vbNullString)
If Right(Recip, 1) = ";" Then
Recip = Left(Recip, Len(Recip) - 1)
End If
Recips = Split(Recip, ";")
For NRecip = LBound(Recips) To UBound(Recips)
On Error Resume Next
' Create a CDO Message object.
Set MailMessage = CreateObject("CDO.Message")
If Err.Number <> 0 Then
SendEMail = False
Exit Function
End If
Err.Clear
On Error GoTo 0
With MailMessage
.Subject = Subject
.From = FromAddress
.To = Recips(NRecip)
If MailBody <> vbNullString Then
.TextBody = MailBody
Else
If BodyFileName <> vbNullString Then
If Dir(BodyFileName, vbNormal) <> vbNullString Then
' import the text of the body from file BodyFileName
FNum = FreeFile
S = vbNullString
Body = vbNullString
Open BodyFileName For Input Access Read As #FNum
Do Until EOF(FNum)
Line Input #FNum, S
Body = Body & vbNewLine & S
Loop
Close #FNum
.TextBody = Body
Else
' BodyFileName not found.
SendEMail = False
Exit Function
End If
End If ' MailBody and BodyFileName are both vbNullString.
End If
If IsArray(Attachments) = True Then
' attach all the files in the array.
For N = LBound(Attachments) To UBound(Attachments)
' ensure the attachment file exists and attach it.
If Attachments(N) <> vbNullString Then
If Dir(Attachments(N), vbNormal) <> vbNullString Then
.AddAttachment Attachments(N)
End If
End If
Next N
Else
' ensure the file exists and if so, attach it to the message.
If Attachments <> vbNullString Then
If Dir(CStr(Attachments), vbNormal) <> vbNullString Then
.AddAttachment Attachments
End If
End If
End If
With .Configuration.Fields
' set up the SMTP configuration
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_Server
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
On Error Resume Next
Err.Clear
' Send the message
.Send
If Err.Number = 0 Then
SendEMail = True
Else
SendEMail = False
Exit Function
End If
End With
Next NRecip
SendEMail = True
End Function
If you want to attach the workbook that contains the code, you need to make the file read-only when you send it and then change access back to read-write. For example,
ThisWorkbook.Save
ThisWorkbook.ChangeFileAccess xlReadOnly
B = SendEmail(_
... parameters ...
Attachments:=ThisWorkbook.FullName)
ThisWorkbook.ChangeFileAccess xlReadWrite
谢谢你的帮助! –
罗恩去熊先生的博客[邮件范围/选择在邮件的正文(http://www.rondebruin.nl/win/s1/outlook/bmail2.htm)的所有代码和例子你需要。 – 2016-10-01 04:56:21