VBA - Copy From Excel into Outlook

Vlade777

New Member
Joined
Jun 14, 2013
Messages
2
Hello,

I've been scouring the internet for a while to try and figure out a way to copy data from Excel into an Outlook email, but haven't been successful. So I thought I would post the question here. Also, I'm fairly new to VBA, and have been learning everything I know from Google. So I apologize if this is a simple solution.

Essentially, I need a macro to do the following:
  1. Copy a range of cells from an Excel workbook
  2. Open up a new Outlook mail
  3. Paste the results into the body of the mail

It seems so simple, but I have yet to find any example of this online. If anyone has a solution, I would greatly appreciate it.

Thanks,
 
Hey all,

Can anyone help me with a similar request? I have a macro that auto-filters Column G for non-blank cells. Now I want to copy those visible (filtered) cells into the body of an email. What should the rest of my macro contain? Thanks!

Code:
Sub Filter

With ActiveSheet
    .AutoFilterMode = False
    .Range("A1:G1").AutoFilter
    .Range("A1:G1").AutoFilter Field:=7, Criteria1:="<>"
End With

End Sub
 
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
I don't suppose you would be able to help me out. I copied your code and adapted it to my needs. It worked fine for a few moments then all of a sudden I've started getting Runtime error 1004 and stating "Method 'Publish' of object 'PublishObject failed"


Thanks in advance

Joe

Code:
 Public Sub prcSendMail()
    Dim objOutlook As Object, objMail As Object
    
    Set objOutlook = CreateObject(Class:="Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    
    With objMail
        .To = "[EMAIL="Mark.pantall@plasticomnium.com"]Mark.pantall@plasticomnium.com[/EMAIL]"
        .Cc = "[EMAIL="gerhard.wolter@plasticomnium.com"]gerhard.wolter@plasticomnium.com[/EMAIL]"
        .Subject = "Leaf Requirements " & Format(Now, "dd/mm/yy")
        .HTMLBody = fncRangeToHtml("LEAF PLAN 2", "P27:R46")
        .Display 'zum testen
'        .Send
    End With
    
    Set objMail = Nothing
    Set objOutlook = Nothing
    
End Sub
  
Private Function fncRangeToHtml( _
    strWorksheetName As String, _
    strRangeAddress As String) As String
    
    Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
    Dim strFilename As String, strTempText As String
    Dim blnRangeContainsShapes As Boolean
    
    strFilename = Environ$("temp") & "" & _
        Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
        
    ThisWorkbook.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        FileName:=strFilename, _
        Sheet:=strWorksheetName, _
        Source:=strRangeAddress, _
        HtmlType:=xlHtmlStatic).Publish True
        
    Set objFilesytem = CreateObject("Scripting.FileSystemObject")
    
    Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
    strTempText = objTextstream.ReadAll
    objTextstream.Close
    
    For Each objShape In Worksheets(strWorksheetName).Shapes
        If Not Intersect(objShape.TopLeftCell, Worksheets( _
            strWorksheetName).Range(strRangeAddress)) Is Nothing Then
            
            blnRangeContainsShapes = True
            Exit For
            
        End If
    Next
    
    If blnRangeContainsShapes Then _
        strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
    
    fncRangeToHtml = strTempText
    fncRangeToHtml = Replace(fncRangeToHtml, "align=center x:publishsource=", "align=left x:publishsource=")
    
    Set objTextstream = Nothing
    Set objFilesytem = Nothing
    
    Kill strFilename
    
End Function
Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
    Const HTM_START = "") - lngPathLeft)
    strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
    strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
    strTemp = strTemp & "/"
    
    strTempText = Replace(strTempText, strTemp, Environ$("temp") & "" & strTemp)
    fncConvertPictureToMail = strTempText
    
End Function
 
Upvote 0
Hello Misca,

I have found below code which fulfill your requirements RangeWithShapesToHTML_BODY. Was posted on office-loesung.de from user Nepomuk:

