Excel macro to send mail automatically

Excel  macro to send mail automatically

Summary :
This is example of macro which helps to send mail automatically with attachment of entire Workbook and pasting one particular sheet in the mail body.

 Function RangetoHTML(rng As Range)  
 ' Changed by Ron de Bruin 28-Oct-2006  
 ' Working in Office 2000-2010  
   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&quot ;)  
   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  
 Sub Mail_Selection_Outlook_Body()  
 ' Don't forget to copy the function RangetoHTML in the module.  
 ' Working in Office 2000-2010  
   Dim rng As Range  
   Dim OutApp As Object  
   Dim OutMail As Object  
   With Application  
     .EnableEvents = False  
     .ScreenUpdating = False  
   End With  
   Set rng = Nothing  
   On Error Resume Next  
   Set rng = ActiveSheet.Range("A2:AM55") 'Selection.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  
   Set OutApp = CreateObject("Outlook.Application")  
   Set OutMail = OutApp.CreateItem(0)  
   On Error Resume Next  
   With OutMail  
     .To = " email@removed "  
     .CC = " email@removed "  
     .BCC = " email@removed "  
     .Introduction = "TEST - " & Format(Date, "04-03-2010")  
     .Subject = "Zonal Review"  
     .HTMLBody = RangetoHTML(rng)  
     .Attachments.Add ActiveWorkbook.FullName  
     .Send  
   End With  
   On Error GoTo 0  
   With Application  
     .EnableEvents = True  
     .ScreenUpdating = True  
   End With  
   Set OutMail = Nothing  
   Set OutApp = Nothing  
 End Sub