VBA - Send screen shot in email (formatting lost)

E

ElBB23

New Member
Joined
Feb 10, 2017
Messages
26
Hi all,

I have the below coding to send an email with a screen shot of excel attached, but it is losing the formating when pasting into the email body, please can you help.


VBA Code: 
 Application.ScreenUpdating = False
 
     'Declare Outlook Variables
     Dim oLookApp As Outlook.Application
     Dim oLookItm As Outlook.MailItem
     Dim oLookIns As Outlook.Inspector
     Dim Subject As String
     Dim DistrlistMain As String

     'Declare Word Variables
     Dim oWrdDoc As Word.Document
     Dim oWrdRng As Word.Range

     'Delcare Excel Variables
     Dim ExcShrinkRange As Range

     On Error Resume Next

     'Get the Active instance of Outlook if there is one
     Set oLookApp = GetObject(, "Outlook.Application")

     'If Outlook isn't open then create a new instance of Outlook
     If Err.Number = 429 Then

     'Clear Error
      Err.Clear

     'Create a new instance of Outlook
     Set oLookApp = New Outlook.Application

     End If

     'Create a new email
     Set oLookItm = oLookApp.CreateItem(olMailItem)


     'Create an array to hold ranges
     Set ExcShrinkRange = Sheet1.Range("Range")

     With oLookItm
    
     Subject = Sheet1.Range("V2").Value
     DistrlistMain = Sheet1.Range("U2").Value

    
         'Define some basic info of our email
         .SentOnBehalfOfName = "Email address"
         .To = DistrlistMain
         .Subject = Subject
        .Body = ""
         'Display the email
  .Display

         'Get the Active Inspector
         Set oLookIns = .GetInspector

         'Get the document within the inspector
         Set oWrdDoc = oLookIns.WordEditor
            'get range
          Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content
           oWrdRng.Collapse Direction:=wdCollapseEnd
          
          
          'copy range
          ExcShrinkRange.Copy
          oWrdRng.PasteSpecial ppPastePNG
    
 .Display
 
                  
 Application.ScreenUpdating = True
  
          End With
          
 End Sub
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Sort by date Sort by votes
Hi ElBB23,
try this code
VBA Code: 
Sub test()

    Dim OutApp As Object, OutMail As Object
    Dim x      As Range
    Dim Name   As String, StrDest As String, MySubject As String
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        
    StrDest = Sheet1.Range("U2").Value
    MySubject = Sheet1.Range("V2").Value
    Name = ThisWorkbook.Path & "\MyPicture.JPG"
            
    Set x = Sheet1.Range("Range")
    
    x.CopyPicture
    
    With ActiveSheet.ChartObjects.Add(0, 0, x.Width, x.Height).Chart
        .Parent.Activate
        .Paste
        .Export Filename:=Name, FilterName:="jpg"
        .Parent.Delete
    End With
    
    With OutMail
        .To = StrDest
        .CC = ""
        .BCC = ""
        .Subject = MySubject
        .Attachments.Add Name, 1, 0
        .HTMLBody = "<html><p>Hi everyone,</p>" & _
                    "<img src=""cid:MyPicture.JPG""height=400 width=600>"
        .display
    End With
    
    Set OutApp = Nothing
    Set OutMail = Nothing
    
    Kill Name
    
End Sub
 
Upvote 0
Solution
Perfect thank you,

One small thing, it does make it go a bit "blurry" but can copy with that if its not fixable
 
Upvote 0
Hi ElBB23,
thanks for the feedback, you can try by adjusting the height and width of the image in the code. I suggest you a different approach by transforming the range into html (original code from Ron de Bruin's site), it definitely keeps original aspect ratio and formatting. Here's the code:
VBA Code: 
Sub test2()

    Dim OutApp As Object, OutMail As Object
    Dim rng   As Range, StrDest As String, MySubject As String
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        
    StrDest = Sheet1.Range("U2").Value
    MySubject = Sheet1.Range("V2").Value
              
    Set rng = Sheet1.Range("Range")
        
    With OutMail
        .To = StrDest
        .CC = ""
        .BCC = ""
        .Subject = MySubject
        .HTMLBody = "<html><p>Hi everyone,</p>" & _
                    RangetoHTML(rng)
        .display
    End With
    
    Set OutApp = Nothing
    Set OutMail = Nothing
        
End Sub

Function RangetoHTML(rng As Range)
    
    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 xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        .Range("A1:J13").ColumnWidth = 5
        '.Range("B4:J13").Font = 9
        
        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
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
Range of Cells to Body of Email (Original Sig Included) Using VBA
Replies
2
Views
930
John_w
J
L
  • Question
Trying to Copy and Paste Excel Range to Outlook but Paste Not Working
Replies
1
Views
367
NdNoviceHlp
NdNoviceHlp
M
  • Question
I want to put the signature below de temporaly screenshot but it appers above, could you assist to me please?
Replies
0
Views
203
MiyagiZama
M
M
  • Question
How to make a string in to bold in Outlook VBA?
Replies
1
Views
446
MiyagiZama
M
M
  • Question
I want o put some strings in bold, could you assist to me please_
Replies
1
Views
288
Micron
M

Forum statistics

Threads
1,214,988
Messages
6,122,620
Members
449,092
Latest member
amyap

Share this page

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