將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的問題。