Difficult!!

[mikebecker]

I'm using VBA to convert a spreadsheet to HTML to email as the body. I found this great code and custom formula on www.rondebruin.nl.

Does anyone know how to reduce the size of the HTML? When printing the email, the right side does not show. Also, it prints on two pages.

If I could reduce it, this will work terrific.

Here is the code and custom formula.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> Email_Send()
    <SPAN style="color:#00007F">Dim</SPAN> oApp <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> oMail <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> oAddress1 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> oAddress2 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> oDate <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> oEndDate <SPAN style="color:#00007F">As</SPAN> Date
    <SPAN style="color:#00007F">Dim</SPAN> dest <SPAN style="color:#00007F">As</SPAN> Workbook
    <SPAN style="color:#00007F">Dim</SPAN> myshape <SPAN style="color:#00007F">As</SPAN> Shape
    oDate = Sheets("Checklist").Range("A1")
    oLoc = Sheets("Info").Range("F118")
    Application.DisplayAlerts = <SPAN style="color:#00007F">False</SPAN>
    oAddress1 = Sheets("Info").Range("F124")
    oAddress2 = Sheets("Info").Range("F125")
    oScore = Sheets("Checklist").Range("M65")
    Application.Goto Reference:="Print_Area"
    ActiveSheet.Copy
    <SPAN style="color:#00007F">Set</SPAN> dest = ActiveWorkbook
    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> myshape <SPAN style="color:#00007F">In</SPAN> dest.Sheets(1).Shapes
        myshape.Delete
    <SPAN style="color:#00007F">Next</SPAN>
    Cells.ClearComments
    Cells.Copy
    Cells.PasteSpecial Paste:=xlPasteValues
    Range("E2,F65,L65").ClearContents
    Application.CutCopyMode = <SPAN style="color:#00007F">False</SPAN>
    ActiveSheet.PageSetup.Zoom = 60 <SPAN style="color:#007F00">'' <--- this has NO affect</SPAN>
    <SPAN style="color:#00007F">Set</SPAN> oApp = CreateObject("Outlook.Application")
    <SPAN style="color:#00007F">Set</SPAN> oMail = oApp.CreateItem(0)
    oEndDate = "3/4/2005"
    <SPAN style="color:#00007F">If</SPAN> o<SPAN style="color:#00007F">End</SPAN>Date > Now() <SPAN style="color:#00007F">Then</SPAN>
        <SPAN style="color:#00007F">With</SPAN> oMail
        .To = oAddress1 <SPAN style="color:#007F00">' Sends to full department until Mar 4</SPAN>
        .Subject = "" & oLoc & " " & Month(oDate) & "-" & Day(oDate) & "-" & Year(oDate) & " Warehouse Operational Checklist " & oScore
        .HTMLBody = RangetoHTML
        .Send
    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>
    <SPAN style="color:#00007F">Else</SPAN>
        <SPAN style="color:#00007F">With</SPAN> oMail
        .To = oAddress2 <SPAN style="color:#007F00">' Sends to only department heads after Mar 4</SPAN>
        .Subject = "" & oLoc & " " & Month(oDate) & "-" & Day(oDate) & "-" & Year(oDate) & " Warehouse Operational Checklist " & oScore
        .HTMLBody = RangetoHTML
        .Send
    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>
    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
    dest.Close <SPAN style="color:#00007F">False</SPAN>
    <SPAN style="color:#00007F">Set</SPAN> oMail = <SPAN style="color:#00007F">Nothing</SPAN>
    <SPAN style="color:#00007F">Set</SPAN> oApp = <SPAN style="color:#00007F">Nothing</SPAN>
End <SPAN style="color:#00007F">Sub</SPAN></FONT>

<font face=Courier New><SPAN style="color:#00007F">Function</SPAN> RangetoHTML()
    <SPAN style="color:#00007F">Dim</SPAN> fso <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> ts <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> TempFile <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>
    TempFile = Environ$("temp") & "/" & _
    Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    ActiveSheet.PageSetup.Zoom = 60
    <SPAN style="color:#00007F">With</SPAN> ActiveWorkbook.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=ActiveSheet.Name, _
        Source:=Selection.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>
    
    <SPAN style="color:#00007F">Set</SPAN> fso = CreateObject("Scripting.FileSystemObject")
    <SPAN style="color:#00007F">Set</SPAN> ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    <SPAN style="color:#00007F">Set</SPAN> ts = <SPAN style="color:#00007F">Nothing</SPAN>
    <SPAN style="color:#00007F">Set</SPAN> fso = <SPAN style="color:#00007F">Nothing</SPAN>
    Kill TempFile
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN></FONT>


Mike

 

[Colo]

Mike,

I asked Ron about this matter.
As he think, the Usedrange is to Big.
Please have a look at the following link.

http://www.contextures.com/xlfaqApp.html#Unused