Hello,

I have the following code, most of which comes from Ron de Bruin and his excellent site involving much about emailing in Excel VBA.

The code simply generates an email in Outlook from a sheet of data. It works great except for one thing. The scaling of the published HTML is different than the scaling of how the sheet appears in Excel. This causes columns of data to wrap in the published HTML whereas the data in the Excel spreadsheet does not wrap. Ideally, I would like for the published HTML to look exactly as the sheet looks in Excel. I tried to use 'ActiveWindow.Zoom = 60' in the Function below to scale the Excel sheet prior to publishing but it has no effect at all.

Any help is appreciated.

TV 

Sub test()
       
        Dim OutApp As Object
        Dim OutMail As Object
        Dim strbody As Range
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        
        Set strbody = Sheets("Sheet1").Range("A1:A10")
    
        On Error Resume Next
        With OutMail
            .To = "me@me.com"
            .CC = ""
            .BCC = ""
            .Subject = "Shipped Orders Summary " & Format(Date, "dd-mmm-yy")
            .HTMLBody = RangetoHTML(strbody)
            'You can add a file like this
            '.Attachments.Add
            .display   '.Send or use .Display
        End With
        On Error GoTo 0
    
        Set OutMail = Nothing
        Set OutApp = Nothing
            

End Sub

Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
        .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
    ActiveWindow.Zoom = 70
 
    ' Publish the sheet to an .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 the RangetoHTML subroutine.
    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.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function