none
VBA Code Copy from Excel and paste into Outlook RRS feed

  • Question

  • Hi I'm trying to copy and paste a range in excel. I found the below code online from the reference below. The code debugs where the bold and underline code is. I've tried different scenarios to prevent it from debugging, but have been unsuccessful. The new workbook will appear, but the range does not paste nor am i able to manually paste. 

    Error: Run-time error 1004:

    The command cannot be used on multiple selections

    Reference: https://www.reddit.com/r/excel/comments/37ppo4/how_to_copy_excel_cells_into_a_outlook_email/

    Function RangetoHTML(rng As Range)

    ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook

        TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

        ' Copy the range and create a workbook to receive the data.
        rng.Copy
        Set TempWB = Workbooks.Add(1)
       With TempWB.Sheets(1)
            
    '        .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial
    '        .Cells(1).PasteSpecial xlPasteValues, , False, False
    '        .Cells(1).PasteSpecial xlPasteFormats, , False, False
    '        .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With

        ' Publish the sheet to an .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 the RangetoHTML subroutine.
        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.
        Kill TempFile

        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function

    Thursday, June 1, 2017 11:59 PM

All replies

  • Note there is two sub in link. SendMail and RangeToHtml. In RangeToHtml there is a parameter called rng. It is supplied by SendMail.

    If you do not use SendMail, you have to supply by other way.

    Secondly, the function rangetohtml returns a HTML text string and SendMail uses that in .HTMLBody property of Mail Body.It is not doing any copy paste


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Friday, June 2, 2017 4:04 AM
    Answerer
  • So i made the changes, but it was pasting an image of a snippet i took instead of the range from the workbook. I activated the workbook and tried different actions, but its still unresolved.

    Debugging on .Cells(1).PasteSpecial Paste:=8

    Any suggestions? 

    The error now is 

    Error: Pastespecial method of range class failed

    reference:

    https://stackoverflow.com/questions/17281872/error-pastespecial-method-of-range-class-failed


    • Edited by Legzen34 Friday, June 2, 2017 4:49 PM
    Friday, June 2, 2017 4:04 PM
  • temp files being created

    I can see temp files being created. Would this cuse an issue. Each one is open, but I'm not sure by what means.

    Friday, June 2, 2017 4:38 PM
  • Here is my full code. please help.


    Sub PrintLoop()
        'Connect to Outlook
        Set olApp = CreateObject("Outlook.Application")
        
        Dim curRow As Integer
        Dim SheetCount As Integer
        Dim SheetArray() As Variant
        
        
    '    On Error Resume Next
        ' Only send the visible cells in the selection.
    '    Set rng = Selection.SpecialCells(xlCellTypeVisible)
        
        On Error GoTo 0
        
        
        'Identify the sheet name where the Named Range "MacroSheet" exists for use later in code.
        'This will enable the end user to change the name of the sheet to whatever they want, as long as the named range exists on it.
        Dim MacroSheetName As String
        MacroSheetName = Range("MacroSheet").Worksheet.Name
        
        
        With ThisWorkbook.Worksheets(MacroSheetName)
            'Start SheetArray Process
            'Identify the sheets that need to be copied to a new workbook
            curRow = .Range("MacroMacroIncludeSheets").Row
            SheetCount = 0
            Do While .Cells(curRow + 1, .Range("MacroMacroIncludeSheets").Column) <> Empty
                SheetCount = SheetCount + 1
                curRow = curRow + 1
                ReDim Preserve SheetArray(1 To SheetCount)
                SheetArray(SheetCount) = .Cells(curRow, .Range("MacroMacroIncludeSheets").Column).Value
            Loop
            'End SheetArray Process
            

            'Check to see if Output Directory exists.  If it does not, create it.
            If Dir(Range("MacroOutputDir").Value, vbDirectory) = "" Then
                MkDir Path:=Range("MacroOutputDir").Value
            End If
        
        
            curRow = .Range("MacroPropName").Row 'Sets default row based on where the Named Range
            'Begin looping through Props where BOOL = TRUE.
            Do While .Cells(curRow + 1, .Range("MacroPropName").Column) <> Empty
                curRow = curRow + 1
                'Debug.Print .Cells(curRow, Range("MacroPropName").Column).Value
                
                'Begin MacroRun_TF
                If .Cells(curRow, Range("MacroRun_TF").Column) Then 'Check for if Property is flagged to run or not
                    .Range("MacroProp").Value = .Cells(curRow, Range("MacroPropName").Column).Value
                    Worksheets("MARS").Range("MARSData").ClearContents
                    Application.Calculate
                    Call Example_HypRetrieve
                    Application.Calculate
                    'If Not Application.CalculationState = xlDone Then DoEvents 'Waits for workbook to completely calculate before advancing in the code
                    Do While Application.CalculationState <> xlDone
                        DoEvents
                    Loop
                    
                    'Debug.Print .Cells(curRow, Range("MacroRun_TF").Column).Value
                    
                    'Supress save override warning
                    Application.DisplayAlerts = False
                    
                    'Begin MacroExportXLSX
                    If .Cells(curRow, Range("MacroExportXLSX").Column) Then
                        ThisWorkbook.Sheets(SheetArray).Copy 'Copies the Array of Sheets to a new workbook
                        Application.Wait (Now + TimeValue("0:00:01")) 'Waits one second, otherwise vba will get ahead of itself and not break links
                        ActiveWorkbook.BreakLink Name:=ThisWorkbook.FullName, Type:=xlExcelLinks 'breaks links from this workbook to newly created workbook (leaving formulas)
                        ActiveWorkbook.SaveAs Filename:=.Range("MacroOutputDir").Value & .Cells(curRow, .Range("MacroFileName").Column).Value, FileFormat:=51 'saves newly created workbook
                        Workbooks(.Cells(curRow, .Range("MacroFileName").Column) & ".xlsx").Close 'closes newly created workbook
                    End If
                    'End MacroExportXLSX
                    
                    'Begin MacroExportPDF
                    If .Cells(curRow, Range("MacroExportPDF").Column) Then
                        ThisWorkbook.Sheets(SheetArray).Select 'selects sheets for printing based on array of selected sheets
                        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=.Range("MacroOutputDir").Value & .Cells(curRow, .Range("MacroFileName").Column).Value, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False 'prints selected sheets to PDF
                    End If
                    'End MacroExportPDF
                    
                    'Bring back application warnings after exports are finished
                    Application.DisplayAlerts = True
                    

    Application.CutCopyMode = False

    'Windows("Hotel Profitability.xlsm").Activate
    Dim rng As Range
    Set rng = Sheets("Email View Tab").Range("C4:M29")
    'rng.Copy

                    'Begin MacroEmail
                    If .Cells(curRow, Range("MacroEmail").Column) Then
                        Set OutMail = olApp.CreateItem(olMailItem)
                        OutMail.To = .Cells(curRow, .Range("MacroEmailTo").Column)
                        OutMail.CC = .Cells(curRow, .Range("MacroCCTo").Column)
                        '.BCC = ""
                        OutMail.Subject = .Cells(curRow, .Range("MacroSubjectLine").Column)
                        OutMail.HTMLBody = "Hello," & "<br>" _
                        & " " & "<br>" _
                        & "Please see attached for the Weekly Hotel Profitability Tracker. Please let us know if there are individuals who should be added to this distribution." & "<br>" _
                        & " " & "<br>" _
                        & RangetoHTML(rng) & "<br>" _
                        & "Expenses are estimated based on variables that incldues labor dollars and trailing twelve months GL data." & "<br>" _
                        & " " & "<br>" _
                        & "We would like to make this report as actionable as possible.  Feel free to let us know of any additional information you would like to see on this report." & "<br>" _
                        & " " & "<br>" _
                        & "Please let me know if you have any questions." & "<br>" _
                        & " " & "<br>" _
                        & "Thank you,"

    '                    .Cells(curRow, .Range("MacroEmailBody").Column)


                        If .Cells(curRow, Range("MacroExportXLSX").Column) Then OutMail.Attachments.Add .Range("MacroOutputDir").Value & .Cells(curRow, .Range("MacroFileName").Column).Value & ".xlsx"
                        If .Cells(curRow, Range("MacroExportPDF").Column) Then OutMail.Attachments.Add .Range("MacroOutputDir").Value & .Cells(curRow, .Range("MacroFileName").Column).Value & ".pdf"
                        .Display
                        '.Send
                        OutMail.Save
                        '.SaveAs "C:\Users\ MyUsername\ Desktop\ MyDrafts\ " & "myEmail" & ".msg"
                    End If
                    'End MacroEmail
                    
                End If
                'End MacroRun_TF
            
            Loop
            
        End With
        
    End Sub

    Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2016
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook

        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
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.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


    Friday, June 2, 2017 6:07 PM
  • What range you specified ? How you are calling the function ?

    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Friday, June 2, 2017 7:04 PM
    Answerer
  • My range is 

    Set rng = Sheets("Email View Tab").Range("C4:M29")

    and I'm calling by 

    OutMail.HTMLBody = "Hello," & "<br>" _
                        & " " & "<br>" _
                        & "Please see attached for the Weekly Hotel Profitability Tracker. Please let us know if there are individuals who should be added to this distribution." & "<br>" _
                        & " " & "<br>" _
                        & RangetoHTML(rng) & "<br>" _

    Friday, June 2, 2017 8:58 PM
  • in rangeTohtml code (bottom ) one line is there rng.copy

    but it is prceded with ' (Apostrophe). Remove that ' and run.


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Saturday, June 3, 2017 8:28 AM
    Answerer
  • I have that in apostrophe because it errors out indicating the first error.

    i'm not sure what i'm doing wrong.

    Monday, June 5, 2017 4:00 PM
  • Remove that and share the line where error appears.

    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Tuesday, June 6, 2017 9:20 AM
    Answerer
  • No matter how i update the code it always seems to pinpoint to the rangetoHTML function i created. Yesterday i had it running, but it skipped the copying of the range to paste into outlook. When i tried to update it to always seems to point to the rangetoHTML function. 

    Tuesday, June 6, 2017 5:35 PM
  • Can you upload a sample file removing all confidential info.

    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Tuesday, June 6, 2017 6:19 PM
    Answerer
  • how would i upload in this thread?

     there is no option

    Tuesday, June 6, 2017 6:48 PM
  • This is where it's currently debugging. A temporary workbook is being created and the rng is being selected, but it is not pasting. The error Error '1004': That command cannot be used on multiple selections" pops up. 

    Please assist.

    Wednesday, June 7, 2017 12:08 AM
  • Hi Legzen34,
    What's the selected range? Could you paste the selected range to the temporary workbook manually? I suggest you share your file by OneDrive and put link here.
    Best Regards,
    Terry
    Wednesday, June 7, 2017 2:34 AM
  • Well after I made several updates to my code, and realized that this error stands in my way. 

    This morning I realized, that my code is exporting three sheets to be attached into the email, and therefore locking the ranges so I cannot export my range. 

    A quick fix was for me to simply selecting the sheet I wanted before the body was inserted.

    Wow, i feel dumb...really dumb..hahahah!

    Wednesday, June 7, 2017 4:52 PM
  • A quick fix was for me to simply selecting the sheet I wanted before the body was inserted.

    Hello,

    It seems that you have resolved your issue, I suggest you mark your solution as answer to close this thread. Thanks for your understanding. It the issue persists, please feel free to let us know.

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Thursday, June 8, 2017 3:03 AM
    Moderator