Senden von E-Mail über Outlook - Fehler 287

Question

Ich versuche, eine Reihe von Arbeitsblättern durchlaufen, speichern Sie sie jeweils als separate Arbeitsmappe, und senden Sie sie als Anhang per E-Mail.

Wenn ich jedoch den untenstehenden Code ausführe, bekomme ich den Fehler 287, ausgelöst durch .Send. Ich habe Ausblick offen, so dass das nicht das Problem ist. Wenn ich ändere .Senden Sie an .Display, die Mails werden als Entwürfe erzeugt, wie sie richtig angezeigt werden, wenn das richtige Blatt angehängt ist.

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: „‚‘. Auch kann er auch ohne Befestigung im Wesentlichen nur den Betreff und Text enthält, Erzeugen einer Nachricht“ Test

Irgendwelche Vorschläge, wie man das löst? Es würde viel Zeit sparen, nicht für jede einzelne E-Mail auf Senden klicken zu müssen, da die Anzahl der zu sendenden E-Mails möglicherweise sehr groß wird.

Answer 1

fand ich einen zweistufigen soultion. Durch Ändern von .Senden an .Die Anzeige im obigen Code erstellt die Nachrichten als Entwürfe in Outlook und Angezeigt. Wenn Sie kein zusätzliches Fenster per E-Mail wünschen, können Sie das .Display in .Save einfach in den Entwurfsordner stellen.

Dann kann ich ein Makro in Outlook geschrieben, um alle Entwürfe zu senden. Code basiert auf der Lösung, die bei the mrexcel forums gefunden wird.

Ich entdeckte auch nach dem Lesen this answer on SO, dass der Entwürfe Ordner nicht ausgewählt werden kann, wenn das Makro ausgeführt wird.

Hoffe das hilft anderen, in das gleiche Problem zu laufen.

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 

könnte eine gute Idee sein, Code hinzufügen, um die Nachrichten, die Sie differntiates versuchen, von anderen Entwürfen zu senden, die bereits in dem Ordner befindet.

Würde immer noch eine Ein-Schritt-Lösung bevorzugen, so werde ich mit der Markierung als eine Lösung warten.

Answer 2

Dies ist das, was ich verwendet, um eine Mail mit Anhang an mehrere Adressen zu schicken, in der Spalte H aufgelistet, während der Name des Empfängers in einem anderen

Spalte aufgeführt ist

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

Versuchen. GetInspector vor .Senden. Es wäre wie .Display ohne Anzeige.