VBA Mail: .HTMLBody and Format

[vadius]

Hello

Below is a code I have arranged which sends a range of cella from excel by email. I want to add some text before (like come comments).
You will find them here : messg = "EUR" etc....
Then I add the range of cells with RangetoHTML(rng)

I have tried .HTMLBody = messg & RangetoHTML(rng) (in red in the code below)

The code works I have the text and the cells, but the format of the text is not the one I specified (I have everything on the same line in my mail message draft).

Has anyone any idea on this ? I can't manage to force him to write messg correctly, and then add the range of cells.

Thanks

Sub Send_Mail()
Dim pathAttach As String
Dim listRecip As String
Dim CClistRecip As String
Dim subj As String
Dim messg As String
Dim pnl, pnl1, pnl1000 As Variant
Dim i, a, u, s As Integer
Dim comments As String
Dim Picture As String
Dim icount As Variant
Dim posneg As String
Dim Flash As Double
Dim objIE As Object
Dim objElement As Object
Dim objCollection, TextAreaCollection, AAreaCollection As Object
Dim Comment, t As String
Dim strStartPath, Folder, Path As String
Dim Folders() As Variant
Dim x, y As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Dim wb As Workbook
Dim rng As Range
'Define PnL figure
Flash = Workbooks("PandL.xls").Worksheets("Mail").Range("G43").Value
 Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    Set rng = Sheets("Mail").Range("B3:H43").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
'check to see if there is a PnL folder for the present month
Folders = SubFolders("P:\Lonib\Derivatives\Equity Financing\Global\P&L\2012")
For u = LBound(Folders) To UBound(Folders)
If Folders(u) = format(Now(), "mmm") Then
Exit For
Else
If u = UBound(Folders) Then
Path = "P:\Lonib\Derivatives\Equity Financing\Global\P&L\2012\" & format(Now(), "mmm")
MkDir Path
End If
End If
Next
Dim fileName1 As String
fileName1 = "P:\Lonib\Derivatives\Equity Financing\Global\P&L\2012\" & format(Now(), "mmm") & "\EQD1 CAFlow Flash " & format(Now(), "dd mmm") & ".xls"

Worksheets("Mail").copy
Set wb = ActiveWorkbook
wb.SaveAs Filename:=fileName1, FileFormat _
:=xlExcel9795, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
'ActiveWorkbook.Close
If Flash > 0 Then
posneg = "+"
Else: posneg = "-"
End If
pnl = Abs(Flash)
pnl1 = format(Application.WorksheetFunction.Round(pnl, 0), "#,##0")
'pnl1000 = format(Application.WorksheetFunction.Round(pnl / 1000, 0), "#,##0")
If Len(Comment) < 2 Then
    If pnl1 >= 2000 Then
        MsgBox "You must enter a comment as Abs(PnL)>=2M EUR", vbOKOnly
        Exit Sub
    Else
        pathAttach = fileName1
        
        listRecip = "CM ED1 LDN PnL Flash"
        
        subj = "EQD1 CAFlow Flash " & format(Now(), "dd mmm") & "  P&L"
        
        [COLOR=red]messg[/COLOR] = "EUR " & posneg & pnl1 & "k" & vbCrLf & vbCrLf _
        & "Main drivers:" & vbCrLf & vbCrLf _
        & "-" & vbCrLf & vbCrLf _
        & Picture & vbCrLf & vbCrLf _
        & "Many Thanks " & vbCrLf & vbCrLf
        '& Comment & vbCrLf & vbCrLf
        '"Hi," & vbCrLf & vbCrLf & "Please find attached today's p&l flash" & vbCrLf & vbCrLf
      
        Set oApp = New Outlook.Application
        Set oMail = oApp.CreateItem(olMailItem)
         
        With oMail
            .To = listRecip
            .CC = CClistRecip
            .Attachments.Add pathAttach
            .Subject = subj
            '.Body = messg
            [COLOR=red].HTMLBody[/COLOR] [COLOR=red]= messg & RangetoHTML(rng)
[/COLOR]            .Save
            .Display
        End With
        
        
        '###############################
        'ENTER P&L FLASH IN IE
        '###############################
        
        
        Set objIE = CreateObject("InternetExplorer.Application")
        objIE.Visible = True
        
        With objIE
        .Navigate "[URL]https://flash.ib.internal//Input/Default.aspx[/URL]"
        End With
           SendKeys "{Enter}"
           
        Do While objIE.Busy
            SendKeys "{Enter}"
            Application.Wait DateAdd("s", 1, Now)
        Loop
    
        
        Application.StatusBar = "Search form submission. Please wait..."
         
        Set objCollection = objIE.Document.getElementsByName("ctl00$cphMainContent$txtValue_89146")
        
        If posneg = "-" Then
            objCollection(0).Value = posneg & pnl1
            objCollection(0).Focus
            SendKeys "{Tab}"
            SendKeys "(Enter)"
            Application.Wait DateAdd("s", 2, Now)
            SendKeys "(Enter)"
        Else
            objCollection(0).Value = pnl1
            objCollection(0).Focus
            SendKeys "{Tab}"
            SendKeys "(Enter)"
            Application.Wait DateAdd("s", 2, Now)
            SendKeys "(Enter)"
        End If
        
        'objIE.Quit
    End If
Else
    'objIE.Quit
End If
End Sub
Sub test()
Dim objIE As InternetExplorer
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True
With objIE
.Navigate "[URL]https://flash.ib.internal//Input/Default.aspx[/URL]"
End With
End Sub
 Sub Macro1()
 Workbooks.Open Filename:= _
    "[URL]https://flash.ib.internal/Input/Default.aspx[/URL]"
Do While IE.Busy
    Application.Wait DateAdd("s", 1, Now)
Loop
End Sub
Function SubFolders(SourceFolderName As String) As Variant
Dim objFSO, objFolder, colSubfolders, objSubfolder As Object
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim k As Integer
Dim Folders() As Variant
Dim Name, name1, name2 As String
Dim Names() As Variant
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(SourceFolderName)
Set colSubfolders = objFolder.SubFolders
k = colSubfolders.Count
ReDim Names(k - 1)
k = 0
For Each objSubfolder In colSubfolders
    Name = objSubfolder.Name
    Names(k) = Name
    k = k + 1
Next
name1 = Names(UBound(Names))
name2 = Names(LBound(Names))
SubFolders = Names
End Function
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    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