send xls to email

[wmtsub]

I had been using a macro from Ron Debruin to do this but lately it ran real slow. So I found online another macro, trimmed it and added some of Ron's to it. It runs very fast. But the issue is the data it sends to outlook seems to start mid page and goes right. I can not seem to get it to line up at the left of the page. Any one got any ide why?
ths.
-Eds




Sub EmailSendSelectedCells_inOutlookEmail()
'Copy the selection
Set objSelection = Range("A1:Z" & Cells.SpecialCells(xlCellTypeLastCell).Row).SpecialCells(xlCellTypeVisible)
objSelection.Copy
'Paste the copied selected ranges into a temp worksheet
Set objTempWorkbook = Excel.Application.Workbooks.Add(1)
Set objTempWorksheet = objTempWorkbook.Sheets(1)
'Keep the values, column widths and formats in pasting
With objTempWorksheet.Cells(1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
End With
'Save the temp worksheet as a HTML file
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
strTempHTMLFile = objFileSystem.GetSpecialFolder(2).Path & "\Temp for Excel" & Format(Now, "YYYY-MM-DD hh-mm-ss") & ".htm"
Set objTempHTMLFile = objTempWorkbook.PublishObjects.Add(xlSourceRange, strTempHTMLFile, objTempWorksheet.Name, objTempWorksheet.UsedRange.Address)
objTempHTMLFile.Publish (True)
'Create a new email
Set objOutlookApp = CreateObject("Outlook.Application")
Set objNewEmail = objOutlookApp.CreateItem(olMailItem)
'Read the HTML file data and insert into the email body
Set objTextStream = objFileSystem.OpenTextFile(strTempHTMLFile)
objNewEmail.HTMLBody = objTextStream.readall
objNewEmail.Display
'****************************************************************************************
'Specify email recipients, subjects ; etc, Here
'objNewEmail.To = "johnsmith@"
'objNewEmail.Cc = "carboncopy"
'objNewEmail.Subject = "DataNumen Products"
'objNewEmail.Send '--> directly send out this email
'****************************************************************************************
objTextStream.Close
objTempWorkbook.Close (False)
objFileSystem.DeleteFile (strTempHTMLFile)
End Sub

 

[ZVI]

Hi,
Instead of this code line:

  objNewEmail.HTMLBody = objTextStream.readall

try using of that one:

  objNewEmail.HTMLBody = Replace(objTextStream.readall, "align=center x:publishsource=", "align=left x:publishsource=")

Also mail creation can be done faster in the already open instance of the Outlook by this part of the code:

  'Create a new email
  On Error Resume Next
  Set objOutlookApp = GetObject( , "Outlook.Application")
  If Err Then Set objOutlookApp = CreateObject("Outlook.Application")
  On Error GoTo 0

Regards

 

[wmtsub]

Thank you,
This fixed the alignment issue:

objNewEmail.HTMLBody = Replace(objTextStream.readall, "align=center xublishsource=", "align=left xublishsource=")


I tried the other code and it gave me an error.
​

 

[wmtsub]

ZVI,
If you're still watching this thread I have two more things I am having issues with

or if anyone else can helo I wouold appreciate it.​

1] I can not get it to Send the email without my hitting the send button on each email.
2] I would like to ad four lines of text to the top of each email with a salutation.

I tried to add it tto the spreadsheet manually but some how it messes up the output.

or if anyone else can help I wouold appreciate it.


Also if you can explain where this would go --- faster is always better.

thanks -Eds

 

[ZVI]

Hi,
Try this code:

Sub SendVisibleCells_inOutlookEmail()
' ZVI:2018-11-03 https://www.mrexcel.com/forum/excel-questions/1074013-send-xls-email.html#post5170781
 
  Dim objOutlookApp As Object
  Dim IsOutlookCreated As Boolean
  Dim sHtmlHeader As String, sSignature As String
  Dim sText As String, sTempHTMLFile As String
 
  ' Create top lines of the email body
  sHtmlHeader = "Dear Customer," & vbLf & vbLf _
              & "Your order for the products listed in this table is accepted" & vbLf
  sHtmlHeader = Replace(sHtmlHeader, vbLf, Chr(60) & "br" & Chr(62))
   
  'Copy visible range only
  ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy
 
  ' Get HTML data
  sTempHTMLFile = Environ("Temp") & "\Temp_for_Excel" & Format(Now, "YYYYMMDD_hhmmssms") & ".htm"
  With Workbooks.Add(xlWBATWorksheet)
    ' Paste data special
    With .Sheets(1).Cells(1)
      .PasteSpecial xlPasteValues
      .PasteSpecial xlPasteColumnWidths
      .PasteSpecial xlPasteFormats
    End With
    Application.CutCopyMode = False
    ' Publish HTML file data
    With .PublishObjects.Add(xlSourceRange, sTempHTMLFile, .Sheets(1).Name, .Sheets(1).UsedRange.Address, xlHtmlStatic)
      .Publish True
    End With
    ' Read the HTML file data
    sText = CreateObject("Scripting.FileSystemObject").OpenTextFile(sTempHTMLFile).ReadAll
    ' Close the created aux workbook
    .Close False
    ' Kill the HTML file
    Kill sTempHTMLFile
  End With
 
  ' Create a new email, fill it and send
  On Error Resume Next
  Set objOutlookApp = GetObject(, "Outlook.Application")
  If Err Then
    Set objOutlookApp = CreateObject("Outlook.Application")
    IsOutlookCreated = True
  End If
  On Error GoTo 0
  With objOutlookApp.CreateItem(0)
    ' Set HTML format
    .BodyFormat = 2
    ' Get default email signature without blinking (instead of .Display method)
    With .GetInspector: End With
    sSignature = .HtmlBody
    ' Concatenate all parts for HtmlBody
    sText = sHtmlHeader & sText & sSignature
    ' Apply left aligning
    sText = Replace(sText, "align=center x:publishsource=", "align=left x:publishsource=")
    ' Insert sText into HtmlBody
    .HtmlBody = sText
    'Specify email recipients, subject, etc:
    .To = "johnsmith@..."
    '.Cc = "carboncopy@..."
    .Subject = "DataNumen Products"
    .Send '<-- Directly send out this email, use .Display instead for the debugging only
  End With
 
  If IsOutlookCreated Then
    ' Close the created Outlook instance
    objOutlookApp.Quit
    Set objOutlookApp = Nothing
  End If
 
End Sub

Regards

 

[wmtsub]

Thank you very Much. I will try it soon.

 

[wmtsub]

This is awesome. It is actually faster than before.
Thanks you so much.

 

[ZVI]

This is awesome. It is actually faster than before.
Thanks you so much.

Glad it helped!

 

[wmtsub]

You may need to tell me to stop as I keep getting new ideas.... And i do not want to wear out my welcome.

But I have taken your email code an inserted into a macro that parses a worksheet into multiple worksheets based on the vendors name.
I intend to generate emails and populate the body with their pertinent lines of information. But I was wondering if I could set a threshold
so an email will only generate if there is x amount of lines on the spreadsheet. So one day I may email everyone with 10 or more rows of data and the next five or more. is this possible? I do not really want to email all the vendors all the time.

And is it possibleto specify what email account to send this thru? I have several on my PC.

 

[ZVI]

... set a threshold so an email will only generate if there is x amount of lines on the spreadsheet.

You may start with the below code which loops sheets in active workbook and if last row with data in the sheet is greater or equal to the defined threshold then that sheet is sending via the previous code.

Sub SendConditonally()
 
  Const SheetLinesGE = 10  ' <-- Change threshold to suit, GE means Greater or Equal
 
  Dim Sh As Worksheet, LastDataRow As Long
  For Each Sh In Worksheets
    LastDataRow = Sh.UsedRange.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                   SearchDirection:=xlPrevious, SearchFormat:=False).Row
    If LastDataRow >= SheetLinesGE Then
      Sh.Activate
      SendVisibleCells_inOutlookEmail
    End If
  Next
 
End Sub