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

Copying/pasting from an Excel file using Outlook VBA.

提问by Jhecht

Ok, so here I have a bit of conundrum. Here's the wordy version of what I am attempting:

好的，所以在这里我有一个难题。这是我正在尝试的冗长版本：

1. In a template I've already made in Outlook, open it up and drag some files in - one of which will be an Excel file.
2. Open the Excel file and read to a predetermined last cell
3. Copy the cells from the last row/column to the first cell, A1.
4. Paste the cells previously copied in step 3 into the Outlook body

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

Number 4 is currently where my issues lie. Attached is the code

数字 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

I saw on another question a function that changes Range objects to HTML, but it doesn't work here since this Macro code is in Outlook, not Excel.

我在另一个问题上看到了一个将 Range 对象更改为 HTML 的函数，但它在这里不起作用，因为此宏代码在 Outlook 中，而不是 Excel 中。

Any help would be appreciated.

任何帮助，将不胜感激。

采纳答案by ptpaterson

Maybe this sitewill point you in the right direction.

也许这个网站会为你指明正确的方向。

---

---

EDIT:

编辑：

After some tinkering I got this to work:

经过一番修修补补，我得到了这个工作：

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 = "[email protected]"
            .CC = "[email protected]"
            .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

You must go to Tools->References and include the Microsoft Excel Object Library. This questionpointed me there. I liked avoiding late binding so that the vba intellisense shows up and I know that the methods are valid.

您必须转到“工具”->“参考”并包含 Microsoft Excel 对象库。 这个问题把我指向了那里。我喜欢避免后期绑定，以便 vba 智能感知出现，并且我知道这些方法是有效的。

RangetoHTML comes from Ron Debruin(I had to edit the PasteSpecial methods to get them to work)

RangetoHTML 来自Ron Debruin（我必须编辑 PasteSpecial 方法才能让它们工作）

I also got some help from this forumon how to insert text into email body.

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

I added the date to the tempfile name because I was trying to save it multiple times.

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

I hope this helps. I sure learned a lot!

我希望这有帮助。我确实学到了很多！

More Notes:

更多注意事项：

It appeared to me that the cells were being truncated. As mvsub1 explains here, The issue with using the function RangeToHTML is that it treats the text that exceeds the column width as hidden text and pastes it as such into the email:

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

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

There are some solutions discussed on the page if you have a similar issue.

如果您遇到类似问题，页面上会讨论一些解决方案。