VBA - Send Email including Range (Pasted as Picture) + Pivot table below
Results 1 to 2 of 2

Thread: VBA - Send Email including Range (Pasted as Picture) + Pivot table below
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Nov 2017
    Location
    Toronto, CAN
    Posts
    4
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default VBA - Send Email including Range (Pasted as Picture) + Pivot table below

    Hi,
    I was hoping that somebody could help me.

    I am working on a spreadsheet ("Email") including a first block (Range B2:G10)(used as introduction, with logo, pictures,..) . Below the block of introduction is located a Pivottable ("PivotAddress1"). The Pivot table starts on line B13:G13.

    I could find/modify the code in order to get the pivot table sent by email and would like now to add the block of introduction on top of the Pivot. ideally, I would like to get the block of intro (Range B2:G10) pasted as a picture, in order to keep the pictures, logos, displayed as they are on the spreadsheet.

    Here is the code that I have for the Pivot, for some reason, I can't seem to find the trick to include the picture of the block of intro on top:

    (As you will notice, I called twice the RangeToHTML function as I was capturing the block of intro already but the formatting + pictures are not carried so would like to switch to the pasting as a picture solution (Just for the Block), the Pivottable should remain the way it is.

    Code:
    Sub Mail_Selection_Range_Outlook_Body()
    
    
    'Working in Excel 2000-2016
        Dim rng As Range
        Dim OutApp As Object
        Dim OutMail As Object
    
    
      
    
    
        Set rng = Nothing
        On Error Resume Next
        'Only the visible cells in the selection
        
        Set PT = ActiveSheet.PivotTables(1) 'K: Will select the Pivot Table
        PT.TableRange1.Select               'K: Will select the Pivot Table
        'Set rng = Selection.SpecialCells(xlCellTypeVisible)
        
        Set rng = Sheets("Email").Range("B2:G10")
        rng2 = RangetoHTML(rng)
        
        Set rng = Sheets("Email").PivotTables("PivotAddress1").TableRange1
        rng3 = RangetoHTML(rng)
        
        
        'You can also use a fixed range if you want
        'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    
    
        If rng Is Nothing Then
            MsgBox "The selection is not a range or the sheet is protected" & _
                   vbNewLine & "please correct and try again.", vbOKOnly
            Exit Sub
        End If
    
    
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    
    
        On Error Resume Next
        With OutMail
            .To = "xx@xx.com"
            .CC = ""
            .BCC = ""
            .Subject = "Sddress updates Date: " & Format(Now, "YYYY/MM/DD")
            .HTMLBody = rng2 & "
    " & rng3
            .Display   'or use .Send
        End With
        On Error GoTo 0
    
    
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    
    
        Set OutMail = Nothing
        Set OutApp = 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 new workbook to past the data in
        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
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
    
        'Publish the sheet to a 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 RangetoHTML
        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 we used in this function
        Kill TempFile
    
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function
    Thank you for any help,

  2. #2
    New Member
    Join Date
    Nov 2017
    Location
    Toronto, CAN
    Posts
    4
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - Send Email including Range (Pasted as Picture) + Pivot table below

    Bump

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •