将Excel工作表附加到Outlook电子邮件

我只是希望能够使用vba将excel文件附加到Outlook电子邮件中 . 这似乎很简单，但我一直收到错误 .

该文件可以附加和发送，但是当收件人打开excel文件时会弹出一个窗口，显示“加载时出现问题”，并在下面的文本框中显示“缺少文件：”

这是代码

Sub SendReports()

Searched_Email = Array("(file destination)", "(subject of the email im searching for)", "(what i want to save the file as)", "(the email(s) its being sent to)")
Call Reports(Searched_Email)

End Sub

Function Reports(a As Variant)

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim olFldr As MAPIFolder
Dim olItms As Items
Dim olMi As MailItem
Dim olEmail As Outlook.MailItem
Dim olAtt As Attachment
Dim MyPath As String

Dim subj As String
Dim saveAs As String
Dim emails As String
Dim FilePath As String


FilePath = a(0) "\"
subj = a(1)
saveAs = a(2)
emails = a(3)

MyPath = "C:\Users\temp\" & FilePath
Set olApp = GetObject(, "Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
Set olEmail = olApp.CreateItem(olMailItem) 

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set rng = Nothing
Set rng = ActiveSheet.UsedRange

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Set olMi = olItms.Find("[Subject] = " & Chr(34) & subj & Chr(34))
If Not (olMi Is Nothing) Then
             For Each olAtt In olMi.Attachments

                 olAtt.SaveAsFile MyPath & saveAs & ".xls"
                 Workbooks.Open (MyPath & saveAs & ".xls")

                 Call NewFormat.master 
                 ' ---- This is separate file that formats the excel file

                 ActiveWorkbook.Save
                 Set rng = Worksheets(saveAs).UsedRange
             Next olAtt
End If
On Error Resume Next
With OutMail
    .To = emails
    .CC = 
    .BCC = ""
    .subject = subj
    .HTMLBody = RangetoHTML(rng)
    .Attachments.Add ActiveWorkbook.FullName '--------heres where the attachment is
    .send
End With
On Error GoTo 0
ActiveWorkbook.Close
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
Set olAtt = Nothing
Set olMi = Nothing
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Function


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(Now, "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

其他一切都有效 . 根据我的理解，一切都是正确的，文件正在发送，并显示为我想要的.xls文件附件 . 但是，任何打开它的尝试每次都会导致相同的错误;即使我保存文档并尝试从桌面打开它 .