GENERATE EMAIL W/ RANGE OF DATA IN BODY (user will select diff range for each email)

[JuicyMusic]

Hello everyone, I have a code that generates emails based on email addresses of recipients in Col A - and CC: in Col A - and BCC: in Col C.

This code uses two text boxes: 1) Text box for the email header........ 2) Text box for the email body. This code works great - but I need to adjust it to work on a different spreadsheet.

HERE IS WHAT I NEED
I need to see how to adjust this code so that whatever the range of cells that the user will be selecting - on any selected sheet - will be pasted into the body of the generated email.
The range will always vary - from 1 to 15 columns - from 2 to 50 rows. This may not always be the case and this is why I'm asking for "selected range" - with all formatting to come across as well.
No text boxes for this one.

I hope the code below is helpful to you. I can't use XL2BB here at work - so I'll insert a snippet of an example range. I don't think you need that but I'll add anyways. I selected a range on the snippet so you can see columns and rows will vary. Thank you so much!.....I am "CG" in the code below.

Option Explicit

Sub EMAIL_Send_to_DistributionList()


    Dim OutlookApp As Object
    Dim MItem As Object
    Dim cell As Range
    Dim email_ As String
    Dim cc_ As String, bcc_ As String
    'CG deactivated the 3rd and 4th "As String" of the line of code above.  Not needed because 2 TextBoxes were used instead.  See last section of this code.
    'subject_ As String, body_ As String
 
  'CG added this section of code to create a error message box
If WorksheetFunction.CountA(Range("A2:A350")) = 0 Then
    MsgBox "Please enter a minimum of one email address in Column A.", vbCritical, "Missing Email Address"
        Exit Sub
    End If
 
 'CG added this section of code to create a Yes/No Message Box
 Dim answer As Variant
    answer = MsgBox("Are you ready to generate your email?", vbYesNo + vbQuestion, "KGC_Email Distribution List")
    If answer = vbNo Then
        Exit Sub
    End If
   

     'Create Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")

     'Loop through the rows
    For Each cell In Range("A2:A350").Cells.SpecialCells(xlCellTypeConstants)

        email_ = cell.Value
        cc_ = cell.Offset(0, 1).Value
        bcc_ = cell.Offset(0, 2)
        'CG deactivated the next two lines of code and used TexBoxes instead
       ' subject_ = cell.Offset(0, 3)
       ' body_ = cell.Offset(0, 4)

        'Create Mail Item and send it
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = email_
            .CC = cc_
            .BCC = bcc_
            'CG changed the following line of code to recognize the 2nd TextBox
            .Subject = ActiveSheet.TextBoxes(2).Text
            'CG changed the following line of code to recognize the 1st TextBox
            .Body = ActiveSheet.TextBoxes(1).Text
            'CG changed the following line of code from .Send to .Display temporarily
            .Display
        End With
    Next
End Sub

 

[johnnyL]

See if you can use any or all of the following:

Sub RangeSelectExample()
'
    Dim RowCounter          As Long
    Dim ColumnCounter       As Long
    Dim UserSelectedRange   As Range
    Dim AddressString       As String
    Dim EmailBodyString     As String
'
    AddressString = ActiveWindow.RangeSelection.Address                 ' The user can highlight the range they want before hand ;)
'
'   Have the user confirm the selection, or change it if desired
    Set UserSelectedRange = Application.InputBox(Prompt:="Please select the range that you want to paste into email body. Ex. $B$2:$K$20", Title:="Email body Range Selector", Default:=AddressString, Type:=8)
'
    On Error Resume Next                            ' If user cancels, it will produce an error so bypass the error and exit sub in the next line
    If UserSelectedRange Is Nothing Then Exit Sub
    On Error GoTo 0                                 ' Turn off the error bypassing code
'
    For RowCounter = 1 To UserSelectedRange.Rows.Count
        For ColumnCounter = 1 To UserSelectedRange.Columns.Count
            EmailBodyString = EmailBodyString & "  " & UserSelectedRange.Cells(RowCounter, ColumnCounter).Value
        Next
    Next
End Sub

The first part asks for the range, it will automatically import the range that is currently selected.
The last part appends the range of cells to a string variable.

It won't have the formatting that you asked for.

Another route, you could utilize the selected range and then use code to create a picture ( a Screenshot basically ) of that range if that is acceptable.

 

[JuicyMusic]

Hi JohnnyL, thank you for these sections. I'm going to read thru and see what works right now and let you know.

I want to add the a "snapshot" would be acceptable. So far I have been using Snippet to take a picture. I follow up.

 

[johnnyL]

This is some code to select a range and then make a picture of it:

Sub RangeSelectExample2()
'
    Dim RowCounter              As Long
    Dim ColumnCounter           As Long
    Dim UserSelectedRange       As Range
    Dim AddressString           As String
    Dim EmailBodyString         As String
    Dim PictureFileName         As String
    Dim TempFilePath            As String
    Dim EmailBodyPictureList    As String
    Dim ws                      As Worksheet
'
    AddressString = ActiveWindow.RangeSelection.Address                 ' The user can highlight the range they want before hand ;)
'
'   Have the user confirm the selection, or change it if desired
    Set UserSelectedRange = Application.InputBox(Prompt:="Please select the range that you want to paste into email body. Ex. $B$2:$K$20", Title:="Email body Range Selector", Default:=AddressString, Type:=8)
'
    Set ws = Application.ActiveSheet
'
    On Error Resume Next                            ' If user cancels, it will produce an error so bypass the error and exit sub in the next line
    If UserSelectedRange Is Nothing Then Exit Sub
    On Error GoTo 0                                 ' Turn off the error bypassing code
'
''    For RowCounter = 1 To UserSelectedRange.Rows.Count
''        For ColumnCounter = 1 To UserSelectedRange.Columns.Count
''            EmailBodyString = EmailBodyString & "  " & UserSelectedRange.Cells(RowCounter, ColumnCounter).Value
''        Next
''    Next
'
    TempFilePath = Environ("USERPROFILE") & "\Desktop\EmailBodyPicture\"
    If Len(VBA.Dir(TempFilePath, vbDirectory)) = False Then VBA.MkDir TempFilePath
'
        If UserSelectedRange.Cells.Count > 1 Then Call CreateRangeJPG(ws.Name, UserSelectedRange.Address, "PictureOfRange" & VBA.Trim(VBA.Str(ws.Index)))

    EmailBodyPictureList = ""
    PictureFileName = Dir(TempFilePath & "*.*")
    Do While PictureFileName <> ""
        EmailBodyPictureList = EmailBodyPictureList + VBA.vbCrLf + "<img src='cid:" + PictureFileName + "'><br>"
        PictureFileName = Dir
        If PictureFileName = "" Then Exit Do
    Loop
'
'
'
'   At this point you can place 'EmailBodyPictureList' in the body of the email
'
'
'
'   Uncomment the next line and place it somewhere after the email has been sent code if you want to delete the picture of the range
'    If VBA.Dir(TempFilePath & "*.*") <> "" Then VBA.Kill TempFilePath & "*.*"           ' Delete Picture(s) from folder

End Sub

Sub CreateRangeJPG(SheetName As String, RangeAddrss As String, PictureFileName As String)
'
    Dim PictureRange As Range
'
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set PictureRange = ThisWorkbook.Worksheets(SheetName).Range(RangeAddrss)
    PictureRange.CopyPicture
'
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ("USERPROFILE") & "\Desktop\EmailBodyPicture\" & PictureFileName & ".jpg", "JPG"
    End With
'
    Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
'
    Set PictureRange = Nothing
End Sub

The picture will be saved to the desktop in a folder called 'EmailBodyPicture'

 

[JuicyMusic]

Hello Johnny, Your code has a VBA.MkDir TempFilePath line in it. I did create a folder on my Desktop called EmailBodyPicture but it gave me a Debug for this line:
VBA.MkDir TempFilePath

I actually found this code. I am adding and modifying it though. It's slow going but so far so good. Here it is in case you want to see it.
Even though I'm showing you my code, could you explain to me what else I should have done so that your code would not fail? Thanks

Sub SendEMail_SELECT_RANGE()
    Dim TempFilePath As String
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xHTMLBody As String
    Dim xRg As Range
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the data range:", "Purple Green Astral Body", Selection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set xOutApp = CreateObject("outlook.application")
    Set xOutMail = xOutApp.CreateItem(olMailItem)
    Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
    TempFilePath = Environ$("temp") & "\"
    xHTMLBody = "<span LANG=EN>" _
            & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
            & "Hello, INSERT PARAGRAPH THAT YOU WANT HERE:<br> " _
            & "<br>" _
            & "<img src='cid:DashboardFile.jpg'>" _
            & "<br>Have a nice day!</font></span>"
    With xOutMail
        .Subject = ""
            .Subject = "Safety Compliance Check for Month: " & "" & Range("F2").Value
        .HTMLBody = xHTMLBody
      .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
        .To = " "
        .Cc = "safety@sirius.com"
        .Display
    End With
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
    Dim xRgPic As Range
    Dim xShape As Shape
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        For Each xShape In ActiveSheet.Shapes
            xShape.Line.Visible = msoFalse
        Next
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
   Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

I wanted to add that it won't be necessary to save a picture of the "snapshot" because the spreadsheet that the selected range comes from will be a saved file. There might be as much as 50 snapshots made each month .....but this might be a good one for another spreadsheet I update. Thank you. I'll wait for your reply re my code.

 

[johnnyL]

Hello Johnny, Your code has a VBA.MkDir TempFilePath line in it. I did create a folder on my Desktop called EmailBodyPicture but it gave me a Debug for this line:
VBA.MkDir TempFilePath

That part of the code looks for the folder, if it doesn't exist it creates it. You don't need to create it yourself, the code does it for you, that is what the mkdir does. It stands for 'make directory'.

 

[JuicyMusic]

Hmmmm....I don't think I want a code that's going to create a folder....BUT I do like the fact that it will save a picture in a folder that I created. I like it for another spreadsheet.
Anyways, if that's the case...then why did it fail? I created the folder first - then ran the code - and it failed. Let me know.


FYI - I went to this Microsoft link to see what that line was doing. I'm sure you already know about this..

MkDir statement (VBA)

Office VBA reference topic

docs.microsoft.com

 

[johnnyL]

If the following line gives you an error for some reason:

    If Len(VBA.Dir(TempFilePath, vbDirectory)) = False Then VBA.MkDir TempFilePath

You can just comment it out or delete it if you already made the folder called 'EmailBodyPicture' on the desktop.
Like I said, that line of code checks to see if the folder exists, if it doesn't, it creates it.

Not sure what error you may be seeing, but you can try the line without the VBA. parts

    If Len(Dir(TempFilePath, vbDirectory)) = False Then MkDir TempFilePath

 

[JuicyMusic]

It was a Debug and it highlighted this row yellow: VBA.MkDir TempFilePath

Thank you. I'll keep the code and comment it out. Good idea. Thank you. SOLVED