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,
 

Misca

Well-known Member
Joined
Aug 12, 2009
Messages
1,558
To me Ron is The Man when it comes to VBA and Outlook.

The only question I still haven't found an answer to from his site is how to send a range with images from Excel to Outlook (=paste the range as it is to the email body using VBA).
 

GermanPath

Board Regular
Joined
May 18, 2013
Messages
81
To me Ron is The Man when it comes to VBA and Outlook.

The only question I still haven't found an answer to from his site is how to send a range with images from Excel to Outlook (=paste the range as it is to the email body using VBA).
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 rel="File-List" href="<br />    Const HTM_END = " 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
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,658
...I have found below code which fulfill your requirements RangeWithShapesToHTML_BODY. Was posted on office-loesung.de from user Nepomuk
Because the code was truncated by engine of this board here is the link to the original code: Email mit Bild(Metafile) versenden - - - - - Office-Loesung.de

Another way is in using of MS Word as the Outlook's editor and set RTF as default format.
Then Outlook's new e-mail is activated, you can copy Excel's range with shapes by Range(...).Copy and paste it by GetObject(, "Word.Application").Selection.Paste
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,658
Another way is in using of MS Word as the Outlook's editor ...
Then Outlook's new e-mail is activated, you can copy Excel's range with shapes by Range(...).Copy and paste it by GetObject(, "Word.Application").Selection.Paste
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
 
Last edited:

Misca

Well-known Member
Joined
Aug 12, 2009
Messages
1,558
Thank you for your suggestions, both of you!

I had managed to solve the problem by including the images as attachments and adding a piece of good old HTML to the message body but the solution I had come up with works best when the images are at the beginning or at the end of the message. The images seem to have an additional white space around them which I didn't like too much. Also controlling the image size was a bit complicated. I'll definitely check out those two examples.
 

kesavabca

New Member
Joined
Jun 18, 2014
Messages
1
i need to select the range dinamicale insted of spesifing B1:h37 i need a loop for this to select the raing automaticale.macro has to select the range in sheet which ever calls contain the data
 
Last edited:

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,658
May be you mean this: .HTMLBody = fncRangeToHtml("Sheet1", Sheets("Sheet1").UsedRange.Address)
 

Forum statistics

Threads
1,085,171
Messages
5,382,125
Members
401,773
Latest member
BredAnderson

Some videos you may like

This Week's Hot Topics

Top