Question

我有几条信息可供使用。

带有自动消息和3个“插入点”的Outlook电子邮件模板，我需要一个整齐的格式化表格，其中包含注入的超链接并发送到保存的分发列表。
包含3张图纸的Master Excel电子表格，会自动更新所有需要在表格中显示的信息（但不包含超链接）。
3个已过滤的Sharepoint列表，其中包含表格中所需的所有信息，并且包含所需的超链接。

我需要以一种方式轻松（比打开文件和复制和粘贴更容易）自动生成带有上述所有信息的格式化电子邮件的方法。我是一名实习生，所以这是对我的能力的考验，而不是个人节省时间，所以偏离要求并不是一个真正的选择。截至目前，我的老板正在打开电子邮件模板，然后逐个打开Sharepoint列表，单击并拖动选择，并单独复制和粘贴每个列表。所以，让我先从我尝试过的方法开始，然后继续前进到我所在的地方。

所以我第一次尝试在源Excel文件中工作并生成一封电子邮件，因为我之前已经完成了一些简单的自动化。

Sub GenerateEmail()
Const template As String = "--The path to the email template goes here--It works but I removed it for this post"
MakeEmail (template)
End Sub

Sub MakeEmail(templatePath As String)

'Not currently working but I'm not as concerned for it at the moment
'I havent been able to make it as far as this yet
'Dim today As String
'today = Format(Now(), "MM/DD/YYYY")
'Dim later As String
'later = Format(DateAdd("D", 28, Now()), "MM/DD/YYYY")

'---Initialize Constants for future use---
Dim OutlookApp As Variant
Dim Email As Variant

Dim requSheet As Worksheet
Dim xferSheet As Worksheet
Dim AttrSheet As Worksheet
'-----------------------------------------

'---Set Constants for future use---
Set OutlookApp = CreateObject("Outlook.Application")
Set Email = OutlookApp.CreateItemFromTemplate(templatePath)

Set requSheet = Worksheets("owssvr ReqList")
Set requSheet = Worksheets("owssvr Transfer")
Set requSheet = Worksheets("owssvr Attrit")
'----------------------------------

'create an editable copy of email body
Dim editedBody As String
editedBody = Email.HTMLBody

'copies requisitions
requSheet.Activate
Dim currentRequisitions As Range
Columns("C").EntireColumn.Hidden = True
Columns("G:H").EntireColumn.Hidden = True
Dim lner As Long
lner = LastNonEmptyRow(Range("A:A"))
Set currentRequisitions = Range(Cells(2, 1), Cells(lner, 13))
currentRequisitions.Copy

'Converts clipboard contents to String
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
DataObj.GetFromClipboard
Dim copy1str As String
copy1str = DataObj.GetText(1)

'Make edites to editable copy
editedBody = Replace(editedBody, "54321RequisitionsFlag_DoNotRemove", copy1str) 'Requisitions
editedBody = Replace(editedBody, "54321TransfersFlag_DoNotRemove", "Place Holder2") 'Transfers
editedBody = Replace(editedBody, "54321AttritionsFlag_DoNotRemove", "Place Holder3") 'Attritions

'Replace email body with newly edited body
Email.HTMLBody = editedBody

Email.Display
End Sub

Function LastNonEmptyRow(r As Range) As Long
LastNonEmptyRow = r.Cells.Count - WorksheetFunction.CountBlank(r)
End Function

我正在使用这种方法遇到的问题很明显，当我将DataObject转换为字符串时，我正在丢失表格的所有格式。（它被放置为由空格分隔的excel值的长字符串）有像http://tableizer.journalistopia.com/这样的在线资源我将用于将文本转换为HTML表格（如果它是我）但是再次..我是实习生，任务是自动化它，这就是我必须做的。所以我需要以某种方式让它维护表格式。

