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

 

[wmtsub]

That is just awesome.

One last tweak please. My macro sets the font to arial [10] in excel and fits the colums. But the verssion [html ?] pasted to outlook is changing in to segoe [11] and it is messign my formatting. I do not mind the larger print but I would need to auto fit the column's and of course the original font / size is ok to.

How should I overcome this? What path is easier?​

 

[ZVI]

My macro sets the font to arial [10] in excel and fits the colums. But the verssion [html ?] pasted to outlook is changing in to segoe [11] and it is messign my formatting.

Can't reproduse that behavior. I've formated (font & size) cells individually and their formats are the same as in the Excel sheet.
Apply .Display instead of .Send and check font(s) in Outlook email.

 

[wmtsub]

I did as requested, results the same. Excel is formated at Arial 10, outlook is formated as Arial 10 and the pasted date is segoe 12. Cant figure why.
Got a work around, I am reformatting excel to segoe 12.

Any chance you can tell me how I would specify to email thru a differnet account other than the default email address?

 

[ZVI]

Any chance you can tell me how I would specify to email thru a different account other than the default email address?

Last+ tweak?
Define smtp address of the mailbox to send from in the Const MySmtpAddress on the top of the code

Sub SendVisibleCells_inOutlookEmail()
' ZVI:2018-11-08 https://www.mrexcel.com/forum/excel-questions/1074013-send-xls-email.html#post5170781
 
  ' User setting, change to suit
  Const MySmtpAddress = "My.SmtpAddress@send.from" ' <-- The smtp address to send from
 
  Dim objOutlookApp As Object, objAccount 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
  Application.CutCopyMode = False
  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
 
  ' Get/Create an Outlook instance
  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
 
  ' Use mailbox defined by SmtpAddress
  For Each objAccount In objOutlookApp.Session.Accounts
    If LCase(objAccount.SmtpAddress) = LCase(MySmtpAddress) Then Exit For
  Next
  If objAccount Is Nothing Then
    MsgBox "Account " & MySmtpAddress & " not found." & vbLf _
         & "The default account will be used", _
         vbExclamation, "Warning:"
  End If
 
  ' Create a new email, fill it and send
  With objOutlookApp.CreateItem(0)
    ' Use the defined mailbox if found
    If Not objAccount Is Nothing Then .SendUsingAccount = objAccount
    ' 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
 
  ' Prevent memory leakage
  Set objAccount = Nothing
 
  ' Quit Outlook instance if it was created by this code
  If IsOutlookCreated Then
    objOutlookApp.Quit
    Set objOutlookApp = Nothing
  End If
 
End Sub

Regards

 

[wmtsub]

I seem to be having an issue with this addition. I think it may be because the email account is not actually n account but rather an alias created by my IT dept.
IS we revert back to the thast rendition of this script can I we force somehing like

SendithAccount = "Account.com"?​

 

[ZVI]

Well, then
1. Do you able to logon manually to that different account and send email from it to yourself?
2. If so, then just do right click on address of the received email to see smtp address of that account and use it in the previous code.
Actually you may send email from the default account on behalf of smtp address of your another installed account by inserting .SentOnBehalfOfName = MySmtpAddress before the line with .Send - find it commented in the below code.

And yes it is possible to use name of the account in the code instead of the smtp address, like this:

Sub SendVisibleCells_inOutlookEmail()
' ZVI:2018-11-09 https://www.mrexcel.com/forum/excel-questions/1074013-send-xls-email.html#post5170781
 
  ' User setting, change to suit
  Const AccountName = "Account.com" ' <-- Name of the account
 
  Dim objOutlookApp As Object, objAccount 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
  Application.CutCopyMode = False
  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
 
  ' Get/Create an Outlook instance
  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
 
  ' Use mailbox defined by SmtpAddress
  For Each objAccount In objOutlookApp.Session.Accounts
    If LCase(objAccount.DisplayName) = LCase(AccountName) Then Exit For
  Next
  If objAccount Is Nothing Then
    MsgBox "Account " & AccountName & " not found." & vbLf _
         & "The default account will be used", _
         vbExclamation, "Warning:"
  End If
 
  ' Create a new email, fill it and send
  With objOutlookApp.CreateItem(0)
    ' Use the defined mailbox if found
    If Not objAccount Is Nothing Then .SendUsingAccount = objAccount
    ' Set HTML format
    .BodyFormat = 2
    ' Get default email signature without blinking (instead of .Display method)
    With .GetInspector: End With
    sSignature = .HtmlBody
    ' Apply left aligning
    sText = Replace(sText, "align=center x:publishsource=", "align=left x:publishsource=")
    ' Concatenate all parts for HtmlBody
    sText = sHtmlHeader & sText & sSignature
    ' Insert sText into HtmlBody
    .HtmlBody = sText
    'Specify email recipients, subject, etc:
    .To = "johnsmith@..."
    '.Cc = "carboncopy@..."
    .Subject = "DataNumen Products"
    '.SentOnBehalfOfName = "behalf@..."
    .Send '<-- Directly send out this email, use .Display instead for the debugging only
  End With
 
  ' Prevent memory leakage
  Set objAccount = Nothing
 
  ' Quit Outlook instance if it was created by this code
  If IsOutlookCreated Then
    objOutlookApp.Quit
    Set objOutlookApp = Nothing
  End If
 
End Sub

Regards

 

[wmtsub]

The email account is not set up in my outlook installation as an account. however when I send an email I can pull the that down on the send from email addresses and have access to it there. Also when retrieving emails it does so under the account. Also I would like to integrate the signature into another macro. Can you supply just the specific code for taht for me to play with please?

 

[wmtsub]

PS. Also for some reason I have not been able to figure out why the format and fonts are being changed. the version just before did work fine but this one does not.

 

[wmtsub]

ZVI, I am fustrated. I love your code but can't get it right. I still can not get the format to stop changing on the second version. And I have not yet goten the email accoutn to change. I trimmed the code down to bare essentials to test the email account change [below]. the message box IS displaying the correct account info but it will not pull up / populate the from email field at all. It always reverts back to the default. I guess I can live with the formatting not exactly as I would like it but this is critical. Can you please help?




' User setting, change to suit
objAccount = "test email @ ccc.com" ' <-- The smtp address to send from
' Create a new email, fill it and send
With objOutlookApp.CreateItem(0)
' Use the defined mailbox if found
MsgBox objAccount
.SendUsingAccount = objAccount
' Get default email signature without blinking (instead of .Display method)
With .GetInspector: End With
sSignature = .HtmlBody
.display
End With

 

[ZVI]

The email account is not set up in my outlook installation as an account. however when I send an email I can pull the that down on the send from email addresses and have access to it there. Also when retrieving emails it does so under the account.

Never faced with a such configuration. Have you tried .SentOnBehalfOfName = "your another address"?