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

编辑：＆＃34;即使没有附件也会失败。基本上生成一条仅包含主题和文本的消息＆＃34; test＆＃34;。＆＃34;

有关如何解决此问题的任何建议？这样可以节省大量时间，无需为每封邮件单击“发送”，因为要发送的邮件数量可能会变得非常大。

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到.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

最好添加一些代码，这些代码可以区分您尝试从该文件夹中可能已存在的其他草稿发送的邮件。

仍然会优先采用一步解决方案，所以我会等待将此标记为解决方案。

Answer 3

Try .GetInspector before .Send. It would be like .Display without displaying.

Answer 4

我终于找到了很多搜寻答案。

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

使用以下命令替换myOutlook = Outlook.Application 设置objOutlook = ThisOutlookSession

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

通过Outlook发送邮件 - 错误287

4 个答案: