使用VBA

Question

我对Excel VBA比较陌生，并且不完全了解所使用的关键字。

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

现在这些报告是动态的，并且通常会在其中放置几个​​手动的东西。在这样做时，列会自行调整大小，这是我不想要的。

我在Outlook的布局选项卡中观察到了一个Autofit（固定列宽度）选项，但是我正在寻找在宏中引入它的方法。

你们中的任何人都可以帮我解决这个问题。

感谢您的帮助。我正在使用的代码就是这个

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