Vba 从Excel导出到Outlook

我的工作簿有5张不同的工作表，我需要复制这5张工作表并将其粘贴到5封不同的邮件中。最好是HTML

下面编写的代码仅将不同的工作表附加到outlook。我需要下面的电子邮件正文的HTML。请注意，我在工作表中的范围因工作簿而异，但工作表名称保持不变

  Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
'BrowseForFolder was a code originally written by Ron De Bruin, I love this function!

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

Sub SaveWorksheets()
'saves each worksheet as a separate file in a specific folder.
Dim ThisFolder As String
Dim NameOfFile As String
Dim Period As String
Dim RecipName As String

ThisFolder = BrowseForFolder()

Application.ScreenUpdating = False

Dim ws As Worksheet
Dim wsName As String
For Each ws In ActiveWorkbook.Worksheets
wsName = ws.Name

If wsName <> "Data" Then

Period = ws.Cells(4, 1).Value 'put the row and column numbers of the report date here.
RecipName = ws.Cells(1, 29).Value 'put the row and column numbers of the email address here
NameOfFile = ThisFolder & "\" & "Termination Report " & wsName & " " & Period & ".xlsx"

ws.Select
ws.Copy
ActiveWorkbook.SaveAs Filename:= _
NameOfFile, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Call EmailWorkbooks(RecipName, NameOfFile)
End If

Next ws
End Sub

Sub EmailWorkbooks(RecipName, NameOfFile)

Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createItem(0)

Msg = "Attached is the xyz report for your review. Please let me know if you have any questions" & vbCrLf & vbCrLf _
& "Thanks," & vbCrLf & vbCrLf _
& "Your Name Here" & vbCrLf _
& "Your Title" & vbCrLf _
& "Your contact info"

Subj = "XYZ Report" & " " & Period

On Error Resume Next
With OutMail
.To = RecipName
'.CC =
.Subject = Subj
.Body = Msg
.Attachments.Add (NameOfFile)
.Save
End With
On Error GoTo 0

End Sub 

函数BrowseForFolder（可选OpenAt作为变量）作为变量
'功能用途：浏览用户选择的文件夹。
'如果提供了“OpenAt”路径，请在该目录下打开浏览器
'注意：如果无效，它将在桌面级别打开
BrowseForFolder是Ron De Bruin最初编写的代码，我喜欢这个功能！
将ShellApp设置为对象
'在默认文件夹中创建文件浏览器窗口
设置ShellApp=CreateObject（“Shell.Application”）_
BrowseForFolder（0，“请选择文件夹”，0，OpenAt）
'将文件夹设置为选定的文件夹。（取消时出错）
出错时继续下一步
BrowseForFolder=ShellApp.self.Path
错误转到0
'销毁Shell应用程序
设置ShellApp=Nothing
'检查无效或非条目并发送到无效错误
'如果找到处理程序
'有效的选择可以以L开头：（其中L是字母）或
“\\（如\\servername\sharename中所示。所有其他内容无效
选择案例Mid（浏览文件夹，2，1）
Case Is=“：”
如果左（BrowseForFolder，1）=“：”则转到无效
Case Is=“\”
如果未离开（BrowseForFolder，1）=“\”则转到无效
其他情况
转到无效
结束选择
退出功能
无效：
'如果确定选择无效，则设置为False
BrowseForFolder=False
端函数
子保存工作表（）
'将每个工作表另存为特定文件夹中的单独文件。
将此文件夹设置为字符串
将文件的名称设置为字符串
将周期变暗为字符串
将名称设置为字符串
ThisFolder=BrowseForFolder（）
Application.ScreenUpdating=False
将ws设置为工作表
将wsName设置为字符串
对于ActiveWorkbook.Worksheets中的每个ws
wsName=ws.Name
如果wsName为“数据”，则
Period=ws.Cells（4，1）.Value'将报告日期的行号和列号放在这里。
RecipName=ws.Cells（1，29）.Value'将电子邮件地址的行号和列号放在这里
NameOfFile=ThisFolder&“\”和“终止报告”&wsName&“&Period&.”.xlsx
ws.Select
ws.Copy
ActiveWorkbook.SaveAs文件名：=_
文件名，文件格式：=_
xlOpenXMLWorkbook，CreateBackup:=False
活动窗口，关闭
调用EmailWorkbooks（RecipName，NameOfFile）
如果结束
下一个ws
端接头
子电子邮件工作簿（RecipName、NameOfFile）
Dim OutApp作为对象
将邮件变暗为对象
Set-OutApp=CreateObject（“Outlook.Application”）
Set-OutMail=OutApp.createItem（0）
Msg=“附件是供您审阅的xyz报告。如果您有任何问题，请告诉我”&vbCrLf&vbCrLf_
&“谢谢，”&vbCrLf&vbCrLf_
&“您的名字在这里”&vbCrLf_
&“您的标题”和vbCrLf_
&“您的联系信息”
sub=“XYZ报告”和“期间”
出错时继续下一步
发邮件
.To=收件人姓名
"抄送=
主语，主语
.Body=Msg
.Attachments.Add（文件名）
拯救
以
错误转到0
端接头

U可以使用PublishObjects集合的Add方法，简短示例：

Sub InsertSheetContent()
  Dim onePublishObject As PublishObject
  Dim oneSheet As Worksheet
  Dim scriptingObject As Object
  Dim outlookApplication As Object
  Dim outlookMail As Object
  Dim htmlBody As String
  Dim htmlFile As String
  Dim textStream

  Set scriptingObject = CreateObject("Scripting.FileSystemObject")
  Set outlookApplication = CreateObject("Outlook.Application")

  For Each oneSheet In ThisWorkbook.Worksheets
    htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
    Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
                                                            Filename:=htmlFile, _
                                                            Sheet:=oneSheet.Name, _
                                                            Source:=oneSheet.UsedRange.Address, _
                                                            HtmlType:=xlHtmlStatic, _
                                                            DivID:=oneSheet.Name)
    onePublishObject.Publish Create:=True

    Set textStream = scriptingObject.OpenTextFile(htmlFile)
    htmlBody = textStream.ReadAll

    Set outlookMail = outlookApplication.CreateItem(0)
    With outlookMail
        .htmlBody = htmlBody
        .Display
    End With
  Next oneSheet

End Sub

---

如何修改代码？我想将您的和我发布的代码合并为一个。请帮助此处是示例文件发布对象的链接，该对象会生成一些（全部？）质量较差的Html智能手机无法接受。如果这是一个问题，我可能会有一个解决方案。@TonyDallimore我将在桌面环境中操作……所以这并不重要：）我如何将其发送到不同的地址？创建的每封邮件都需要发送给不同的人。我该怎么做？