用不同的附件发送多封电子邮件

我正在尝试创build一个macros，以便将电子邮件发送到Excel电子表格中的收件人列表，并为每个电子邮件附加不同的附件。

我能够创build一个生成所有不同电子邮件的macros，但是当我添加附件时，只有列表的第一封电子邮件被创build，并带有所有正确的附件。 当循环回到第二封电子邮件，它给了我一个错误消息，说附件没有find（我认为这是第二个消息）。

我一遍又一遍地检查，根据我在代码中设置的规则，文件名和path是正确的，但系统仍然找不到第二个附件。 它甚至不创build第二封电子邮件的草稿，但只是告诉我该文件不是发现。

我怎样才能生成所有的电子邮件与他们适当的附件？

代码如下：

Sub clientemails() Dim pfolio As String Dim destino As String Dim mo As String Dim text As String Dim subject As String Dim CC As String Dim signature As String Dim officer As String Dim yr As String Dim date1 As String Dim position As String Dim analysis As String Dim activities As String Dim nl As Integer Dim i As Integer Dim OutlookApp As Outlook.Application Dim MItem As Outlook.mailitem Set OutlookApp = New Outlook.Application nl = Cells(5, 1).End(xlDown).Row i = 5 yr = Cells(1, 6).Value date1 = Format(Cells(1, 4).Value, "mm.dd.yy") While nl + 1 > i pfolio = Cells(i, 2).Value destino = Cells(i, 3).Value officer = Cells(i, 10).Value CC = Cells(i, 11).Value Set MItem = OutlookApp.CreateItem(olmailitem) If Cells(i, 9) = "P" Then mo = Cells(1, 3) subject = "Posição e Análise " & pfolio text = "<p><font face=arial size=3>Bom Dia,</p>" _ & "<p>Segue em anexo a posição e análise da carteira " & pfolio & " referente ao mês de " & mo & ". Caso tenha quaisquer dúvidas, favor entrar em contato conosco.</p>" _ & "Atenciosamente," ElseIf Cells(i, 9) = "E" Then month = Cells(2, 3) subject = pfolio & " Statement and Analysis" text = "<p><font face=arial size=3>Hello,</p>" _ & "<p>Please find attached the portfolio statement and analysis for the " & pfolio & " portfolio for the month of " & mo & ". Should you have any questions, please don't hesitate to contact us.</p>" _ & "Sincerely," End If If Cells(i, 4) = "X" Then position = "F:\Files\General Folders\3 Clients\" & officer & "\" & pfolio & "\Position\" & yr & "\" & pfolio & " Portfolio Statement Summary " & date1 & ".pdf" With MItem .Attachments.Add position End With End If If Cells(i, 5) = "X" Then analysis = "F:\Files\General Folders\3 Clients\" & officer & "\" & pfolio & "\Portfolio Analysis\" & yr & "\" & pfolio & " Portfolio Analysis " & date1 & ".pdf" With MItem .Attachments.Add analysis End With End If If Cells(i, 6) = "X" Then activities = "F:\Files\General Folders\3 Clients\" & officer & "\" & pfolio & "\Portfolio Activities\" & yr & "\" & pfolio & " Portfolio Activities " & date1 & ".pdf" With MItem .Attachments.Add activities End With End If With MItem .Display End With signature = MItem.HTMLBody With MItem .subject = subject .To = destino .CC = CC .HTMLBody = text & signature .Save End With i = i + 1 Wend End Sub 

Answer 1

我知道你应该在添加附件之前保存你的邮件。 所以你可能需要

 MItem.SaveAs('some path name', olTXT) 

在添加每个附件之前。

编辑：或者也许最好是简单地使用

 MItem.Save 

Answer 2

我最近做了一个库，以发送电子邮件与macrosVBA。 我使用Microsoft CDO技术来做到这一点，所以它不像Outlook或Thunderbird那样依赖于客户端消息。 这只取决于SMTP服务器。

