Email individual worksheet as image in Body of text

[Samson92]

Hi,

I have a workbook that currently has two sheets, Master and Dash. The Master sheet is data collated from multiple sheets in a folder, then the Dash is a display of this data. The data corresponds to individual people, so what I want to do is create individual new sheets, named after each of them for a monthly summary, and place some info on, including their email address.

Email addresses will always be in the same location. What I want to do is cycle through the workbook, and any sheet that has an email in Cell B4 (basically every worksheet except Master and Dash), copy the cells on that sheet in Range B5:V10 and email it to that address as image in the body, and the subject is "{current month} Data". So if I have 25 names, it would be 25 separate emails with just their data.

Is this possible, and if so where to start?

Thanks

 

[Logit]

.
Everything email : https://www.rondebruin.nl/win/s1/outlook/mail.htm

 

[Samson92]

I've tried following that site already, and using the code along with some changes have been able to get the sheet range to copy to an email, but it doesn't copy a chart. That's why i'm trying to get it as an image, which is where i'm struggling, just making the range as an image is what I want.

 

[Logit]

.

Option Explicit
Sub sendmail()
   Dim OutApp       As Object
   Dim OutMail      As Object
   Dim SigString    As String
   Dim Signature, EmailTo, CCto, Subj, msg, Filepath As String
   Dim ws           As Worksheet
   Dim cel          As Range
   Dim LR           As Long
   Dim rng As Range
   
   Set ws = Sheets("MRM")
   Set rng = Sheets("Sheet1").Range("B4:J10")   '<-- Set the sheet and range to be copied into body of email.
   
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      If Not .AutoFilterMode Then
         .Range("A3:P3").AutoFilter
      End If
      .Range("A3:P" & LR).AutoFilter Field:=16, Criteria1:="<>"
      If .Range("P3:P" & LR).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
         For Each cel In .Range("P4:P" & LR).SpecialCells(xlCellTypeVisible)
            EmailTo = .Cells(cel.Row, "J").Value
            CCto = .Cells(cel.Row, "K").Value
            Subj = .Cells(cel.Row, "L").Value
            Filepath = .Cells(cel.Row, "M").Value
            msg = .Cells(cel.Row, "N").Value


            With Application
               .EnableEvents = False
               .ScreenUpdating = False
            End With
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)


            SigString = Environ("appdata") & _
                        "\Microsoft\Signatures\mrm.htm"


            If Dir(SigString) <> "" Then
               Signature = GetBoiler(SigString)
            Else
               Signature = ""
            End If
            On Error Resume Next
            With OutMail
               .To = EmailTo
               .CC = CCto
               .BCC = ""
               .Subject = Subj
               .HTMLBody = msg & "<br><br>" & "Please review the following : " & RangetoHTML(rng)
               '.body = msg & vbNewLine & vbNewLine & Signature
               ' .Attachments.Add Filepath 'Uncomment this Line if you've added attachments
               .Display   '.Send   'or use .Display
            End With
         Next cel
      End If
      .AutoFilterMode = False
   End With


   On Error GoTo 0
   Set OutMail = Nothing
   Set OutApp = Nothing


   With Application
      .EnableEvents = True
      .ScreenUpdating = True
   End With
End Sub


Function GetBoiler(ByVal sFile As String) As String
   '**** Kusleika
   Dim fso          As Object
   Dim ts           As Object
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
   GetBoiler = ts.ReadAll
   ts.Close
End Function


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

Download : https://www.amazon.com/clouddrive/share/cSEVIjqIn9Pt0aRlZwD8xXMM5AGaiSYRRVNvvfzJ2ic

 

[Samson92]

Thank you for suggesting this, but it's not exactly what i'm looking for. I'll post tomorrow what I have so far, and see if it's possible to amend it to get the final results. Appreciate you helping.

 

[Samson92]

What I have now is the following;

Sub Outlook_Mail_Every_Worksheet_Body()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet




    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    Set OutApp = CreateObject("Outlook.Application")


    For Each ws In ActiveWorkbook.Worksheets
        If ws.Range("A1").Value Like "?*@?*.?*" Then
            Dim r As Range
            Set r = Range("B4:J10")
            r.Copy
            Dim p As Picture
            Set p = ActiveSheet.Pictures.Paste
            p.Cut
            
            Set OutMail = OutApp.CreateItem(0)
            OutMail.Display
            Dim wordDoc As Object
            Set wordDoc = OutMail.GetInspector.WordEditor


            On Error Resume Next
            With OutMail
                .To = ws.Range("A1").Value
                .CC = ""
                .BCC = ""
                .Subject = "Your data as of" & VBA.Format(Now, " dd-mm-yyyy")
                .HTMLBody =
                            wordDoc.Range.Paste
                .Send
            End With
            On Error GoTo 0


            Set OutMail = Nothing
        End If
    Next ws


    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

This works to an extent. When I run the code from a button on the main sheet, it goes through each sheet and if there's an email in cell A1, it just copies the range from the front sheet, and does that each time. So say I have 6 sheets with an email out of everything, it will copy the sheet it was run from 6 times, but send it to the email on those sheets. I need it to copy the data from the sheet with the email. What am I missing? Thanks.

 

[Domenic]

You need to qualify your range reference...

[COLOR=#333333]Set r = ws.Range("B4:J10")[/COLOR]

 

[Samson92]

I had that in originally, and assumed it was something I hadn't changed throughout. Stupid little mistake I overlooked. thank you.

 

[Logit]

.
The following works here :

Sub Outlook_Mail_Every_Worksheet_Body()
Dim ws As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim vInspector, GetInspector, wEditor As Variant




For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Sheet1" Then
            If ws.Range("A1").Value Like "?*@?*.?*" Then
                ws.Range("B4:J10").Copy
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = ws.Range("A1").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = "Your data as of" & VBA.Format(Now, " dd-mm-yyyy")
                    .Body = ""
                    .Display
                    ws.Range("B4:J10").Copy
                    Set vInspector = OutMail.GetInspector
                    Set wEditor = vInspector.WordEditor
                
                    wEditor.Application.Selection.Start = Len(.Body)
                    wEditor.Application.Selection.End = wEditor.Application.Selection.Start
                
                    wEditor.Application.Selection.Paste
                
                .Display
                End With
            End If
        End If
Next ws
End Sub