使用Outlook VBA从Excel文件复制/粘贴。

好吧，在这里我有一些难题。 这是我正在尝试的罗嗦版本：

1. 在我已经在Outlook中创build的模板中，打开它并拖动一些文件 – 其中之一将是一个Excel文件。
2. 打开Excel文件并读取到预定的最后一个单元格
3. 将最后一行/列的单元格复制到第一个单元格A1 。
4. 将以前在步骤3中复制的单元格粘贴到Outlook正文中

4号是目前我的问题所在。 附上的是代码

 Const xlUp = -4162 'Needed to use the .End() method Sub Sample() Dim NewMail As MailItem, oInspector As Inspector Set oInspector = Application.ActiveInspector Dim eAttachment As Object, xlsAttachment As Object, i As Integer, lRow As Integer, lPriorRow As Integer, lCommentRow As Integer '~~> Get the current open item Set NewMail = oInspector.CurrentItem 'Code given to me from a previous question Set eAttachment = CreateObject("Excel.Application") With NewMail.Attachments For i = 1 To .Count If InStr(.Item(i).FileName, ".xls") > 0 Then 'Save the email attachment so we can open it sFileName = "C:/temp/" & .Item(i).FileName .Item(i).SaveAsFile sFileName eAttachment.Workbooks.Open sFileName With eAttachment.Workbooks(.Item(i).FileName).Sheets(1) lCommentRow = .Cells.Find("Comments").Row lPriorRow = .Cells.Find("Prior Inspections").Row lRow = eAttachment.Max(lCommentRow, lPriorRow) ' Weirdly enough, Outlook doesn't seem to have a Max function, so I used the Excel one. .Range("A1:N" & lRow).Select .Range("A1:N" & lRow).Copy 'Here is where I get lost; nothing I try seems to work NewMail.Display End With eAttachment.Workbooks(.Item(i).FileName).Close Exit For End If Next End With End Sub 

我在另一个问题上看到一个函数，将Range对象更改为HTML，但由于此macros代码位于Outlook中，因此无法在此处使用Excel 。

任何帮助，将不胜感激。

Answer 1

也许这个网站会指出你在正确的方向。

---

编辑：

经过一些修补之后，我得到了这个工作：

 Option Explicit Sub Sample() Dim MyOutlook As Object, MyMessage As Object Dim NewMail As MailItem, oInspector As Inspector Dim i As Integer Dim excelApp As Excel.Application, xlsAttachment As Attachment, wb As workBook, rng As Range Dim sFileName As String Dim lCommentRow As Long, lPriorRow As Long, lRow As Long ' Get the current open mail item Set oInspector = Application.ActiveInspector Set NewMail = oInspector.CurrentItem ' Get instance of Excel.Application Set excelApp = New Excel.Application ' Find the attachment For i = 1 To NewMail.Attachments.Count If InStr(NewMail.Attachments.Item(i).FileName, ".xls") > 0 Then MsgBox "Located attachment: """ & NewMail.Attachments.Item(i).FileName & """" Set xlsAttachment = NewMail.Attachments.Item(i) Exit For End If Next ' Continue only if attachment was found If Not IsNull(xlsAttachment) Then ' Set temp file location and use time stamp to allow multiple times with same file sFileName = "C:/temp/" & Int(CDbl(Now()) * 10000) & xlsAttachment.FileName xlsAttachment.SaveAsFile (sFileName) ' Open file so we can copy info Set wb = excelApp.Workbooks.Open(sFileName) ' Search worksheet for important info With wb.Sheets(1) lCommentRow = .Cells.Find("Comments").Row lPriorRow = .Cells.Find("Prior Inspections").Row lRow = excelApp.Max(lCommentRow, lPriorRow) set rng = .Range("A1:H" & lRow) End With ' Set up the email message With NewMail .To = "[e-mail]" .CC = "[e-mail]" .Subject = "TEST - PLEASE IGNORE" .BodyFormat = olFormatHTML .HTMLBody = RangetoHTML(rng) .Display End With End If wb.Close End Sub Function RangetoHTML(rng As Range) ' By Ron de Bruin. Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As workBook Dim excelApp As Excel.Application Set excelApp = New Excel.Application 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 ' Paste over column widths from the file .Cells(1).PasteSpecial xlPasteValues .Cells(1).PasteSpecial xlPasteFormats .Cells(1).Select excelApp.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 

您必须转至工具 – >参考并包含Microsoft Excel对象库。 这个问题在那里指向我。 我喜欢避免后期绑定，以便vba intellisense出现，我知道这些方法是有效的。

RangetoHTML来自Ron Debruin （我不得不编辑PasteSpecial方法来让它们工作）

我也从这个论坛上得到了一些关于如何在电子邮件正文中插入文字的帮助。

我将date添加到临时文件名称，因为我试图多次保存它。

我希望这有帮助。 我肯定学到了很多！

更多备注：

在我看来，细胞被截断。 正如mvsub1在这里解释的那样 ，使用函数RangeToHTML的问题在于它将超出列宽的文本视为隐藏文本，并将其粘贴到电子邮件中：

 [td class=xl1522522 width=64 style="width:48pt"]This cell i[span style="display:none">s too long.[/span][/td] 

如果您遇到类似的问题，则会在页面上讨论一些解决scheme。