将数据从 Excel 导入 Outlook 时如何设置固定列宽？

Posted 2023-02-19

【中文标题】将数据从 Excel 导入 Outlook 时如何设置固定列宽？

【英文标题】：How to set a Fixed Column Width while importing data from Excel to Outlook?

【发布时间】：2017-10-03 21:56:36

【问题描述】：

我编写了一个 Excel VBA 脚本来生成一份报告，然后通过电子邮件发送。我使用了 Ron De Bruin 的 Rangetohtml 函数。

这些报告是动态的，通常会在其中放置一些手动操作。这样做时，列会自行调整大小。

我在 Outlook 的布局选项卡中观察到了自动调整（固定列宽）选项，但我正在寻找在宏中引入此选项的方法。

Function prepmail()
    Dim r1 As Range
    Dim d As Variant
    Dim d2 As String
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set r1 = Nothing
    ' Only send the visible cells in the selection.
    
    Set r1 = Range(Cells(1, 1), Cells(21, 3))
    
    If r1 Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
               vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Function
    End If
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Dim s1 As String
    
    'Call formatsetter
    Dim r2 As Range
    Dim s2 As String
    s1 = RangetoHTML(r1)
    
    
    d = Date - 1
    Cells(22, 3).Value = d
    Cells(22, 3).NumberFormat = "mm/dd/yyyy"
    d2 = VBA.format(d, "mm/dd/yyyy")
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .to = "MML RPS <[e-mail]>"
        .CC = "MML Team <[e-mail]>"
        .BCC = ""
        .Subject = "RPS Batch Cycle Status Report: " & d2
        .HTMLBody = s1
        ' In place of the following statement, you can use ".Display" to
        ' display the e-mail message.
        .Display
    End With
    On Error GoTo 0
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Function
    
Function RangetoHTML(rng As Range)
    ' By Ron de Bruin.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim vPath As String
    vPath = ThisWorkbook.Path
    
    TempFile = vPath & "\" & "temp.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

【问题讨论】：

您是否需要：您不希望 Outlook 调整列的大小？那你想用 Excel VBA 做吗？

没错，当数据导入到 Outlook 中，然后在电子邮件中手动进行进一步修改时，列而不是保持理想情况下应该扩展的固定宽度。所以每次我向单元格添加一些东西时，我必须手动按 ALT+Enter 以避免这种情况，或者必须关闭自动调整大小选项。

【参考方案1】：

您需要在复制部分之后复制目标范围内的行高和列宽：

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

    Dim r3 As Range, rw As Integer, c As Integer
    Set r3 = Range(Cells(1, 1), Cells(21, 3))

    With r3
        For rw = 1 To .Rows.Count
            .Rows(rw).RowHeight = rng.Rows(rw).RowHeight
        Next rw
        For c = 1 To .Columns.Count
            .Columns(c).ColumnWidth = rng.Columns(c).ColumnWidth
        Next c
    End With
...

【讨论】：

谢谢你，我试过了，但问题仍然存在。我不确定，但我猜这段代码会将 Outlook 中的行高和列高设置为与excel中的列。然后，一旦准备好邮件，当手动将一些数据输入单元格时，行和列再次打开以自动调整大小，但我不确定。一旦准备好邮件，我正在寻找某种方法来修复列宽，以便在邮件准备好后手动将数据输入单元格时，列不会调整大小。