VBA Code for Email_For

[AbhishekJain]

Dear All,

I am looking for code, which copies the contents from Excel workings to the outlook, and probably display the email and not send. It’s a monthly activity where we let out clients know about their status, have to send these emails to multiple recipients (I am okay to fill in the email address manually), but I want to have the subject and body of the email from the excel.

Example subject of the email, I want to copy it from two cells A6:B6

And body of the email is a bit lengthy (basically texts) so I am trying to update it in the excel with formulas which are linked to the workings (which will have the period of the email, the payable amount , bank details) the code has to copy the body of the email from excel Sheet10 and data from row A37:U74.

This avoids a lot of errors we doing it manually updating the bank details every week.

Thanks in advance!

 

[AbhishekJain]

Dear All,

I am looking for code, which copies the contents from Excel workings to the outlook, and probably display the email and not send. It’s a monthly activity where we let out clients know about their status, have to send these emails to multiple recipients (I am okay to fill in the email address manually), but I want to have the subject and body of the email from the excel.

Example subject of the email, I want to copy it from two cells A6:B6

And body of the email is a bit lengthy (basically texts) so I am trying to update it in the excel with formulas which are linked to the workings (which will have the period of the email, the payable amount , bank details) the code has to copy the body of the email from excel Sheet10 and data from row A37:U74.

This avoids a lot of errors we doing it manually updating the bank details every week.

Thanks in advance!

Dear All,

I am still looking for help on the above, looking forward for responses.
Have a good day ahead!

Thanks

 

[Logit]

Option Explicit

Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
    ws1.Range("A1:M42").Copy     '------------------------------ Change range here
    Mail_Selection_Range_Outlook_Body
End Sub

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets("Sheet1").Range("A1:M42")     '--------------- Change range here
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Your Subject Here"

    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    '.Send
    .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"
    '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")
    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

 

[AbhishekJain]

Thanks for your reply, I tried it, unfortunately needs some tweaking.

For subject I am getting “Your Subject Here” as the result, guess its still picking values from here and not from the range I gave above.

And for the body of the email;

Its working, I am able to see the result on the email, but its copying only the first few words from each line.
Is it because its copying the contents from excel? I see before pasting on the outlook, the macro is creating a new excel and copying the content from there, may be its because of this? Also on the email its giving me the result in the form of a table, don’t know how it will be if it copies to a word document before moving to the outlook ?

 

[Logit]

Option Explicit


Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
    ws1.Range("A1:M42").Copy     '------------------------------ Change range here
    Mail_Selection_Range_Outlook_Body
End Sub

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets("Sheet1").Range("A1:M42")     '--------------- Change range here
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = Range("A6:B6")

'###########################################################################################
'<-- This is creating the BODY of the email. Edit these lines to create your own body info.
 
 .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
               RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
'###########################################################################################
 
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    '.Send
    .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"
    '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")
    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

Your initial request did not say anything about using WORD. Suggest you create the email first, then work with WORD.

 

[AbhishekJain]

Apologies for the delay in my response. I was dealing with some personal emergencies.
Currently, the email is displayed in the column format (I am talking about the paragraph starting "Please find enclosed the ***") is there a way I can get the this a bit different so it does not get limited to a column.
The table below with borders are good as they are separating the critical bank data.

 

[AbhishekJain]

Copied from the outlook

Dear ***,
Please find enclosed the *** for your review, If you agree with its content, please provide us with your formal approval by replying to this email. Upon receiving your written approval, we will submit the *** electronically to the *** Authorities.
Name	ABC Corporation
Payable/Receivable	1000 EUR
Period	August
Deadline
Bank details	The Tax should be paid to the following bank account
Recipient:	XYZ
IBAN:	US***********
BIC:	XXXXX
Amount:	1.000,00 USD
Reference:	20232458179	EA2405
Notes
We have noticed the following points:
We thank you in advance and remain at your disposal for any questions.
Kind regards,

 

[AbhishekJain]

Hello - Would this work if we copy and do paste special as text? But not sure if I will get the table I have at the bottom.

 

[AbhishekJain]

Sorry to chase, anyone there to help?