通过 Outlook 发送邮件 - 错误 287

Question

我正在尝试遍历一组工作表，将每个工作表保存为单独的工作簿，然后通过邮件将它们作为附件发送。

但是，在运行以下代码时，我最终会遇到由 .Send 触发的错误 287。我已经打开了前景，所以这不是问题。如果我将 .Send 更改为 .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”的消息。”

对于如何解决这个问题有什么建议吗？不必为每封邮件单击“发送”将节省大量时间，因为要发送的邮件数量可能会变得非常大。

Answer 1

这是我用来发送带有附件的邮件到多个地址的邮件，列在 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 2

在 .Send 之前尝试 .GetInspector。这就像 .Display 不显示。

Answer 3

我找到了一个两步的灵魂。通过将上面代码中的 .Send 更改为 .Display，消息将在 Outlook 中创建为草稿并显示。如果您不希望每封电子邮件有一个额外的窗口，将 .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

添加代码以区分您尝试发送的消息与可能已经在文件夹中的其他草稿可能是一个好主意。

仍然更喜欢一步解决方案，所以我会等待将其标记为解决方案。

Answer 4

我终于在谷歌上搜索了很多答案。

问题不在于 .send 方法，而在于会话对象。

将 Set myOutlook = Outlook.Application 替换为 设置 objOutlook = ThisOutlookSession

这可确保您的宏使用打开的同一 Outlook 会话。至少它对我有用