Отправить Gmail VBA HTML формат выпуска

Question

Это код, который я использую для отправки электронных писем через электронную почту из электронных таблиц, я пытаюсь отправить более одной таблицы в теле, поэтому я создал новую вкладку со всеми таблицами, все работает, и я могу отправить электронная почта, и когда я go отправляю на настольное приложение Gmail электронное письмо с тем же форматом, моя настоящая проблема заключается в том, что когда я go перехожу на веб-страницу Gmail или в мое приложение Gmail, формат отсутствует, у кого-то была такая же проблема или может помочь посмотреть, что мне не хватает? спасибо!

Option Explicit

Sub SMgTEmail()

Application.ScreenUpdating = False
Application.Calculation = xlManual

Dim newMail As CDO.Message
Dim mailConfiguration As CDO.Configuration
Dim fields As Variant
Dim msConfigURL As String
Dim rng As Range
Dim myValue As Variant

On Error GoTo errHandle

Set newMail = New CDO.Message
Set mailConfiguration = New CDO.Configuration

'Call SnewRange

Set rng = Nothing

Set rng = [Test]

mailConfiguration.Load -1

Set fields = mailConfiguration.fields

With newMail

  .Subject = [SubjectInternal]
  .From = [FromInternal]
  .To = [ToInternal]
  .CC = ""
  .BCC = ""
  .TextBody = ""
  .HTMLBody = RangetoHTML(rng)
End With

msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

With fields
    .Item(msConfigURL & "/smtpusessl") = True
    .Item(msConfigURL & "/smtpauthenticate") = 1

    .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
    .Item(msConfigURL & "/smtpserverport") = 465
    .Item(msConfigURL & "/sendusing") = 2

    myValue = InputBox("Gmail Password")

    .Item(msConfigURL & "/sendusername") = [FromInternal]
    .Item(msConfigURL & "/sendpassword") = myValue

    .Update

End With

newMail.Configuration = mailConfiguration
newMail.Send

MsgBox "E-Mail has been sent", vbInformation

exit_line:

' Release Object Memory
Set newMail = Nothing
Set mailConfiguration = Nothing

Exit Sub

errHandle:

MsgBox "Error:" & Err.Description

GoTo exit_line

Application.ScreenUpdating = True

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

On Error Resume Next
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

Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit

'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

Sub SnewRange()

Dim TempWB As Workbook
Dim rng, rng1, rng2, rng3 As Range
Dim rng4 As String
Dim lngRng1, Row As Long

shtEmail.Select
Cells.Select
Cells.Clear

Set rng = [PnL]
Set rng1 = [Monthly]
Set rng2 = [YTD]
Set rng3 = [Token]
rng4 = [Total]

Set TempWB = ActiveWorkbook

'Paste PnL
 lngRng1 = Application.CountA(shtEmail.Range("A:A")) + 2

On Error Resume Next
rng.Copy

With TempWB.Sheets("Email")
    .Cells(lngRng1, 1).PasteSpecial Paste:=8
    .Cells(lngRng1, 1).PasteSpecial xlPasteValues, , False, False
    .Cells(lngRng1, 1).PasteSpecial xlPasteFormats, , False, False
    .Cells(lngRng1, 1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
    End With

'Format *********Need to be dynamic

Range("L10").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("A10:K15").Select

'******************

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.Style = "Comma"
Selection.NumberFormat = "_(* #,##0.0_);_(* (#,##0.0);_(* ""-""??_);_(@_)"
Selection.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"

With Selection
    .HorizontalAlignment = xlRight
    .VerticalAlignment = xlBottom
    .Orientation = 0
    .IndentLevel = 0
    .ReadingOrder = xlContext
End With

'Paste PnL MTD

lngRng1 = Application.CountA(shtEmail.Range("A:A")) + 3

On Error Resume Next
rng1.Copy

With TempWB.Sheets("Email")
    .Cells(lngRng1, 1).PasteSpecial Paste:=8
    .Cells(lngRng1, 1).PasteSpecial xlPasteValues, , False, False
    .Cells(lngRng1, 1).PasteSpecial xlPasteFormats, , False, False
    .Cells(lngRng1, 1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
    End With

'Paste PnL YTD

lngRng1 = Application.CountA(shtEmail.Range("A:A")) + 4

On Error Resume Next
rng2.Copy

With TempWB.Sheets("Email")
    .Cells(lngRng1, 1).PasteSpecial Paste:=8
    .Cells(lngRng1, 1).PasteSpecial xlPasteValues, , False, False
    .Cells(lngRng1, 1).PasteSpecial xlPasteFormats, , False, False
    .Cells(lngRng1, 1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
    End With

'Paste Token

lngRng1 = Application.CountA(shtEmail.Range("A:A")) + 5

On Error Resume Next
rng3.Copy

With TempWB.Sheets("Email")
    .Cells(lngRng1, 1).PasteSpecial Paste:=8
    .Cells(lngRng1, 1).PasteSpecial xlPasteValues, , False, False
    .Cells(lngRng1, 1).PasteSpecial xlPasteFormats, , False, False
    .Cells(lngRng1, 1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
    End With

'Format *********Need to be dinamic

Row = Application.WorksheetFunction.Match("Total", shtEmail.Range("N:N"), 0)
lngRng1 = Application.CountA(shtEmail.Range("A:A")) + 7


Range("N" & Row).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("A" & Row & ":N" & lngRng1).Select

'******************

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
Application.CutCopyMode = False

Columns("A:A").Select
With Selection
    .HorizontalAlignment = xlLeft
    .Orientation = 0
    .IndentLevel = 0
    .ReadingOrder = xlContext
 End With


 Cells.Select
 Cells.EntireColumn.AutoFit
 Cells.EntireRow.AutoFit

 End Sub