Code:
Option Explicit
Public Sub prcSendMail()
    Dim objOutlook As Object, objMail As Object
    
    Set objOutlook = CreateObject(Class:="Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    
    With objMail
        .To = "[EMAIL="Mailadresse@irgendwo.de"]Mailadresse@irgendwo.de[/EMAIL]"
        .Subject = "Hallo"
        .HTMLBody = fncRangeToHtml("Sheet1", "B2:H37")
        .Display 'zum testen
'        .Send
    End With
    
    Set objMail = Nothing
    Set objOutlook = Nothing
    
End Sub

  
Private Function fncRangeToHtml( _
    strWorksheetName As String, _
    strRangeAddress As String) As String
    
    Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
    Dim strFilename As String, strTempText As String
    Dim blnRangeContainsShapes As Boolean
    
    strFilename = Environ$("temp") & "" & _
        Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
        
    ThisWorkbook.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        FileName:=strFilename, _
        Sheet:=strWorksheetName, _
        Source:=strRangeAddress, _
        HtmlType:=xlHtmlStatic).Publish True
        
    Set objFilesytem = CreateObject("Scripting.FileSystemObject")
    Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
    strTempText = objTextstream.ReadAll
    objTextstream.Close
    
    For Each objShape In Worksheets(strWorksheetName).Shapes
        If Not Intersect(objShape.TopLeftCell, Worksheets( _
            strWorksheetName).Range(strRangeAddress)) Is Nothing Then
            
            blnRangeContainsShapes = True
            Exit For
            
        End If
    Next
    
    If blnRangeContainsShapes Then _
        strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
    
    fncRangeToHtml = strTempText
    fncRangeToHtml = Replace(fncRangeToHtml, "align=center x:publishsource=", "align=left x:publishsource=")
    
    Set objTextstream = Nothing
    Set objFilesytem = Nothing
    
    Kill strFilename
    
End Function

Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
    Const HTM_START = "<link href="<br />    Const HTM_END = " rel="File-List" filelist.xml?
    
    Dim strTemp As String
    Dim lngPathLeft As Long
    
    lngPathLeft = InStr(1, strTempText, HTM_START)
    
    strTemp = Mid$(strTempText, lngPathLeft, InStr(lngPathLeft, strTempText, ">") - lngPathLeft)
    strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
    strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
    strTemp = strTemp & "/"
    
    strTempText = Replace(strTempText, strTemp, Environ$("temp") & "" & strTemp)
    fncConvertPictureToMail = strTempText
    
End Function


I don't suppose you would be able to help me out. I copied your code and adapted it to my needs. It worked fine for a few moments then all of a sudden I've started getting Runtime error 1004 and stating "Method 'Publish' of object 'PublishObject failed"


Thanks in advance

Joe

Code:
Public Sub prcSendMail()
    Dim objOutlook As Object, objMail As Object
    
    Set objOutlook = CreateObject(Class:="Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    
    With objMail
        .To = "[EMAIL="Mark.pantall@plasticomnium.com"]Mark.pantall@plasticomnium.com[/EMAIL]"
        .Cc = "[EMAIL="gerhard.wolter@plasticomnium.com"]gerhard.wolter@plasticomnium.com[/EMAIL]"
        .Subject = "Leaf Requirements " & Format(Now, "dd/mm/yy")
        .HTMLBody = fncRangeToHtml("LEAF PLAN 2", "P27:R46")
        .Display 'zum testen
'        .Send
    End With
    
    Set objMail = Nothing
    Set objOutlook = Nothing
    
End Sub
  
Private Function fncRangeToHtml( _
    strWorksheetName As String, _
    strRangeAddress As String) As String
    
    Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
    Dim strFilename As String, strTempText As String
    Dim blnRangeContainsShapes As Boolean
    
    strFilename = Environ$("temp") & "" & _
        Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
        
    ThisWorkbook.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        FileName:=strFilename, _
        Sheet:=strWorksheetName, _
        Source:=strRangeAddress, _
        HtmlType:=xlHtmlStatic).Publish True
        
    Set objFilesytem = CreateObject("Scripting.FileSystemObject")
    
    Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
    strTempText = objTextstream.ReadAll
    objTextstream.Close
    
    For Each objShape In Worksheets(strWorksheetName).Shapes
        If Not Intersect(objShape.TopLeftCell, Worksheets( _
            strWorksheetName).Range(strRangeAddress)) Is Nothing Then
            
            blnRangeContainsShapes = True
            Exit For
            
        End If
    Next
    
    If blnRangeContainsShapes Then _
        strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
    
    fncRangeToHtml = strTempText
    fncRangeToHtml = Replace(fncRangeToHtml, "align=center x:publishsource=", "align=left x:publishsource=")
    
    Set objTextstream = Nothing
    Set objFilesytem = Nothing
    
    Kill strFilename
    
