Copy and Paste Excel Sheet in to Outlook Email

[slenish]

Hello,

Ok I am having a problem where I am taking an Excel File and cutting and pasting the info from the first sheet into an Email on a button click on a form.

I actually have it working but my problem is that it will only do it one time and then I have to close the database and re-open it to get it to work again. I think that the problem is that when the program executes I have it creating a temp file and copying the info from the temp and then pasting it, then its supposed to Kill the temp file but i dont think it is until I close out of the db for some reason.

Any help with this would be much appreciated.

My code is in two parts. One is creating the email and putting everything in, the other is a function to cut and paste the excel info.

create temp file, cut and paste:

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ("temp") & "/" & Format(Date, "dd-mm-yy h-mm-ss") & ".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
 

Create email:

Private Sub CreateMail()
 
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim rng As Range
Dim XL_File As String
 
XL_File = "C:\test.xlsx"
 
On Error Resume Next
 
Dim xlApp As Excel.Application
Set xlApp = Nothing
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Open XL_File, , False
'Set xlApp = Nothing
 
Set rng = Nothing
Set rng = xlApp.Sheets(1).UsedRange
'Set rng = Workbooks.Open("C:\test.xlsx").Sheets(1).UsedRange
 
'Get Outlook if it's running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
    'Outlook wasn't running, start it from code
    Set oOutlookApp = CreateObject("Outlook.Application")
    bStarted = True
End If
 
'Create new mail item
Set oItem = oOutlookApp.CreateItem(olMailItem)
 
With oItem
    'Set the recipient for the new email
    .To = "[e-mail]"
    .Subject = "Hello"
    .Attachments.Add "C:\test.xlsx"
    .HTMLBody = RangetoHTML(rng)
    .Display
End With
 
'If bStarted Then
    'If we started Outlook from code, then close it
    'oOutlookApp.Quit
'End If
 
'Clean up
 
Set oItem = Nothing
Set oOutlookApp = Nothing
Set rng = Nothing
 
End Sub