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,
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
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).
 
Upvote 0
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
 
Upvote 0
...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
 
Upvote 0
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:
Upvote 0
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.
 
Upvote 0
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:
Upvote 0
May be you mean this: .HTMLBody = fncRangeToHtml("Sheet1", Sheets("Sheet1").UsedRange.Address)
 
Upvote 0

Forum statistics

Threads
1,212,927
Messages
6,110,733
Members
448,294
Latest member
jmjmjmjmjmjm

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