vba 发送带有不同附件的多封电子邮件

Sending Multiple emails with Different Attachments

提问by Bruno Simon Costa

I am trying to send emails to a list of recipients in an Excel spreadsheet, with a different attachment for each of the emails.

我正在尝试向 Excel 电子表格中的收件人列表发送电子邮件，每封电子邮件都有不同的附件。

I created a macro that generates the different emails, but when I added attachments, only the first email of the list is created with the correct attachment.

我创建了一个宏来生成不同的电子邮件，但是当我添加附件时，只有列表中的第一封电子邮件是用正确的附件创建的。

When the loop comes back to the second email it gives me an error message saying that the attachment was not found (I assume this is for the second message).

当循环返回到第二封电子邮件时，它给我一条错误消息，指出未找到附件（我认为这是第二封邮件）。

I checked and the file names and paths are correct according to the rules I set in the code. It doesn't create a draft of the second email, but simply tells me the file was not found.

我根据我在代码中设置的规则检查了文件名和路径是否正确。它不会创建第二封电子邮件的草稿，而只是告诉我未找到该文件。

How can I generate all of the emails with their proper attachments?

如何生成所有带有正确附件的电子邮件？

The code is as follows:

代码如下：

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 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 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 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

回答by Matt Cremeens

I understand you are supposed to save your mail item before adding attachments. So you might need

我了解您应该在添加附件之前保存您的邮件项目。所以你可能需要

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

before you add each attachment.

在添加每个附件之前。

EDIT: Or perhaps it's best to simply use

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

MItem.Save

回答by v20100v

I recently make an library in order to send email with macros VBA. I use Microsoft CDO technologyto do it, so it doesn't depend on client messagerie like Outlook or Thunderbird. It's only depend on SMTP server.

我最近制作了一个库，以便使用宏 VBA 发送电子邮件。我使用Microsoft CDO 技术来做这件事，所以它不依赖于像 Outlook 或 Thunderbird 这样的客户端消息。它只依赖于 SMTP 服务器。

Enjoy.

享受。

'---------------------------------------------------------------------------
' 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: "[email protected]; [email protected]")
' @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 reperttheitroade (ex: c:\test\foo\) existe
'----------------------------------------------------
' @param String folderPath : le réperttheitroade à tester
' @return Boolean (true, le réperttheitroade 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éperttheitroade 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

---

---

Example of use it :

使用示例：

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