2017-05-05 22 views
2

我對Excel VBA相對較新,並未完全瞭解所用的關鍵字。使用VBA將數據從Excel導入到Outlook時引入固定列寬

我寫了一個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 <[email protected]>" 
    .CC = "MML Team <[email protected]>" 
    .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 
+0

是你的需要:你不」想要Outlook調整列的大小?那麼你想用Excel VBA做到這一點? –

+0

是的,當數據被導入到outlook中,然後手動完成電子郵件中的進一步修改時,這些列不是保持固定寬度,而是理想地應該擴展。所以每次我給細胞添加東西時,我都必須手動按下ALT + Enter來避免出現,或者必須關閉自動調整大小選項。 –

回答

0

你需要複製的行的高度,並在目標範圍內的列的副本後部分寬度:

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

謝謝D.O,我試過這個,但問題仍然存在。我不確定,但我猜這個代碼會在Outlook中設置行和列的高度,就像在Excel中列的行和列的高度一樣。然後,一旦準備好郵件,行和列再次打開,以便手動輸入一些數據時自動調整大小,但我不確定。我正在尋找一些方法來修復郵件準備後的列寬,以便在郵件準備就緒後將數據手動輸入到單元格中時,列不會調整大小。 –