Отправлять почту через Outlook - Ошибка 287

Question

Я пытаюсь прокрутить список рабочих листов, сохранить каждую из них в виде отдельной книги, а затем отправить их как вложение по почте.

Однако при запуске приведенного ниже кода я заканчиваю ошибкой 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 

Edit: «Он также не даже без вложения По существу генерируя сообщение, содержащее только тему и текст.„Тест“.»

Любые предложения по тому, как это решить? Это сэкономит много времени, чтобы не нажимать «Отправить» для каждой отдельной почты, так как количество отправляемых писем может стать довольно большим.

Answer 1

Я нашел два шага soultion. Изменив .Отправить в. Отображение в приведенном выше коде, сообщения будут создаваться в виде черновиков в 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 перед тем. Отправляем. Это будет похоже. Дисплей без отображения.