Как получить формат таблицы для переноса при отправке таблицы через конверт Excel?

Question

Когда я пытаюсь отправить по электронной почте таблицу, которую я сделал через конверт Excel, данные и их размещение в таблице переносятся, но цвет, границы и т. Д. c. не делает.

В этом сценарии я пытаюсь нажать кнопку, чтобы она скопировала диапазон моей таблицы и разослала его. Я хочу получить как можно лучшее соответствие в выводе , Смотрите мой код и скриншоты ниже:)

Sub DEQACreateAndSend()

' Auto Adjust Sizing based off amount of data given
ActiveSheet.Range("B4:C15").Columns.AutoFit

   ' Select the range of cells on the active worksheet.
   ActiveSheet.Range("B8:C15").Select

Dim cell As Range
Dim rng As Range
Set rng = Range("C7:C14") 'enter your range

On Error Resume Next
    Dim errMsg As String
    For Each cell In rng
    Dim CellString As String
    CellString = cell.Value
    Dim CellLen As Integer
    CellLen = Len(Trim(CellString))

    If CellLen < 1 Then
        errMsg = "Please fill out All required fields!"
    End If
Next cell

If errMsg <> "" Then
    MsgBox errMsg
Else
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True

   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
      .Introduction = ""
      .Item.To = Range("C5")
      If IsEmpty(Range("F3").Value) = True Then
        .Item.Subject = Range("C4")
        Else
        .Item.Subject = ActiveSheet.Range("F3").Text + ActiveSheet.Range("C4")
        End If
        .Item.CC = Range("C6")
      .Item.Send
   End With
   ActiveWorkbook.MailEnvelope = False

End If

' Reset Sizing
With ActiveSheet.Columns("C")
    .ColumnWidth = 87
    End With
With ActiveSheet.Columns("B")
    .ColumnWidth = 25.55
    End With
' Set Active Cell to first field
    ActiveSheet.Range("C4").Select


End Sub

Answer 1

Это будет долго, поэтому извиняюсь ... но это работает.

---

Единственный способ, которым я смог добавить таблицу с форматами в электронное письмо Outlook. сначала преобразует таблицу Excel в таблицу HTML. Затем добавьте таблицу HTML в свою электронную почту.

Это макрос для преобразования таблицы Excel с форматами в диапазон HTML. Здесь вводится диапазон вашей таблицы. Это нужно будет вызывать из отдельного макроса (который фактически собирает и отправляет электронную почту), например, так:

Set EmailTable = Range("??:??")
RangetoHTML(EmailTable) 

Обратите внимание, где приведенный выше код хранится в последнем макросе, совместно используемом при реализации

Option Explicit

Function RangetoHTML(EmailTable As Range)

''''''''''''''''''''''''''''''''''''''''''''''''''''
'Funciton to convert an excel range to a HTML table

    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"


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

---

Я понятия не имею, работает ли это с Envelope, но я не считаю, что это лучший способ отправлять электронные письма из excel. Вместо этого получите доступ к объектам Outlook, чтобы дать вам больше контроля. Вы можете использовать этот шаблон (скопированный непосредственно из макроса, который я успешно использую раз в год в течение последних 3 лет для отправки тысяч писем), чтобы начать работу.

Обратите внимание, что .HTMLBody вызывает макрос выше. Где бы вы ни назвали этот макрос, ваш стол будет приземляться.

Sub Sender ()

Dim OutApp As Object
Dim OutMail As Object
Dim EmailTable as Range
Dim EmailBody as String
EmailBody = "THIS IS YOUR EMAIL BODY"

On Error GoTo FML:
    Set EmailRange = 'INSERT RANGE HERE
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .to = "To"
            .Subject = "Subject"
            .HTMLBody = "" _
                        & "Hi " 
                        & "<br>" _
                        & EmailBody _
                        & RangetoHTML(EmailTable)

            'Change to .Send to actually send emails
            .Display

        End With
  Exit Sub

FML:
    Set OutApp = Nothing
    Set OutMail = Nothing
    'I usually write to a dynamic cell here denoting failure and pass along any relevant info (.to maybe?)

End Sub

---

Конечно, тысячи писем были внутренними. Я не спамер:)