Question

我有一个像这样的工作簿：

Column B                           Column Q
C:\Folder\file1.xls                Recipient1@email.com
C:\Folder\file2.xls                Recipient2@email.com
C:\Folder\file3.xls                Recipient3@email.com

我想在Q栏中向每位收件人发送电子邮件。我不想向多个收件人发送一封电子邮件，而是希望在列表中为每个收件人发送一封电子邮件。

电子邮件主题，正文等每次都是相同的，但我还想为每封电子邮件附上B列的相应工作簿。

因此，例如，发送给收件人1的电子邮件将包含文件file1.xls，发送给收件人2的电子邮件将包含文件file2.xls，依此类推。

这是我的代码：

Sub Macro1()
    ActiveWorkbook.Save

    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim fromAdr As String
    Dim subject As String
    Dim recip As String
    Dim numSend As Integer
    Dim Attachment1 As String

    ' Mail settings
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields

    ' Mail fields
    fromAdr = """example@example.com"
    recip = Range("Q1").Value
    Debug.Print strbody
    subject = "Orders fondsen"
    strbody = strbody & "Hi," & vbNewLine & vbNewLine & _
              "Please find the document..."

    ' Fields layout
    strbody = strbody & vbNewLine & vbNewLine & "Text"
    Debug.Print strbody
    strbody = strbody & vbNewLine & vbNewLine & "Kind regards,"

    ' Location attachment
    Attachment1 = "file-path"

    ' send mail
    On Error GoTo handleError
    With iMsg
   Set .Configuration = iConf
   .To = recip
   .CC = ""
   .From = fromAdr
   .subject = subject
   .TextBody = strbody
   .AddAttachment Attachment1
   .Send
End With
    numSend = numSend + 1
    GoTo skipError

handleError:
    numErr = numErr + 1
    oFile.WriteLine "*** ERROR *** Email for account" & " not sent. Error: " & Err.Number & " " & Err.Description
skipError:

    On Error GoTo 0

    MsgBox "Total number of emails send: " & numSend & vbNewLine & "Total number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished"
    GoTo endProgram
cancelProgram:
    MsgBox "No emails have been sent.", vbOKOnly + vbExclamation, "Operation cancelled"

endProgram:
    Application.Interactive = True
    Set iMsg = Nothing
    Set iConf = Nothing
    Set dp = Nothing
End Sub

目前此代码会发送一封包含一个附件的电子邮件。我对vba是全新的，所以我不知道该如何做到这一点，但有人可以告诉我让我的代码做我想做的事吗？

P.S。我在这一行也遇到了错误，我不确定原因：

 oFile.WriteLine "*** ERROR *** Email for account" & " not sent. Error: " & Err.Number & " " & Err.Description

提前致谢

Answer 1

您需要添加一个循环，以便您的代码可以选择每个收件人并为每个收件人添加附件。

Sub Macro1()
    ActiveWorkbook.Save

    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim fromAdr As String
    Dim subject As String
    Dim recip As String
    Dim numSend As Integer
    Dim Attachment1 As String

    ' Mail settings
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields

    ' Add the loop
    Range("Q1").Select
    While ActiveCell.Value <> ""

    ' Mail fields
    recip = ActiveCell.Value
    Debug.Print strbody
    strbody = strbody & "Hi," & vbNewLine & vbNewLine & _
              "Please find the document..."

    ' Fields layout
    strbody = strbody & vbNewLine & vbNewLine & "Text"
    Debug.Print strbody
    strbody = strbody & vbNewLine & vbNewLine & "Kind regards,"

    ' Location attachment
    Attachment1 = Range("B" & ActiveCell.Row).Value

    ' send mail
    On Error GoTo handleError
    With iMsg
   Set .Configuration = iConf
   .To = recip
   .CC = ""
   .From = "example@example.com"
   .subject = "Orders fondsen"
   .Body = strbody
   .AddAttachment Attachment1
   .Send
End With

    ActiveCell.Offset(1,0).Select
    Wend

    numSend = numSend + 1
    GoTo skipError

handleError:
    numErr = numErr + 1
    oFile.WriteLine "*** ERROR *** Email for account" & " not sent. Error: " & Err.Number & " " & Err.Description
skipError:

    On Error GoTo 0

    MsgBox "Total number of emails send: " & numSend & vbNewLine & "Total number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished"
    GoTo endProgram
cancelProgram:
    MsgBox "No emails have been sent.", vbOKOnly + vbExclamation, "Operation cancelled"

endProgram:
    Application.Interactive = True
    Set iMsg = Nothing
    Set iConf = Nothing
    Set dp = Nothing
End Sub

此代码或类似的代码应该可以使用。

VBA：通过IBM笔记发送电子邮件（带附件）？

1 个答案: