Auto Mailer Macro

[Jaisam]

HI I want a macro to send a mail from outlook. Body for the message rage is Sheet1(C13:E19,C22:F62,C65:G84),send To sheet2(M16), CC is sheet5(A2), BCC is Sheet4(E2) Subject for the mail is sheet3(K19). Please help me to create macro for my request .....so that i can apply this macro in click event. Pls help

 

[CsJHUN]

Hi Jaisam!


This comes from Ron de Bruin I edited to your needs. (his site )
3 Functions to read the 3 different size range to html then put them into outlook mail. Put all (1 sub and 3 function) into one module, and set a button only for the sub.
Try this on a sample file.
I let Ron comment in the 2nd function if you need

Sub Mail_Selection_Range_Outlook_Body()    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object


    Set rng = Nothing
    On Error Resume Next
    
    On Error GoTo 0
    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 = Worksheets(2).Range("M16").Value
        .CC = Worksheets(5).Range("A2").Value
        .BCC = Worksheets(4).Range("E2").Value
        .Subject = Worksheets(3).Range("K19").Value
        .HTMLBody = rng & vbnewline & rng2 & vbnewline & rng3 & vbnewline
        .Attachments.Add ActiveWorkbook.FullName   'If you dont want to add the workbook just remove this line
        .Display   'or use .Send if you want to send without checking it before 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"
    Set rng = ThisWorkbook.Worksheets(1).Range("C13:E19")
    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
    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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function


Function Range2toHTML(rng2 As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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"
    Set rng2 = ThisWorkbook.Worksheets(1).Range("C22:F62")
    'Copy the range and create a new workbook to past the data in
    rng2.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)
    Range2toHTML = ts.readall
    ts.Close
    Range2toHTML = Replace(Range2toHTML, "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
Function Range3toHTML(rng3 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"
    Set rng3 = ThisWorkbook.Worksheets(1).Range("C65:G84")
    rng3.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
    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
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    Range3toHTML = ts.readall
    ts.Close
    Range3toHTML = Replace(Range3toHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[Jaisam]

Hi CsJHUN, Thanks a lots for your help and its working fine for me ... one more help i need from you. How i can select the chart in the excel sheet as a another body of the mail. can you please give a additional function to select the chart as a body ... Thank you !!!!

 

[CsJHUN]

Hi, sorry for not responding sooner, i'm trying to achieve it.
Current status: i (the macro) can attach the file to the e-mail. Not giving up on this.

 

[CsJHUN]

Figured out:

Sub Mail_Selection_Range_Outlook_Body()    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Set rng = Nothing
    On Error Resume Next
    
    On Error GoTo 0
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    

[COLOR=#ff0000]chartname= Environ("userprofile") & "\desktop" & "[B]\exportedchart.gif"[/B][/COLOR]
[COLOR=#ff0000]ActiveSheet.ChartObjects([B]"diagram 1"[/B]).Chart.Export Filename:=charname, FilterName:="GIF"[/COLOR]
    On Error Resume Next
    With OutMail
[COLOR=#ff0000]       .Attachments.add chartname[/COLOR]
        .to = Worksheets(2).Range("M16").Value
        .CC = Worksheets(5).Range("A2").Value
        .BCC = Worksheets(4).Range("E2").Value
        .Subject = Worksheets(3).Range("K19").Value
        .HTMLBody = rng & vbnewline & rng2 & vbnewline & rng3 & vbnewline & [COLOR=#ff0000]"[[img src='cid:[B]exportedchart.gif' height=597 width=800[/B]]]"[/COLOR]
        .Attachments.Add ActiveWorkbook.FullName   'If you dont want to add the workbook just remove this line
        .Display   'or use .Send if you want to send without checking it before send
    End With
    On Error GoTo 0
[COLOR=#ff0000]kill chartname[/COLOR]
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

please change the [[ and ]] to < and > thanks
This is the mail creating macro, you must not change the other functions.
The red part is added. The bold part has to be change as you need.
Also if you want you can change the [activesheet] to [Sheets("sheetname")].

 

[Jaisam]

its not working i am getting error in this line Sheets("LTS Details").ChartObjects("Chart 9").Chart.Export Filename:=charname, FilterName:="GIF". and also i am not sure what i have to change instant of exportedchart.gif". i want to add the chart which is have in Sheets("LTS Details") and chart should be added in to the body of the mail not as a attachment . please help

 

[CsJHUN]

Sorry typo on that line

This has to work:

Sheets("LTS Details").ChartObjects("Chart 9").Chart.Export Filename:=char[B][COLOR=#ff0000]t[/COLOR][/B]name, FilterName:="GIF"

I tried that code, and the attached chart was in the body only. But you have to attach every image you want to shown in the mail body.
You don't need to change the exportedchart.gif, it's optional this file will be created on the desktop and will be deleted after the mail is composed.

 

[Jaisam]

Working fine thanks a lot my friend