通過Outlook發送郵件 - 錯誤287

Question

我試圖循環一組工作表，將它們中的每一個都保存爲單獨的工作簿，然後通過郵件將它們作爲附件發送。

但是，當運行下面的代碼時，最終由.Send觸發的錯誤287結束。我有前景開放，所以這不是問題。如果我更改。發送到.Display，郵件生成爲草稿，正確顯示並附上正確的表單。

Sub SendWorksheetsByMail() 
    Dim wb As Workbook 
    Dim destinationWb As Workbook 
    Dim OutApp As Outlook.Application 
    Dim OutMail As Outlook.MailItem 

    Set wb = Workbooks("Test.xlsm") 

    Application.EnableEvents = False 
    Application.ScreenUpdating = False 

    For Each ws In wb.Worksheets 
     'Ignore Summary and Config 
     If ws.Name <> "Summary" And ws.Name <> "Config" Then 
      'On Error Resume Next 
      Set OutApp = CreateObject("Outlook.Application") 
      Set OutMail = OutApp.CreateItem(olMailItem) 

      ws.Copy 
      Set destinationWb = ActiveWorkbook 
      destinationWb.SaveAs "C:\****************\" & ws.Name & ".xlsx", FileFormat:=51 
      With OutMail 
       .To = "*******************" 
       .Subject = "Test" 
       .Body = "Test" 
       .Attachments.Add destinationWb.FullName 
       .Send 
      End With 

      Set OutMail = Nothing 
      Set OutApp = Nothing 
     End If 
    Next ws 

    Application.EnableEvents = True 
    Application.ScreenUpdating = True 
End Sub 

編輯：「它也沒有即使沒有附着實質上生成僅包含主題和文本的消息。‘測試’。」

有關如何解決此問題的任何建議？這將節省大量時間，無需爲每個單獨的郵件點擊發送，因爲發送郵件的數量可能會變得相當大。

Answer 1

列出我發現了一個兩步soultion。通過更改。發送到上面代碼中的.Display，郵件將在Outlook和Displayed中創建爲草稿。如果您不希望每個電子郵件有額外的窗口，請將.Display更改爲.Save將它們放入草稿文件夾中。

然後我可以使用在Outlook中編寫的宏發送所有草稿。基於解決方案的代碼見the mrexcel forums。

我在閱讀this answer on SO後也發現，運行宏時無法選擇草稿文件夾。

希望這有助於其他人遇到同樣的問題。

Public Sub SendDrafts() 

    Dim lDraftItem As Long 
    Dim myOutlook As Outlook.Application 
    Dim myNameSpace As Outlook.NameSpace 
    Dim myFolders As Outlook.Folders 
    Dim myDraftsFolder As Outlook.MAPIFolder 

    'Send all items in the "Drafts" folder that have a "To" address filled in. 

    'Setup Outlook 
    Set myOutlook = Outlook.Application 
    Set myNameSpace = myOutlook.GetNamespace("MAPI") 
    Set myFolders = myNameSpace.Folders 

    'Set Draft Folder. 
    Set myDraftsFolder = myFolders("*******@****.com").Folders("Drafts") 

    'Loop through all Draft Items 
    For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1 
     'Check for "To" address and only send if "To" is filled in. 
     If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then 
      'Send Item 
      myDraftsFolder.Items.Item(lDraftItem).Send 
     End If 
    Next lDraftItem 

    'Clean-up 
    Set myDraftsFolder = Nothing 
    Set myNameSpace = Nothing 
    Set myOutlook = Nothing 

End Sub 

可能是添加differntiates你正試圖從其他草稿可能已經在文件夾中發送消息的代碼是一個好主意。

仍然會提供一個步驟的解決方案，所以我將等待將此標記爲解決方案。

Answer 2

這是我以前帶附件發送郵件到多個地址，在H列中列出，而接收方的名稱，另一列

Sub Mail() 
'#################################### 
'### Save the file as pdf ###### 
'#################################### 
Dim FSO As Object 
Dim s(1) As String 
Dim sNewFilePath As String 

Set FSO = CreateObject("Scripting.FileSystemObject") 
s(0) = ThisWorkbook.FullName 

If FSO.FileExists(s(0)) Then 
    '//Change Excel Extension to PDF extension in FilePath 
    s(1) = FSO.GetExtensionName(s(0)) 
    If s(1) <> "" Then 
     s(1) = "." & s(1) 
     sNewFilePath = Replace(s(0), s(1), ".pdf") 

     '//Export to PDF with new File Path 
     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNewFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False 
    End If 
Else 
    '//Error: file path not found 
    MsgBox "Error: this workbook may be unsaved. Please save and try again." 
End If 

Set FSO = Nothing 
'########################################## 
'### Attach the file and mail it ###### 
'########################################## 
Dim OutApp As Object 
Dim OutMail As Object 
Dim sh As Worksheet 
Dim cell As Range 
Dim FileCell As Range 
Dim rng As Range 

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

Set sh = Sheets("sheet") 

Set OutApp = CreateObject("Outlook.Application") 
For Each cell In sh.Columns("H").Cells.SpecialCells(xlCellTypeConstants) 

    If cell.Value Like "?*@?*.?*" Then 
     Set OutMail = OutApp.CreateItem(0) 

     With OutMail 
      .to = cell.Value 
      .Subject = "file delivery " 
      .Body = "Hi " & cell.Offset(0, -3).Value & " here is my file" 
      .Attachments.Add sNewFilePath 


      .Send 'Or use .Display 
     End With 

     Set OutMail = Nothing 
    End If 
Next cell 

Set OutApp = Nothing 
With Application 
    .EnableEvents = True 
    .ScreenUpdating = True 
End With 
End Sub 

Answer 3

試試。 GetInspector之前。發送。這將是.Display不顯示。