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

Question

我只是希望能够使用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:Userstemp" & 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文件附件。然而，每次打开它的尝试都会导致相同的错误;即使我保存文档并试图从桌面打开它

Answer 1

所以很明显，如果我链接到我的dropbox中的任何文件，并试图使用vba代码将其附加到电子邮件，我会得到这个错误。当文件保存到我的桌面并作为附件从那里拉出来时，它工作得很好。我只能假设这是dropbox的问题。