• 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.

How to change font size of e-mail body in following code

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.


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
 
Back
Top