Input past end of file error (62)

[db2020]

Hi,

I get an "Input past end of file" error with the code below after the step "readall = myfile.readall":

Sub Paste_Pivot()
Sheets("Missing").Select
ActiveSheet.PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel, True
Selection.Copy

Workbooks.Add
ActiveSheet.Paste
Dim newwb As Workbook
Set newwb = ActiveWorkbook

Dim fso As Scripting.FileSystemObject, readall As Variant
Dim myfile As Scripting.TextStream
Set fso = New FileSystemObject
fso.CreateTextFile ("Desktop")
newwb.PublishObjects.Add(xlSoureRange, "Desktop", "sheet1", newwb.Sheets(1).UsedRange.Address, xlHtmlStatic).Publish (True)
Set myfile = fso.OpenTextFile("Desktop")
readall = myfile.readall

Dim o As Outlook.Application
Set o = New Outlook.Application
Dim omail As Outlook.MailItem
Set omail = o.CreateItem(olMailItem)

omail.HTMLBody = "Hello" & "<Br>" & "<table align=left>" & readall & "</table"
omail.Display
End Sub

Any idea how this can be solved? Thanks in advance

 

[Domenic]

Here's what's happening...

fso.CreateTextFile ("Desktop") creates an empty file called "Desktop" in the current directory.

newwb.PublishObjects.Add(xlSoureRange, "Desktop", "sheet1", newwb.Sheets(1).UsedRange.Address, xlHtmlStatic).Publish (True) creates a file called "Desktop.mht" in the current directory.

Set myfile = fso.OpenTextFile("Desktop") opens the text file called "Desktop", not "Desktop.mht".

readall = myfile.readall tries to read the empty file "Desktop", not "Desktop.mht", and so you'll get that error.

So, first of all, you can get rid of this line...

fso.CreateTextFile ("Desktop")

It's not needed. Then you can replace...

newwb.PublishObjects.Add(xlSoureRange, "Desktop", "sheet1", newwb.Sheets(1).UsedRange.Address, xlHtmlStatic).Publish (True)
Set myfile = fso.OpenTextFile("Desktop")

with

newwb.PublishObjects.Add(xlSoureRange, "Desktop.mht", "sheet1", newwb.Sheets(1).UsedRange.Address, xlHtmlStatic).Publish (True)
Set myfile = fso.OpenTextFile("Desktop.mht")

And, lastly, you should close your text stream after you've read the contents of your file using the following line...

myfile.Close

By the way, there's no need to create a new workbook in order to create your html document. Or do you need it for some other use?

 

[db2020]

Hey Domenic, many thanks for y our feedback! Goal of the macro is to copy the pivot table into an outlook mail, a new workbook is not needed necessarily.

I have the macro working but in the email that is generated I get an error (See attached). How can I solve this?

Below this error the pivot is pasted. Is it possible to paste it with the formatting used in the excel file where its copied from?

 

[Domenic]

I have the macro working but in the email that is generated I get an error (See attached). How can I solve this?

You can get rid of the initial part of the text from the file as follows...

.htmlbody = "Hello" & "<br>" & Mid(readall , InStr(1, readall , "<html", vbTextCompare) - 1)

Is it possible to paste it with the formatting used in the excel file where its copied from?

An alternative would be to export a picture of the pivot table, and then embed it within your email. Have you considered this method?

 

[db2020]

Unfortunately I get the same error, but if pasting as a picture solves it i am all ears

 

[Domenic]

The following macro first exports an image of your pivot table to your local temporary folder, then it creates a new email, then it attaches the exported image to the email, and then it embeds the image within the body of the email, and then it deletes the exported image from your local temporary folder.

Note that the code uses late binding, instead of early binding. So there's no need to set any references, such as the Microsoft Outlook Object Library. Also, note that the code assumes that the workbook running the code contains the pivot table. If you want the code to run based on the active workbook instead, replace...

Set pt = ThisWorkbook.Worksheets("Missing").PivotTables("PivotTable1")

with

Set pt = ActiveWorkbook.Worksheets("Missing").PivotTables("PivotTable1")

Here's the code...

Option Explicit

Sub Email_Pivot()

    Dim pt As PivotTable
    Set pt = ThisWorkbook.Worksheets("Missing").PivotTables("PivotTable1")
 
    Dim tempPath As String
    tempPath = Environ("temp") & "\"
 
    Dim tempFile As String
    tempFile = pt.Name & ".png"
 
    tempFile = Replace(tempFile, " ", "_") 'replace any spaces with underscores
 
    ExportRangeToPNG tempPath & tempFile, pt.TableRange2
 
    Dim olApp As Object
    Set olApp = CreateObject("Outlook.Application")
 
    Dim olMailItem As Object
    Set olMailItem = olApp.createitem(0)
 
    With olMailItem
        .attachments.Add tempPath & tempFile
        .htmlbody = "Hello<br><br><img src=""cid:" & tempFile & """>"
        .display
    End With
 
    Kill tempPath & tempFile
 
End Sub

Public Sub ExportRangeToPNG(ByVal saveAsFilename As String, ByVal rangeToExport As Range)

    rangeToExport.CopyPicture Appearance:=xlScreen, Format:=xlPicture
 
    Dim tempWorksheet As Worksheet
    Set tempWorksheet = rangeToExport.Parent.Parent.Worksheets.Add
 
    With tempWorksheet.ChartObjects.Add(Left:=rangeToExport.Left, Top:=rangeToExport.Top, Width:=rangeToExport.Width + 2, Height:=rangeToExport.Height + 2)
        .Activate
        With .Chart
            Do While .SeriesCollection.Count > 0
                .SeriesCollection(1).Delete
            Loop
            .ChartArea.Format.Line.Visible = msoFalse
            .Paste
            With .Pictures(1)
                .Left = .Left + 2
                .Top = .Top + 2
            End With
            .Export Filename:=saveAsFilename, Filtername:="PNG"
        End With
        .Delete
    End With
 
    Application.DisplayAlerts = False
    tempWorksheet.Delete
    Application.DisplayAlerts = True

End Sub

Hope this helps!

 

[db2020]

Many thanks Domenic, this did the trick