将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:\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文件附件，因为我想。但是，任何尝试打开它都会导致每次都出现相同的错误;即使我保存文档并尝试从桌面上打开它。

Answer 1

因此，显然如果我链接到我的保管箱中的任何文件，并尝试使用vba代码将其附加到电子邮件，我会得到这个错误。当文件保存到我的桌面并从那里作为附件提取时，它可以正常工作。我只能假设这是Dropbox的问题。