Copying/pasting from an Excel file using Outlook VBA.

Question

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

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

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.

Any help would be appreciated.

Answer 1

Maybe this site will 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 = "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

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

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

I also got some help from this forum on 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:

[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.