使用VBA将数据从Excel导入到Outlook时引入固定列宽

Question

我对Excel VBA相对较新，并未完全了解所用的关键字。

我写了一个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 <MML_RPS@csc.com>" 
    .CC = "MML Team <MML_Team@csc.com>" 
    .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 

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