通过Outlook发送邮件 – 错误287
我试图通过一组工作表循环，将它们中的每一个保存为一个单独的工作簿，然后通过邮件发送它们作为附件。
但是，当运行下面的代码，我最终以.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 编辑：“即使没有附件也会失败，主要是生成一个只包含主题和文本”test“的消息。
任何build议如何解决这个问题？ 这样可以节省大量的时间，无需为每个单独的邮件单击“发送”，因为要发送的邮件数量可能会相当大。
这是我用来发送一个邮件附件多个地址，列在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
试试。 GetInspector之前。发送。 这将会像.Display不显示。
我发现了一个两步的灵魂。 通过在上面的代码中更改。发送到.Display，将在Outlook和Displayed中将这些消息创build为草稿。 如果您不希望每个电子邮件有额外的窗口，则将.Display更改为.Save会将其放入草稿文件夹中。
然后，我可以使用Outlook中编写的macros发送所有草稿。 基于在mrexcel论坛上find的解决scheme的代码。
在阅读完SO的这个答案之后，我发现运行macros时不能select草稿文件夹。
希望这有助于其他人遇到同样的问题。
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
可能是一个好主意，添加代码来区分您尝试从可能已经在文件夹中的其他草稿发送的消息。
仍然会提前一步解决scheme，所以我会等待标记为解决scheme。