请享用。

 '--------------------------------------------------------------------------- ' Constantes and global variables '--------------------------------------------------------------------------- Const CONFIG_ACTIVE_SEND_EMAIL = True Const CONFIG_SMTP_SERVER As String = "smtp.host" Const CONFIG_SMTP_PORT As String = "25" Const CONFIG_SMTP_AUTHENTICATE = "0" Const CONFIG_SMTP_USERNAME = "20100" Const CONFIG_SMTP_PASSWORD = "seeyousoon" Const CONFIG_SMTP_SSL = "false" Dim SEND_TRACE_ACTIVATE As Boolean Dim SEND_TRACE_EMAIL As String Global LOG_ACTIVATE As Boolean Global LOG_FILEPATH As String '--------------------------------------------------------------------------- ' Pour envoyer un email avec un serveur SMTP avec la technologie CDO.Message '--------------------------------------------------------------------------- ' @param String expediteur : l'expediteur de l'email ' @param String destinataires : le ou les destinataires de l'email (ex: "[e-mail]; [e-mail]") ' @param String sujet : le sujet de l'email ' @param String body : le contenu du message de l'email (ex: "Hello" & vbNewLine & "See you soon") ' @param Optional String carbon_copy : Addresse(s) pour Carbon-Copy (envoyer un email à plusieurs personnes) ' @param Optional String blind_carbon_copy : Idem que carbon copy sauf que dans l'en-tête la liste des personnes en copie est cachée. ' @param Optional Variant fichiers_joints : String ou Array(String) de chemin de fichiers à joindre dans l'email (max:8mo en tout) ' @param Optional Boolean opt_sendTraceActivate : pour activer la récuperation de la trace d'envoi (par défaut envoi à l'expediteur de l'email). Active forcement l'option opt_logActivate = true. ' @param Optional String opt_sendTraceEmail : pour changer l'email de reception de la trace d'envoi (par défaut envoi à l'expediteur de l'email) ' @param Optional Boolean opt_logActivate : pour activer le log ' @param Optional String opt_logFilePath : pour changer le chemin du fichier log (par defaut = Application.ActiveWorkbook.Path & "log.txt") '--------------------------------------------------------------------------- Sub sendEmail( _ expediteur As String, _ destinataires As String, _ sujet As String, _ body As String, _ Optional carbon_copy As String = "", _ Optional blind_carbon_copy As String = "", _ Optional fichiers_joints As Variant, _ Optional opt_sendTraceActivate As Boolean = False, _ Optional opt_sendTraceEmail As String = "", _ Optional opt_logActivate As Boolean = False, _ Optional opt_logFilePath As String = "") '-- Gestion option sendTrace If opt_sendTraceActivate = True Then opt_logActivate = True SEND_TRACE_ACTIVATE = True SEND_TRACE_EMAIL = expediteur If Not opt_sendTraceEmail = "" Then SEND_TRACE_EMAIL = opt_sendTraceEmail End If End If '-- Gestion option log If opt_logActivate = True Then LOG_ACTIVATE = True LOG_FILEPATH = Application.ActiveWorkbook.Path & "\log_email.txt" If Not opt_logFilePath = "" Then LOG_FILEPATH = opt_logFilePath End If LogFileDelete End If '-- Gestion option carbon_copy et blind_carbon_copy pour affichage dans le debug Dim carbon_copy_str As String Dim blind_carbon_copy_str As String If carbon_copy = "" Then carbon_copy_str = "#vide#" End If If blind_carbon_copy = "" Then blind_carbon_copy_str = "#vide#" End If '-- Log du traitement (ne fonctionne que si l'option opt_logActivate est à true date_now = Now() LogInformation " " If CONFIG_ACTIVE_SEND_EMAIL = True Then LogInformation "---[ DEBUT DU TRAITEMENT]---" Else LogInformation "---[ DEBUT DU TRAITEMENT (mode simulation) ]---" End If LogInformation " _________________________________" LogInformation " " LogInformation " PADI-Excel email (v0.0.1) " LogInformation " _________________________________" LogInformation " " LogInformation " * Informations *" LogInformation " -> Macro du classeur = " & ThisWorkbook.Name LogInformation " -> Utilisateur = " & Application.UserName LogInformation " -> Debut traitement = " & Format(date_now, "yyyy-mm-dd hh:mm:ss") LogInformation " -> SMTP Server = " & CONFIG_SMTP_SERVER LogInformation " -> SMTP Port = " & CONFIG_SMTP_PORT LogInformation " -> SMTP Username = " & CONFIG_SMTP_USERNAME LogInformation " -> SMTP SSL = " & CONFIG_SMTP_SSL LogInformation " -> Option sendTrace = " & SEND_TRACE_ACTIVATE LogInformation " -> Email sendTrace = " & SEND_TRACE_EMAIL LogInformation " " LogInformation " * Propriétés email *" LogInformation " -> Expediteur = " & expediteur LogInformation " -> Destinataires = " & destinataires LogInformation " -> Subject eMail = " & sujet LogInformation " -> Carbon copy = " & carbon_copy_str LogInformation " -> Blind CC = " & blind_carbon_copy_str LogInformation " " LogInformation " -> Body eMail:" LogInformation "{{-------------------------------}}" LogInformation body LogInformation "{{-------------------------------}}" LogInformation " " '-- Création de l'objet CDO (pour créer en envoyer l'email + headers email) Dim objCDO As Object Set objCDO = CreateObject("CDO.Message") '-- Configuration du serveur SMTP With objCDO.Configuration.Fields .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = CONFIG_SMTP_SERVER .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CONFIG_SMTP_PORT .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = CONFIG_SMTP_AUTHENTICATE .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = CONFIG_SMTP_SSL End With '-- Configuration authentification SMTP (si nécessaire) If CONFIG_SMTP_AUTHENTICATE = "1" Then With objCDO.Configuration.Fields .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = CONFIG_SMTP_USERNAME .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = CONFIG_SMTP_PASSWORD End With End If '-- Mise à jour de la configuration CDO objCDO.Configuration.Fields.Update '-- Création du mail à envoyer With objCDO .From = expediteur .To = destinataires .Subject = sujet .TextBody = body .Cc = carbon_copy .Bcc = blind_carbon_copy End With '-- Création du mail à envoyer : ajout de 1 ou plusieurs fichiers joint (si renseigné) LogInformation " -> fichiers joints:" LogInformation "{{-------------------------------}}" If Not IsMissing(fichiers_joints) Then If IsArray(fichiers_joints) Then For i = LBound(fichiers_joints) To UBound(fichiers_joints) objCDO.AddAttachment fichiers_joints ' "C:\temp\Bon de commande.pdf" Next i Else LogInformation " 1 fichiers joints :" LogInformation " -> " & fichiers_joints objCDO.AddAttachment fichiers_joints ' "C:\temp\Bon de commande.pdf" End If Else LogInformation "#aucun#" End If LogInformation "{{-------------------------------}}" '-- Envoi de l'email If CONFIG_ACTIVE_SEND_EMAIL = True Then objCDO.Send End If LogInformation " " LogInformation " -> email envoyé à " & Format(date_now, "yyyy-mm-dd hh:mm:ss") LogInformation " " LogInformation "---[ FIN DU TRAITEMENT]---" LogInformation " " End Sub '---------------------------------------------------- ' Ajoute un message dans le fichier log déclaré dans la variable LOG_FILEPATH ' uniquement si le log est activé avec la variable LOG_ACTIVATE '---------------------------------------------------- ' @param String logMessage : le message à ajouter dans le fichier log '---------------------------------------------------- Sub LogInformation(logMessage As String) If LOG_ACTIVATE = True Then Dim FileNum As Integer FileNum = FreeFile ' next file number Open LOG_FILEPATH For Append As #FileNum ' creates the file if it doesn't exist Print #FileNum, logMessage ' write information at the end of the text file Close #FileNum ' close the file End If End Sub '---------------------------------------------------- ' Pour supprimer le fichier log en début de traitement '---------------------------------------------------- Sub LogFileDelete() On Error Resume Next ' ignore possible errors Kill LOG_FILEPATH ' delete the file if it exists and it is possible On Error GoTo 0 ' break on errors End Sub '---------------------------------------------------- ' Fonction pour tester si un repertoire (ex: c:\test\foo\) existe '---------------------------------------------------- ' @param String folderPath : le répertoire à tester ' @return Boolean (true, le répertoire existe et false sinon) '---------------------------------------------------- Function is_folder_exist(folderPath As String) As Boolean Dim FSO As Object Set FSO = CreateObject("scripting.filesystemobject") If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\" End If If FSO.FolderExists(folderPath) = False Then is_folder_exist = False Else is_folder_exist = True End If End Function '---------------------------------------------------- ' Fonction pour tester si un fichier (ex: c:\test\foo\sample.txt) existe '---------------------------------------------------- ' @param String filePath : le fichier à tester ' @return Boolean (true, le répertoire existe et false sinon) '---------------------------------------------------- Function is_file_exist(filePath As String) As Boolean Dim FSO As Object Set FSO = CreateObject("scripting.filesystemobject") If FSO.FileExists(filePath) = False Then is_file_exist = False Else is_file_exist = True End If End Function 

---

使用它的例子：

 sendEmail _ "[e-mail]", _ "[e-mail]", _ "Subjet", _ "Hello," & vbCrLf & "rfxc", _ opt_logActivate:=True, _ fichiers_joints:="c:\test1.pdf"