Filter Table, Select Range, Copy as Picture and Paste in Outlook Email

[Marhier]

Good afternoon, I hope you're all well.
I've been searching here and other forums all day and can't find a soltuion to a problem I'm having.

I have a worksheet where I want the user to click a button, it filters the table by a particular criteria, highlights a range, copies that range as a picture, opens a new email and pastes that image in the body of the email along with some text.

I'm pretty much there, but the issue I'm having is, the picture is being cut off half way across once pasted.
If I manually copy as picture and paste to an email, it works no problem.

I've read time and time again that it might me down to Application.ScreenUpdating, but I don't have any of that in my code at the moment.

My code is as follows:

Sub Notify()

'Outlook Variables
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim oLookIns As Outlook.Inspector

'Excel Variables
Dim ExcRng As Range
Dim wsSheet As Worksheet, rRng As Range, sRnge As Range, fRng As Range
Set wsSheet = ActiveSheet
Set rRng = wsSheet.Range("A8:X1008")
Set sRng = wsSheet.Range("Y1")
Set fRng = wsSheet.Range("A8:P1008")

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

'Unprotect the sheet
ActiveSheet.Unprotect

'Filter the table
With rRng
    .AutoFilter Field:=22, Criteria1:="O"
    If .SpecialCells(xlCellTypeVisible).Address = .Rows(1).Address Then
    MsgBox "There are no lines set as 'To Order' - Status 'O'."
    wsSheet.AutoFilter.ShowAllData
    ActiveSheet.Protect
Exit Sub
Else
End If
End With

On Error Resume Next

'Get the Active instance of Outlook
Set oLookApp = GetObject(, "Outlook.Applicaiton")

'If error, 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

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

'Create a reference to Excel range
Set ExcRng = wsSheet.Range("A8:P1008")

With oLookItm
    .To = "me@me.com"
    .CC = ""
    .BCC = ""
    .Subject = sRng
    .Body = "Hello, the following has been added to order."
   
    'Display email
    .Display
   
    'Get the Active Inspector
    Set oLookIns = .GetInspector
   
    'Get Word Editor
    Set oWrdDoc = oLookIns.WordEditor
   
    'Specify the range in the document
    Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content
        oWrdRng.Collapse Direction:=wdCollapseEnd
       
    'Add paragraph and insert break
    Set oWrdRng = oWdEditpor.Paragraph.Add
        oWrdRng.InsertBreak
       
    'Copy the Range
    ExcRng.Copy
   
    'Paste it
    oWrdRng.PasteSpecial DataType:=wdPasteMetafilePicture
   
End With
ActiveSheet.Protect
End Sub

If anyone can point me in the right direction, it would be greatly appreciated.

Thank you.
Regards
Marhier.

 

[Marhier]

Good morning.
Further to the below, I've been trying different things and amended the following code:

'Copy the Range
ExcRng.Copy

'Paste it
oWrdRng.PasteSpecial DataType:=wdPasteMetafilePicture

To the following:

'Copy the Range
ExcRng.CopyPicture xlScreen, xlPicture

'Paste it
oWrdRng.Paste

I then realised that the image being pasted this time isn't cut off, but being pasted at 37% of it's original size.
I then reworked my code to include more Word variables and try and manually resize the image to 100%

The code doesn't flag up any issues, but it also doesn't resize the image I'm pasting into the Outlook email
If someone could help as to where I'm going wrong, it would be greatly appreciated.

Current code is now:

Sub Notify()

'Outlook Variables
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim oLookItm2 As Outlook.MailItem
Dim oLookIns As Outlook.Inspector

'Excel Variables
Dim ExcRng As Range
Dim wsSheet As Worksheet, rRng As Range, sRnge As Range, fRng As Range
Set wsSheet = ActiveSheet
Set rRng = wsSheet.Range("A8:X1008")
Set sRng = wsSheet.Range("Y1")
Set fRng = wsSheet.Range("A8:P1008")

'Word Variables
Dim oWrdDoc As Word.Document
Dim oWrdDoc2 As Word.Document
Dim oWrdRng As Word.Range
Dim objInlineShape As Word.InlineShape
Dim objShape As Word.Shape


'Unprotect the sheet
ActiveSheet.Unprotect

'Filter the table
With rRng
    .AutoFilter Field:=22, Criteria1:="O"
    If .SpecialCells(xlCellTypeVisible).Address = .Rows(1).Address Then
    MsgBox "There are no lines set as 'To Order' - Status 'O'."
    wsSheet.AutoFilter.ShowAllData
    ActiveSheet.Protect
Exit Sub
Else
End If
End With

On Error Resume Next

'Get the Active instance of Outlook
Set oLookApp = GetObject(, "Outlook.Applicaiton")

'If error, 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

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

'Create a reference to Excel range
Set ExcRng = wsSheet.Range("A8:P1008")

With oLookItm
    Set oWrdDoc2 = oLookItm2.GetInspector.WordEditor
    .To = "me@me.com"
    .CC = ""
    .BCC = ""
    .Subject = sRng
    .Body = "Hello, the following has been added to order."
    
    'Display email
    .Display
    
    'Get the Active Inspector
    Set oLookIns = .GetInspector
    
    'Get Word Editor
    Set oWrdDoc = oLookIns.WordEditor
    
    'Specify the range in the document
    Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content
        oWrdRng.Collapse Direction:=wdCollapseEnd
        
    'Add paragraph and insert break
    Set oWrdRng = oWdEditpor.Paragraph.Add
        oWrdRng.InsertBreak
        
    'Copy the Range
    ExcRng.CopyPicture xlScreen, xlPicture
    
    'Paste it
    oWrdRng.Paste

    For Each objInlineShape In oWrdDoc2.InlineShapes
        objInlineShape.ScaleHeight = 100
        objInlineShape.ScaleWidth = 100
    Next
    
    For Each objShape In oWrdDoc2.Shapes
        objShape.ScaleHeight PercentSize / 100, msoCTrue
        objShape.ScaleWidth PercentSize / 100, msoCTrue
    Next
End With
wsSheet.AutoFilter.ShowAllData
ActiveSheet.Protect
End Sub

Much appreciated.
Thank you.
Regards
Marhier

 

[Marhier]

I've decided doing it as an image is proving too much of a pain in the backside.
If anyone can solve this and let me know, it would be greatly appreciated.

For now, I've changed it to just copying and pasting it as a table directly, along with it's formats; which seems to work quite nicely.

My code is now:

Sub NotifyToOrder()
Application.ScreenUpdating = False

'Variables
Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object
Dim oLookApp As outlook.Application
Dim wsSheet As Worksheet, rRng As Range, sRnge As Range, fRng As Range
Set wsSheet = ActiveSheet
Set rRng = wsSheet.Range("A8:X1008")
Set sRng = wsSheet.Range("Y1")
Set fRng = wsSheet.Range("A8:P1008")
Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)

'Unprotect the sheet
ActiveSheet.Unprotect

'Filter the table
With rRng
    .AutoFilter Field:=22, Criteria1:="O"
    If .SpecialCells(xlCellTypeVisible).Address = .Rows(1).Address Then
    MsgBox "There are no lines set as 'To Order' - Status 'O'."
    wsSheet.AutoFilter.ShowAllData
    ActiveWindow.ScrollRow = 1
    wsSheet.Range("A1").Select
    wsSheet.Protect
    Application.ScreenUpdating = True
Exit Sub
Else
End If
End With

On Error Resume Next

'Get the Active instance of Outlook
Set oLookApp = GetObject(, "Outlook.Applicaiton")

'If error, 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

With newEmail
    .To = "me@me.com"
    .CC = ""
    .BCC = ""
    .Subject = sRng
    .Body = "Hello, the following has been added to order." & vbCrLf & vbCrLf & "Thank you."
    .Display
    Set xInspect = newEmail.GetInspector
    Set pageEditor = xInspect.WordEditor

    fRng.Copy
        
    pageEditor.Application.Selection.Start = Len(.Body)
    pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
    pageEditor.Application.Selection.Paste
    .Display
    Set pageEditor = Nothing
    Set xInspect = Nothing
    
End With

Set newEmail = Nothing
Set outlook = Nothing

wsSheet.AutoFilter.ShowAllData
ActiveWindow.ScrollRow = 1
wsSheet.Range("A1").Select
wsSheet.Protect
Application.ScreenUpdating = True
End Sub

 

[John_w]

Your code contains several spelling mistakes (e.g Applicaiton and oWdEditpor) which are 'hidden' when you run the code because you're using On Error Resume Next, and I guess you haven't specified Option Explicit at the top of the module. You should always use Option Explicit to detect these sort of errors at compile time.

Try this macro, which doesn't rely on Outlook's Word editor to paste the image of the filtered cells. Instead, it creates a HTML email, attaches the image of the filtered cells and references the image in the img tag. HTML emails allow more flexibility with formatting and layout.

Looking at your code, you are filtering columns A:X (from A8:X8) on column V and then copying only columns A:P into the email. My macro does the same.

You'll see that the function Save_Object_As_Picture allows scaling of the image if you specify the optional scaleFactor argument. scaleFactor = 1 means 100% scale (default); scaleFactor = 0.9 means 90% scale; scaleFactor = 1.1 means 110% scale, etc.

