使用 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

也許這個網站會為你指明正確的方向。

---

編輯：

經過一番修修補補，我得到了這個工作：

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 對象庫。 這個問題把我指向了那里。 我喜歡避免后期綁定，以便 vba 智能感知出現，並且我知道這些方法是有效的。

RangetoHTML 來自Ron Debruin （我必須編輯 PasteSpecial 方法才能讓它們工作）

我也從這個論壇得到了一些關於如何在電子郵件正文中插入文本的幫助。

我將日期添加到臨時文件名中，因為我試圖多次保存它。

我希望這會有所幫助。 我確實學到了很多！

更多注意事項：

在我看來，細胞被截斷了。 正如mvsub1 在此處解釋的那樣，使用 RangeToHTML 函數的問題在於它將超出列寬的文本視為隱藏文本並將其粘貼到電子郵件中：

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

如果您遇到類似問題，頁面上會討論一些解決方案。