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

Question

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

1. 在我已经在 Outlook 中制作的模板中，将其打开并拖入一些文件 - 其中一个是 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 的函数，但它在这里不起作用，因为 此宏代码在 Outlook 中，而不是 Excel 中。

任何帮助将不胜感激。

Answer 1

也许this site 会为您指明正确的方向。

---

编辑：

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

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 = "someone@organisation.com"
            .CC = "someoneelse@organisation.com"
            .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 对象库。 This question 指向我那里。我喜欢避免后期绑定，以便显示 vba 智能感知，并且我知道这些方法是有效的。

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

我还从 this forum 获得了一些关于如何将文本插入电子邮件正文的帮助。

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

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

更多注意事项：

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

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

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