使用正在复制到电子邮件的 VBA 格式化表格

Question

我已经为这个问题苦苦挣扎了一段时间，如果能提供任何帮助，我将不胜感激。所以我有从我拥有的 excel 文件生成电子邮件的代码。问题是当电子邮件粘贴在表格上时格式不正确。我附上了输出的截图，代码如下。

Sub Send_Email()

'Updated by Extendoffice 20200119
    Dim xRg As Range
    Dim I, J As Long
    Dim xAddress As String
    Dim xEmailBody As String
    Dim xMailOut As Outlook.MailItem
    Dim xOutApp As Outlook.Application
    On Error Resume Next
    xAddress = ActiveWindow.RangeSelection.Address
    Set xRg = Range("A9:E32")
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
    Set xOutApp = CreateObject("Outlook.Application")
    Set xMailOut = xOutApp.CreateItem(olMailItem)
    For I = 1 To xRg.Rows.Count
        For J = 1 To xRg.Columns.Count
            xEmailBody = xEmailBody & "  " & xRg.Cells(I, J).Value
        Next
        xEmailBody = xEmailBody & vbNewLine
    Next
    xEmailBody = "" & vbLf & vbLf & "" & vbLf & vbLf & xEmailBody & vbNewLine
    With xMailOut
        .Subject = Worksheets("TDN Generator").Range("A6").Value
        .To = ""
        .Body = xEmailBody
        .Display
        '.Send
    End With
    Set xMailOut = Nothing
    Set xOutApp = Nothing
    Application.ScreenUpdating = True
End Sub

这就是它粘贴到电子邮件中的方式：

  Hello, 
   
  Check it out:        
          
  Trade 2        
  Trade Type  Grant Number  Security Type  Shares Sold  Shares Exercised 
  Sell To Cover  12345  Restricted Stock  200  
  Sell To Cover  12346  Restricted Stock  220  
  Sell To Cover  12347  Restricted Stock  240  
  Sell To Cover  12348  Restricted Stock  260  
  Sell To Cover  12349  Restricted Stock  280  

我希望他们都在他们所说的列中正确对齐。

Answer 1

您可以根据需要使用空格函数向左或向右填充值。

Option Explicit

Public Sub Test()

    Dim colwidth(1 To 5) As Integer
    Dim rg As Range
    Dim row As Range
    Dim col As Integer
    Dim val As String
    Dim strout As String
    
    ' adjust the column widths as required
    ' you will get an error if the value is
    ' wider than the column width
    colwidth(1) = 13
    colwidth(2) = 12
    colwidth(3) = 16
    colwidth(4) = 12
    colwidth(5) = 16
    
    ' function is in the worksheet module for convenience
    With Me
    
        Set rg = .Range("A1:E6")
        
        For Each row In rg.Rows
        
            ' pad left
            col = 1
            val = row.Cells(1, col)
            strout = val & Space(colwidth(col) - Len(val) + 1)
        
            ' pad right
            col = 2
            val = row.Cells(1, col)
            strout = strout & Space(colwidth(col) - Len(val)) & val & Space(1)
        
            ' pad left
            col = 3
            val = row.Cells(1, col)
            strout = strout & val & Space(colwidth(col) - Len(val) + 1)
        
            ' pad right
            col = 4
            val = row.Cells(1, col)
            strout = strout & Space(colwidth(col) - Len(val)) & val & Space(1)
        
            ' pad left
            col = 5
            val = row.Cells(1, col)
            strout = strout & val & Space(colwidth(col) - Len(val) + 1)
            
            Debug.Print strout
            
        Next row
    
    End With
    
End Sub

数据范围

输出

Trade Type    Grant Number Security Type     Shares Sold Shares Exercised 
Sell To Cover        12345 Restricted Stock          200                  
Sell To Cover        12346 Restricted Stock          220                  
Sell To Cover        12347 Restricted Stock          240                  
Sell To Cover        12348 Restricted Stock          260                  
Sell To Cover        12349 Restricted Stock          280                  

当然，这仅适用于固定间距字体。如果邮件客户端支持，最好将数据写成 html 表格。

Answer 2

使用 HTML 格式：

Sub Send_Email()

    Dim xRg As Range
    Dim I, J As Long
    Dim xAddress As String
    Dim xEmailBody As String
    Dim xMailOut As Outlook.MailItem
    Dim xOutApp As Outlook.Application

    On Error Resume Next
    
    Set xRg = Range("A9:E32")
    xEmailBody = "Take a look:<br><br>" & HtmlTable(xRg)
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xMailOut = xOutApp.CreateItem(olMailItem)
    
    With xMailOut
        .Subject = Worksheets("TDN Generator").Range("A6").Value
        .To = ""
        .HTMLBody = xEmailBody
        .Display
        '.Send
    End With
    Set xMailOut = Nothing
    Set xOutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Function HtmlTable(rng As Range) As String
    Dim s As String, rw As Range, c As Range
    s = "<table border=1>"
    For Each rw In rng.Rows
        s = s & "<tr>"
        For Each c In rw.Cells
            s = s & "<td>" & c.Value & "</td>"
        Next c
        s = s & "</tr>"
    Next rw
    HtmlTable = s & "</table>"
End Function

Answer 3

你试过粘贴特殊命令吗？

通常是 CTRL+ALT+V 或 ALT+E+S 打开粘贴专用对话框。