Public Sub Create_Outlook_Email_with_Image()

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim OutAttachment As Outlook.Attachment
    Dim OutPropertyAcc As Outlook.PropertyAccessor
    Dim SendTo As String, CC As String
    Dim emailSubject As String
    Dim dataCells As Range, filteredCells As Range
    Dim cellsImage As String, tempCellsFile As String
    Dim dataSheet As Worksheet, tempSheet As Worksheet
    Dim HTML As String
    
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
    
    SendTo = "email.address1@email.com"
    CC = "email.address2@email.com;email.address3@email.com"
    
    Set dataSheet = ActiveSheet
    With dataSheet
        If .AutoFilterMode Then .AutoFilter.ShowAllData
        Set dataCells = .Range("A8:X1008")
        emailSubject = .Range("Y1").Value
        .Unprotect
    End With
    
    'Filter the range on column V
    
    With dataCells
        .AutoFilter Field:=22, Criteria1:="O"
        If .SpecialCells(xlCellTypeVisible).Address = .Rows(1).Address Then
            MsgBox "There are no lines set as 'To Order' - Status 'O'."
            dataSheet.AutoFilter.ShowAllData
            dataSheet.Protect
            Exit Sub
        Else
            'Reference the first 16 columns (A:P) of filtered range and copy as picture to temporary sheet
            Set filteredCells = dataCells.CurrentRegion.Resize(, 16).SpecialCells(xlVisible)
            Set tempSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            filteredCells.Copy
            tempSheet.Pictures.Paste
        End If
    End With
    
    'Save picture as a temporary .jpg file
    
    cellsImage = Replace(Timer, ".", "") & "image.jpg"
    tempCellsFile = Environ("temp") & "\" & cellsImage
    Save_Object_As_Picture tempSheet.Pictures(1), tempCellsFile
    
    'Construct the HTML string, with the .jpg file in an img tag with corresponding src='cid:xxxx.jpg' attribute
    
    HTML = "<html>"
    HTML = HTML & "<p>Hello, the following has been added to order.</p>"
    HTML = HTML & "<p>Thank you.</p>"
    HTML = HTML & "<img src='cid:" & cellsImage & "'>"
    HTML = HTML & "<p>New text paragraph below the image.<br>New line in same paragraph.</p>"
    HTML = HTML & "</html>"
    
    On Error Resume Next
    'Get the active instance of Outlook
    Set OutApp = GetObject(, "Outlook.Application")
    'If error, create a new instance of Outlook
    If Err.Number = 429 Then
        Set OutApp = New Outlook.Application
    End If
    On Error GoTo 0
    
    'Create the email

    Set OutMail = OutApp.CreateItem(olMailItem)
    With OutMail
        .To = SendTo
        .CC = CC
        .Subject = emailSubject
        
        'Attach the image referenced in the img tag
        
        Set OutAttachment = .Attachments.Add(tempCellsFile)
        Set OutPropertyAcc = OutAttachment.PropertyAccessor
        OutPropertyAcc.SetProperty PR_ATTACH_CONTENT_ID, cellsImage
        
        .HTMLBody = HTML
        
        .Display
    End With
       
    'Delete the temporary image file and sheet
    
    Kill tempCellsFile
    Application.DisplayAlerts = False
    tempSheet.Delete
    Application.DisplayAlerts = True
    
    dataSheet.Protect
    
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub


Private Sub Save_Object_As_Picture(saveObject As Object, imageFileName As String, Optional scaleFactor As Single)

    'Save a picture of an object as a JPG/JPEG file
    
    'Arguments
    'saveObject     - any object in the CopyPicture method's 'Applies To' list, for example a Range or Shape
    'imageFileName  - the .jpg or .jpeg file name (including folder path if required) the picture will be saved as
    
    Dim temporaryChart As ChartObject
     
    Application.ScreenUpdating = False
    
    saveObject.CopyPicture xlScreen, xlPicture
    Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
    With temporaryChart
        .Activate                                'Required, otherwise image is blank with Excel 2016 or fast CPU
        .Border.LineStyle = xlLineStyleNone      'No border
        .Chart.Paste
        If scaleFactor > 0 Then
            .Width = .Width * scaleFactor
            .Height = .Height * scaleFactor
        End If
        .Chart.Export imageFileName
        .Delete
    End With
    
    Application.ScreenUpdating = True
    
    Set temporaryChart = Nothing
    
End Sub

 

[Marhier]

You're an absolute star, that worked a treat!

It gave me a 'Compile Error: Argument not optional' when using:

Set filteredCells = dataCells.CurrentRegion.Resize(, 16).SpecialCells(xlVisible)

I amended it to:

Set filteredCells = dataSheet.Range("A8:P1008")

Seems to make it run perfectly after that

Thanks for your tip on Option Explicit; I wasn't aware of it's function of making sure you're clear on your variables.
That's a handy tip to know, I really appreciate it.


Thanks ever so much for your help.
Legendary status confirmed!

Kind regards
Marhier

 

[Marhier]

I was trying to avoid the temp image in the user's environment, in case of resctricitons in creating files in certain locations set by the IT team of the company I work at.
Fortunately, it doesn't seem there is that restriction....... Currently.

 

[John_w]

You're an absolute star, that worked a treat!

It gave me a 'Compile Error: Argument not optional' when using:

Set filteredCells = dataCells.CurrentRegion.Resize(, 16).SpecialCells(xlVisible)

I amended it to:

Set filteredCells = dataSheet.Range("A8:P1008")

Seems to make it run perfectly after that

Thanks for your feedback and I'm pleased that it works.

I don't know why you get that Compile Error. With your amendment I get 1000 rows in the temporary sheet and all of them are pasted into the email.

If you want to avoid the user's temp folder, replace:

    tempCellsFile = Environ("temp") & "\" & cellsImage

with:

    tempCellsFile = ThisWorkbook.Path & "\" & cellsImage