Pièce jointe non envoyée avec Gmail et CDO dans Excel / VBA

J'essaie d'envoyer la feuille de travail active via CDO et gmail à toutes les personnes inputs dans certaines zones de text lors de leur envoi. J'utilise le code suivant:

Sub CommandButton1_Click() 'Working in Excel 2000-2013 'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm Dim FileExtStr As Ssortingng Dim FileFormatNum As Long Dim Sourcewb As Workbook Dim ProjectName As Ssortingng Dim Destwb As Workbook Dim TempFilePath As Ssortingng Dim TempFileName As Ssortingng Dim iMsg As Object Dim iConf As Object Dim strbody As Ssortingng Dim Flds As Variant Dim recipientsArray(1 To 10) As Ssortingng Dim i As Long Dim qScore As Ssortingng recipientsArray(1) = TextBox1.Value recipientsArray(2) = TextBox2.Value recipientsArray(3) = TextBox3.Value recipientsArray(4) = TextBox4.Value recipientsArray(5) = TextBox5.Value recipientsArray(6) = TextBox6.Value recipientsArray(7) = TextBox7.Value recipientsArray(8) = TextBox8.Value recipientsArray(9) = TextBox11.Value recipientsArray(10) = TextBox10.Value With Application .ScreenUpdating = False .EnableEvents = False End With Set Sourcewb = ThisWorkbook 'Copy the ActiveSheet to a new workbook ThisWorkbook.ActiveSheet.Copy Set Destwb = ActiveWorkbook 'Determine the Excel version and file extension/format With Destwb If Val(Application.Version) < 12 Then 'You use Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007-2013 Select Case Sourcewb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If .HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If End With 'Save the new workbook/Mail it/Delete it TempFilePath = Environ$("temp") & "\" If Sourcewb.Worksheets("Final Review Feedback").Range("B4").Value = "" Then TempFileName = "No project name" Else TempFileName = Sourcewb.Worksheets("Final Review Feedback").Range("B2").Value & " " & Sourcewb.Worksheets("Final Review Feedback").Range("D4").Value End If If Sourcewb.Worksheets("Extraction").Range("C1").Value = "" Then ProjectName = "N/A" Else ProjectName = Sourcewb.Worksheets("Extraction").Range("C1").Value End If If Sourcewb.Worksheets("Final Review Feedback").Range("D4").Value = 0 Then qScore = "QScore: N/A" Else qScore = "QScore: " & Sourcewb.Worksheets("Final Review Feedback").Range("D4").Value End If Set iConf = CreateObject("CDO.Configuration") iConf.Load -1 ' CDO Source Defaults Set Flds = iConf.Fields With Flds .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "[email protected]" .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*******************" .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com" .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 .Update End With With Destwb .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum On Error Resume Next For i = LBound(recipientsArray) To UBound(recipientsArray) If Not recipientsArray(i) = "" Then Set iMsg = CreateObject("CDO.Message") With iMsg Set .Configuration = iConf .To = recipientsArray(i) .CC = "" .BCC = "" .Subject = "Final Review Feedback: " & ProjectName & " " & qScore .TextBody = "Dear All," & Chr(10) & Chr(10) & "attached you will find the Final Review Feedback for " & ProjectName & "." _ & Chr(10) & Chr(10) & "Yours sincerely," & Chr(10) & Environ("Username") .from = """Final Review"" <[email protected]>" .ReplyTo = "[email protected]" .AddAttachment (TempFilePath & TempFileName & FileExtStr) .Send End With End If Next i On Error GoTo 0 .Close SaveChanges:=False End With 'Delete the file you have send Kill TempFilePath & TempFileName & FileExtStr Set iMsg = Nothing Set iConf = Nothing With Application .ScreenUpdating = True .EnableEvents = True End With Me.Hide Sheet9.Range("N2").Value = "Awaiting Upload" End Sub 

Tout fonctionne bien (text, destinataires, sujet, etc.) à l'exception des pièces jointes. Ils ne sont pas inclus dans le courrier électronique. Comme code, j'ai essayé .Attachments.Add et .AddAttachments . tous deux avec le même résultat.

J'ai vérifié si le nom du file était correct et il semble que ce soit bien. Est-ce que quelqu'un a une idée pourquoi j'envoie des emails vides? Est-ce un problème que j'essaie d'envoyer le classur actif (tout en l'ouvrant et l'activant)?

• Extraire le destinataire du dernier élément dans le dossier de courrier envoyé dans Outlook
• Envoi d'emails de masse avec des pièces jointes à l'aide de VBA
• Copier des outlook
• Code VBA pour envoyer un email personnalisé à partir d'excel
• Comment puis-je envoyer des données Excel (plusieurs plages individuelles) séparées par des returns de chariot à un corps de courrier Outlook

• Automatiser le triggersment du courrier électronique qui a été répondu
• envoi d'un courrier électronique depuis Excel en fonction de multiples conditions
• Sélection de courrier électronique à partir d'Excel à l'aide de Outlook
• Comment mettre à jour automatiquement une signature (plusieurs) dans Email avec VBA
• Automatisation des e-mails

 Sub SendQuoteForm() Dim Send As Integer Dim oApp As Object Dim oMail As Object Dim LWorkbook As Workbook Dim LFileName As Ssortingng Send = MsgBox("Please be sure that you are logged into Microsoft Outlook before sending your finsihed quote. Would you like to continue?", vbYesNo, "Send Finished Quote?") 'I'm not sure if the whole gmail thing will work here, but it's a start If Send = vbYes Then Application.ScreenUpdating = False ActiveSheet.Copy Set LWorkbook = ActiveWorkbook LFileName = LWorkbook.Worksheets(1).Name On Error Resume Next Kill LFileName On Error GoTo 0 LWorkbook.SaveAs Filename:=LFileName Set oApp = CreateObject("Outlook.Application") Set oMail = oApp.CreateItem(0) With oMail .To = "[email protected]" .Subject = "Subject" .body = "blah blah blah" .Attachments.Add LWorkbook.FullName .Display End With LWorkbook.ChangeFileAccess Mode:=xlReadOnly Kill LWorkbook.FullName LWorkbook.Close SaveChanges:=False Application.ScreenUpdating = True Set oMail = Nothing Set oApp = Nothing Else Exit Sub End If End Sub 

  .AddAttachment "C:\Temp\Filename.xlsx" 

  .AddAttachment TempFilePath & "\" & TempFileName & FileExtStr 

 Destwb.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum Destwb.Close SaveChanges:=True