ThrottleWorks
Excel Ninja
Hi,
This is a non excel question.
I am using below mentioned code to prepare new e-mail from excel file.
I have taken this code form Ozgrid.
However I am not able to change the font size of entire e-mail body.
Also, the e-mail body starts from 2nd line of the e-mail (leave starting line as blank).
I tried checking it but could not find way to populate e-mail body from 1st line itself.
Can anyone please help me in this.
Moderator, please remove the post if required.
This is a non excel question.
I am using below mentioned code to prepare new e-mail from excel file.
I have taken this code form Ozgrid.
However I am not able to change the font size of entire e-mail body.
Also, the e-mail body starts from 2nd line of the e-mail (leave starting line as blank).
I tried checking it but could not find way to populate e-mail body from 1st line itself.
Can anyone please help me in this.
Moderator, please remove the post if required.
Code:
Sub SendEmail()
Dim Rng As Range 'This is range for E-mail body
Dim OutApp As Object 'This will start MS Outlook
Dim OutMail As Object 'This will create new E-mail
Set Rng = Nothing
Set Rng = ThisWorkbook.Worksheets("sheet1").Range("g6:i17") 'E-mail body
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'This code will start MS Outlook if it is closed
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
'CreateItem(0) will create new E-mail
'CreateItem(1) will create new Appointment
'CreateItem(2) will create new Contact
'CreateItem(3) will create new Task
'CreateItem(4) will create Journal Entry
'CreateItem(5) will create Note (tiny yellow square)
'CreateItem(6) will create "Post in this Folder" do not know what is this
'CreateItem(7) will create new Contact Group
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail 'This means with created E-mail object
.SentOnBehalfOfName = ThisWorkbook.Worksheets("sheet1").Range("c1") 'From field
.To = ThisWorkbook.Worksheets("sheet1").Range("c2")
.CC = ThisWorkbook.Worksheets("sheet1").Range("c3")
.Subject = ThisWorkbook.Worksheets("sheet1").Range("c4")
.HTMLBody = RangetoHTML(Rng) 'This RangetoHTML is a function as mentioned in below code
'.Send 'is used to send e-mail
.Display 'is used to save e-mail as draft item
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
ActiveWorkbook.CheckCompatibility = False
End Sub
Function RangetoHTML(Rng As Range) 'Rng here is ThisWorkbook.Worksheets("sheet1").Range("g6:i17")
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) 'Create new excel file
With TempWB.Sheets(1) 'Select Sheet 1 of the new file
.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) 'UsedRange.Address should be range for E-mail body
.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)
'OpenAsTextStream(1, 1)2) E-mail body not populated in saved e-mail
'E-mail body populated with (1,0)
'E-mail body full of invalid values with (1,-1)
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