VBA: отправить электронную почту (с приложением) через примечания IBM?

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. Я не хочу, чтобы отправить одно письмо нескольким получателям, а я хочу, чтобы отправить 1 адрес электронной почты для каждого получателя в списке.

Тема электронной почты, тело и т. Д. Будут одинаковыми каждый раз, но я также хочу прикрепить каждую из соответствующей книги из колонки 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 

Этот код, или что-то очень похожее, должен работать.