Ответить на ваш вопрос:
Я думаю, что причина того, что вы видите только одно электронное письмо, заключается в том, что вы создали только один объект OutMail. Если вы хотите выполнить цикл, вам нужно установить объект = ничего, прежде чем вы сможете создать новый:
Set OutMail = Nothing
Выглядит так, как будто вы создаете один словарь, в котором все электронные письма объединены в поле электронного письма, собраны имена и т. Д. Вам нужен способ перебирать каждое электронное письмо, которое вы хотите отправить. Вы можете создать массив словарей, создать коллекцию объектов или просмотреть диапазон, в котором хранятся данные. Зацикливание диапазона звучит так, как будто это будет наименее сложно в этом случае.
Псевдокод / код выглядит следующим образом:
'instantiate the outlook object. Use:
Set OutApp = CreateObject("Outlook.Application")
'Create your array of dictionaries or return a range with the data
'Let's call it listOfEmails
For each email in listOfEmails:
'instantiate the mail object. Use:
Set OutMail = OutApp.CreateItem(0)
'The block that creates the email:
With OutMail
.To = strEmailTo
.CC = strCCTo
.BCC = ""
.Subject = strToday & " - Agreement"
.Body = strbody
'.Attachments.Add
.Display
End With
'destroy the object when you are done with that particular email
Set OutMail = Nothing
Next email
Set OutApp = Nothing
Некоторые общие советы:
Разбиение вашего кода на более мелкие части может облегчить исправление и чтение. Это также делает его более пригодным для повторного использования как для этого проекта, так и для будущих проектов.
Я включил этот отзыв, потому что он также облегчает вопросы здесь.
Например:
Функция для проверки, открыт ли Outlook:
Function isOutlookOpen() As Boolean
'returns true or false if Outlook is open
Dim OutApp As Object
On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
If OutApp Is Nothing Then
isOutlookOpen = False
Else: isOutlookOpen = True
End If
On Error GoTo 0
End Function
Подпрограмма для отправки электронного письма, по которому можно позвонить из другого подпрограммы:
Sub sendEmail(ByVal recTO As String, ByVal subjectContent As String, ByVal bodyContent As String)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = recTO
'.CC = ""
'.BCC = ""
.subject = subjectContent
.body = bodyContent '.HTMLBody
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Функция для возврата диапазона данных:
Function dataRange() As Range
'Returns the range where the data is kept
Dim ws As Worksheet
Dim dataRng As Range
Dim lastRow As Integer
Dim rng As Range
Set ws = Workbooks("outlookEmail.xlsm").Sheets("dataSheetName")
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
'still select where the data should go if the data range is empty
If lastRow = 2 Then
lastRow = lastRow + 1
End If
Set dataRange = Range("B3", "G" & lastRow)
End Function
Подпрограмма, чтобы собрать все вместе:
Sub main()
'This sub does more than one thing, but I'm asuming it's extremely custom ans still relatively short
Dim data As Range
Dim subj As String
Dim recEmail As String
Dim body As String
Dim Row As Range
'check if data exists. Exit the sub if there's nothing
Set data = dataRange
If dataRange.Cells(1, 1).Value = "" Then
MsgBox "Data is empty"
Exit Sub
End If
'Loop through the data and send the email.
For Each Row In data.Rows
'Row is still a range object, so you can access the ranges inside of it like you normally would
recEmail = Row.Cells(1, 2).Value
If recEmail <> "" Then 'if the email is not blank, send the email
subj = Format(Date, "mm.dd.yy") & " - Agreement"
body = "Dear " & Row.Cells(1, 4).Value & "," & vbNewLine & vbNewLine & _
"Say Hello World!" & vbNewLine & vbNewLine & _
"Kind Regards," & vbNewLine & _
"Mr A Nother"
Call sendEmail(recEmail, subj, body)
End If
Next Row
End Sub
Очень важно:
Спасибо Рону де Брюину за то, что он научил меня отправлять электронные письма из Outlook, используя код в Excel VBA