我已经查看过其他人的代码，将文本转换为HTML并且它存在，但它有几千行代码，我不认为我的老板要我转入其他人的代码用于这种评估类型的项目。（我使用只接受字符串的Replace方法的原因是因为我找不到在MailItem.Body的MIDDLE部分中插入文本的其他方法）我将3个“标志”放入我希望插入的电子邮件模板中成为。（占位符被放置在正确的位置，所以我有这样的选择..）

我还看到使用此方法使某些列表项成为超链接时出现问题。这个列表是动态的，所以我不能对链接进行硬编码，但是当我想到它时，我会越过那座桥。（该URL包含在另一列的Excel工作表中）

我的第二种方法是在启动时编写Outlook VBA中的代码并从中获取更好的源代码（Excel或Sharepoint）

Public Sub Application_Startup()

'This isn't working but I'm not concerned with it at the moment
'Dim today As String
'today = Format(Now(), "MM/DD/YYYY")
'Dim later As String
'later = "11/11/2015"

'---initialize Excel Objects---
Const sourcePath As String = "This is a path to the excel sheet--it works but I removed it for this post"
Dim xlWB As Excel.Workbook
Dim xlRequisition As Excel.Worksheet
Dim xlTransfers As Excel.Worksheet
Dim xlAttritions As Excel.Worksheet
'Set Excel Objects
Excel.Workbooks.Open (sourcePath)
Set xlWB = Excel.ActiveWorkbook
Set xlRequisitions = xlWB.Worksheets("owssvr ReqList")
Set xlTransfers = xlWB.Worksheets("owssvr Transfer")
Set xlAttritions = xlWB.Worksheets("owssvr Attrit")
'----------------------------------
xlRequisitions.Activate
Dim lner As Long
lner = LastNonEmptyRow(Range("A:A"))
'Range("A2:N" & Trim(Str(lner))).AutoFilter Field:=3, Criteria1:=">=" & Format(today, "MM/DD/YYYY"), Operator:=xlAnd, Criteria2:="<" & Format(later, "MM/DD/YYYY")
Range("A2:N" & Trim(Str(lner))).Copy
End Sub

Function LastNonEmptyRow(r As Range) As Long
LastNonEmptyRow = r.Cells.Count - WorksheetFunction.CountBlank(r)
End Function

这个方法让我少了一点..表格仍然在剪贴板中格式化，我可以简单地使用SendKeys方法强制按键击中^ v ..但是这不允许我把它放在3“插入点”。（每个点之前，之后和之间都有文本）。据我所知，你无法在VBA中“移动光标”。在绝望中，我的思绪开始于一个空白的电子邮件，并逐个打印电子邮件模板的所有格式化内容。我希望不会那样。

我尚未尝试的其他方法，但我并非极为希望...

使用MS Word文档作为中间位置来保存表格/电子邮件正文。这可能会让我把所有东西放在一个地方，Word MIGHT有一些方法可以移动光标以将表格放在你真正想要的地方。我不知道。

另一种看起来更有希望的方法，但我不知道该怎么做才能找到一种方法来使用Sharepoint上的URL和listID号码来直接移动这些数据...更接近模仿我老板的做法手动。

Answer 1

听起来你有2个问题，这两个问题已经在SO上得到解答，但我会尝试回答这里，因为你是新成员。在将来，我建议您在SO和一般调试时提出单独的问题。

如何修改Outlook模板。

Send an email from Excel 2007 VBA using an Outlook Template & Set Variables

这里的关键是电子邮件是纯文本或HTML（或没有人使用的富文本）。要插入格式化的表，您必须：

一个。将表转换为HTML（见下文）

B中。将模板转换为HTML（只需打开它，更改格式文本选项卡下的格式并保存）

℃。使用上面链接中描述的.HTMLBody = Replace（）插入文本

将Excel范围转换为HTML

您实际上不需要第三方应用程序来执行此操作 - 它内置于Excel中。请参阅：Paste specific excel range in outlook

使用VBA中的表生成完全格式化的电子邮件

1 个答案: