Send mail through Outlook - Error 287

Question

I am trying to loop through a set of worksheets, save each of them as a separate workbook, and then send them as attachment by mail.

However when running the below code, I end up with error 287 triggered by .Send. I have outlook open, so that is not the problem. If I change .Send to .Display, the mails are generated as drafts as displayed properly with the correct sheet attached.

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

Edit: "It also fails even without an attachment. Essentially generating a message containing only the subject and text "test"."

Any suggestions for how to solve this? It would save a lot of time to not have to click Send for each individual mail, as the number of mails to send could potentially become quite large.

Just curious, why include OutMail at the line OutMail.Attachments.Add destinationWb.FullName when it's in With OutMail? — BruceWayne
Typo, had written it without with to begin with, and thought it was the attachement causing problems at first, so took that part out. And then just pasted it without changing it. Works both wazs though. But will update code above. — johankr
See here -- there may be a lag while Outlook is attaching the file, and you may need to control for that lag. Or see here: Outlook security settings may prevent sending mail via automation. — David Zemens
@DavidZemens allready tried the first method, and it still fails when I step through with F8. It also fails even without an attachment. Essentially generating a message containing only the subject and text "test". I also think it is likely to be a security issue. The question is how to get around it. Since I need to send attachements, the first solution will not work, and for the second, I am unsure I will get the permission to install Redemption. — johankr

L.Dutch L.Dutch · Accepted Answer · 2016-10-06T19:28:18

This is what I used to send a mail with attachment to multiple addresses, listed in column H while the name of the receiver is listed in another column

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

Send mail through Outlook - Error 287

4 Answers