VBA Excel - email with attachments and a screenshot/table in the body

[Accalio07]

Hi everyone,

I'm an apprentice in Finance. My manager needs to automate the email process.
What I'm asked to do:
- Generate emails personalised to each receiver (DONE)
- Attach the adequate file to each mail (DONE)
- A table/screenshot of the most important financial KPI in the email body (Don't know how to)

I have 2 ideas but don't know how to code them

1 - Make VBA search in the files attached the KPI (turnover/margin and EBITDA) and take a screen and project it in the mail body for each mail
2 - Create a table in Excel with changeable values of all the agencies using functions and VBA only takes a screen or the table itself of the concerned agencies and send them to the right people

(In my Excel Sheet, there are the names of the destinator, their emails, the message of the mail and the link to the attachment)

THANK YOU SO MUCH ! I really need any help I can get

Here is the code so far:

Sub Send_Files()

Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range

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

Set sh = Sheets("ESSAI 2")

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)

With OutMail
.Display
.To = cell.Value
.Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
.HTMLBody = "Bonjour " & cell.Offset(0, -1).Value & "," & "<p>" & "<\p>" & Range("B15") & " " & Range("C15") & " " & Range("D15") & "<p>" & Range("B16") & "<p>" & "<\p>" & Range("B17") & .HTMLBody

For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell

End With

Set OutMail = Nothing
End If
Next cell

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


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

 

[Micron]

I'm thinking that this is what you need and that this part (rng.CopyPicture) is how you'd copy your KPI data.

Copy Excel range as Picture to Outlook

How can I use the command "Paste Special - As Picture" that you access in Excel from the right-click menu? I have viewed various posts, but they seem to be outdated when using Excel 2016. It seems...

stackoverflow.com

Please use code tags (vba button on posting toolbar) to maintain code indentation and readability.

 

[Accalio07]

Hey, thank you for your answer. I've been able to copy a range as a picture in the body mail but still I have an issue, the picture in the code is from a random range in the excel I'm working on, however I want to capture the range from the files attached to the email (different file for each email) (Column B).
Do you have an idea how I can do that ?
Here's my code :

Sub Send_Files()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim MakeJPG As String

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

    Set sh = Sheets("Sheet1")
      

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
        
        MakeJPG = CopyRangeToJPG("Sheet1", "B15:C17")
        
    If MakeJPG = "" Then
        MsgBox "Something go wrong, we can't create the mail"
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
        Exit Sub
    End If
    
    On Error Resume Next
        

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
            .Display
                .To = cell.Value
                .Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
                .Attachments.Add MakeJPG, 1, 0
                .HTMLBody = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/>" & "<br/>" & Range("B15") & " " & Range("C15") & " " & Range("D15") & "<p>" & Range("B16") & "<p>" & "<\p>" & "</p><img src=""cid:NamePicture.jpg"" width=200 height=50></html>" & Range("B17") & .HTMLBody
                
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

            End With

            Set OutMail = Nothing
        End If
    Next cell

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

Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
    'Ron de Bruin, 25-10-2019
    Dim PictureRange As Range

    With ActiveWorkbook
        On Error Resume Next
        .Worksheets(NameWorksheet).Activate
        Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
        
        If PictureRange Is Nothing Then
            MsgBox "Sorry this is not a correct range"
            On Error GoTo 0
            Exit Function
        End If
        
        PictureRange.CopyPicture
        With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
        End With
        .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
    End With
    
    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
    Set PictureRange = Nothing
End Function


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

Thank you !

 

[Micron]

Not understanding. Your ranges don't seem random at all; they seem to be hard coded.
Perhaps use an input box (type 8) to get the range you want?

 

[Accalio07]

Yes you're right, they're not random, I've taken the range "B15:C17" in the sheet where there is all the other information (emails, direction to the files (B), and body message). It was a test to see if I can have an image in the emails and it worked however it is the same image for all the destinators. What I have been asked to do is to capture the same range "B15:C17" but each time from a different file that is attached to the email.
I don't know if I made myself clear but for example, the files represent different regions:

File 1: "B15:B16" Turnover: 1,2 > Email 1
File 2: "B15:B16" Turnover: 4,5 > Email 2

I believe I have to do something on the loop like I did to attach different files to different emails but I keep bumping into error messages

Thanks

 

[Micron]

but each time from a different file that is attached to the email.

Clear as mud to me, but then I'm not overly smart. A different workbook? Different tab in the same workbook? The file is in the email? Something else?

 

[Accalio07]

   For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

I'm sure you're way smarter than I am This code attributes a unique file (Excel Sheets xlsx) to each email, the data source being in column B. I want the images to be captured from those files if it's any clearer :D

 

[Accalio07]

How the emails look, I want the image to be from the file in the email (notice that it's not the same excel in the two emails)

 

[Micron]

It would seem to me that what your code needs to do is open the file (hidden?) that is listed in the sheet column and grab the range image from that file>workbook>sheet and paste that image into the email then attach that file. Does that summarize what you are trying to do? If so, that seems too much for me - I'm not as adept at Excel vba as I am with Access & Access vba. If I've at least properly described the process, then perhaps someone knows what to do once they understand that process.

 

[Accalio07]

Yes it pretty much summarizes it. Thank you for being reactive and trying to solve the problem.
I could use a different approach but I don't know if it's possible and "easier".
If I have different ranges in the excel sheet I'm working on (ex: A1:B1; C1:D1; E1:F1) and I want to send an image per email but of different ranges depending on the recipient, is it possible ?
Email 1: A1:B1
Email 2: C1:D1
Email 3: E1:F1
Etc...

Thanks