• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA not sending email

Ronak Parekh

New Member
I have following VBA scrip which is creating the email body but not hitting the send button. Thus once the email body is created I have to manually hit the send button. Is there a way to automate the send button as well?

>>> use code - tags <<<
Code:
Sub Mail_Selection_Range_Outlook_Body()
  Dim rng As Range
  Dim OutApp As Object
  Dim OutMail As Object
  Dim StrBody As String

  Set rng = Nothing
  On Error Resume Next
  Set rng = Sheets("Summary").Range("A3:G42")
  On Error GoTo 0

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

  StrBody = "<p style='font-family:Calibri;font-size:16'>Hi " & Sheets("Misc").Range("A98").Value & "," & "<br><br>" & _
  "<p style='font-family:Calibri;font-size:16'>Please find below Timeliness & Accuracy details as on " & Format(Date, "mm-dd-yyyy")
  On Error Resume Next
  With OutMail
  .Display
  .To = Sheets("Misc").Range("A99").Value
    .Subject = "Timeliness Update" & Format(Date, "mm-dd-yyyy")
  .HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & .HTMLBody
  .Display  'or use .Display
  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"

  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
 
Last edited by a moderator:
Back
Top