End Function
Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
    Const HTM_START = "") - lngPathLeft)
    strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
    strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
    strTemp = strTemp & "/"
    
    strTempText = Replace(strTempText, strTemp, Environ$("temp") & "" & strTemp)
    fncConvertPictureToMail = strTempText
    
End Function
 
Upvote 0
Thank you for sharing this code - I was struggling to find the code that would export formatted excel cells in outlook.


I'm trying now to modify it so it would export all worksheets from the book to email address specified in A1 cell in each workbook


May be someone could help me with that ? I'm very new to VBA and still learning how it works :)


Many thanks in advance !!
 
Upvote 0
I think this code is just what I needed. However, I seem to be getting error on line "With GetObject(, "Word.Application")". Error message is ActiveX component cannot create object. I have pasted this component in Excel VBA Editor and not in Outlook VBA Editor. Can I know why I am getting this error? I have checked the reference to MS Word, MS Office & MS Outlook 16.0 Object Libraries within EXCEL VBA references. Juts an FYI. Thanking in advance.

I mean that if Word is Outlook's default editor then this copies the selected Excel's range with its shapes into the new e-mail body:
Rich (BB code):
Sub CopyRangeToRtfMail()
' ZVI:2013-06-15 http://www.mrexcel.com/forum/excel-questions/708544-visual-basic-applications-copy-excel-into-outlook.html
 
  Const olFormatRichText = 3, olEditorRTF = 3, olEditorWord = 4
  Dim olApp As Object, olEditorType As Long
  Dim IsCopyObject As Boolean
 
  ' Assign CopyObjectsWithCells=True
  With Application
    IsCopyObject = .CopyObjectsWithCells
    .CopyObjectsWithCells = True
  End With
 
  ' Copy the selected Excel's range with objects
  Selection.Copy
 
  ' Get/Greate object of Outlook Aplication
  On Error Resume Next
  Set olApp = GetObject(, "Outlook.Application")
  If Err Then
    Set olApp = CreateObject("Outlook.Application")
  End If
  On Error GoTo 0
 
  ' Paste into email body of RTF type
  With olApp.CreateItem(0)
    ' Check the type of Outlook's editor (Word is expected)
    olEditorType = .GetInspector.EditorType
    ' Copy range with shapes from Excel to email of RFT format
    If olEditorType = olEditorRTF Or olEditorType = olEditorWord Then
      'Set body format to RTF
      .BodyFormat = olFormatRichText
      ' Paste to RTF email
      With GetObject(, "Word.Application")
        .Visible = True
        .Selection.Paste
      End With
      ' Show or send email
      .Display ' or .Send
    Else
      MsgBox "Outlook's default Editor is not Word", vbExclamation, "Not copied"
    End If
   
    ' Disable Excel's copy mode
    Application.CutCopyMode = False
   
    ' Restore CopyObjectsWithCells
    Application.CopyObjectsWithCells = IsCopyObject
   
    ' Clear the memory of object variable
    Set olApp = Nothing
 
  End With
 
End Sub
Regards
 
Upvote 0
That code (post #7 ) was written for Outlook 2003 where WordEditor was not embedded into Outlook.
For Outlook 2007+ replace this line of the code: With GetObject(, "Word.Application")
by that one: With .GetInspector.WordEditor.Application
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,205
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top