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