Excel VBA генерирует электронные письма Outlook в пределах одной электронной почты - PullRequest
Новая
       38

Excel VBA генерирует электронные письма Outlook в пределах одной электронной почты

0 голосов
/ 13 сентября 2018

У меня есть следующий код, который генерирует электронные письма Outlook на основе данных из двух листов Excel

  • "Sheet1": (содержит информацию о получателе)
  • "Config" (содержит ссылки нассылки на вложения, строки темы, предложения тела письма и т. д.)

Код также создает встроенные изображения в середине тела с предложениями над / под изображением.

Проблема : код работает отлично, за исключением того, что он открывает весь контент в одном электронном письме Outlook.Мне нужно иметь возможность перебирать все элементы строки в «столбце А» и заполнять отдельные электронные письма.

Я думаю, что в коде отсутствует что-то простое.Я исследовал онлайн, но не смог найти пример со встроенными изображениями и циклом.Любая помощь приветствуется.

Пример кода: 

Sub create_emails()
Dim wb As Workbook
Dim reportsRange As Range
Dim xlCell As Range
Dim SendID
Dim Subject
Dim Body
Dim olMail As Object
Dim fileattach, ccid, wimage, sig, mimage, msub, wsub, cname, cemail, sdate, mname, mfrom, wfrom As String
Dim s1, s2, s3, s4, s5 As String
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(0)
Set Doc = olMail.GetInspector.WordEditor
Dim oAttach As Object
Set wb = ActiveWorkbook
Set reportsRange = Range("A2", Range("A" & Cells.Rows.Count).End(xlUp))

'configuration references
s1 = wb.Sheets("Config").Range("c14").Value
s2 = wb.Sheets("Config").Range("c15").Value
s3 = wb.Sheets("Config").Range("c16").Value
s4 = wb.Sheets("Config").Range("c17").Value
s5 = wb.Sheets("Config").Range("c18").Value
fileattach = wb.Sheets("Config").Range("c3").Value
ccid = wb.Sheets("Config").Range("c4").Value
mfrom = wb.Sheets("Config").Range("c5").Value
wfrom = wb.Sheets("Config").Range("c8").Value
mimage = wb.Sheets("Config").Range("c6").Value
wimage = wb.Sheets("Config").Range("c9").Value
msub = wb.Sheets("Config").Range("c7").Value
wsub = wb.Sheets("Config").Range("c10").Value
sig = wb.Sheets("Config").Range("c11").Value

'recipient references
mname = wb.Sheets("Sheet1").Range("b2").Value
sdate = wb.Sheets("Sheet1").Range("d2").Value
cname = wb.Sheets("Sheet1").Range("c2").Value
cemail = wb.Sheets("Sheet1").Range("a2").Value

For Each xlCell In reportsRange
If xlCell.Value <> "" Then
With olMail
.SentOnBehalfOfName = mfrom
.To = SendID
.CC = ccid
.Subject = msub
.Attachments.Add mimage, olByValue, 0
.Attachments.Add sig, olByValue, 0
.Attachments.Add fileattach
.HTMLBody = .HTMLBody & "<font color=""#1a5276"" face=""AmplitudeTF""> Hi " & xlCell.Offset(0, 1).Value _
            & ",<br><br>We have " & xlCell.Offset(0, 2).Value & " joining your team on " & xlCell.Offset(0, 3).Value & "!<br><br>" _
            & s1 & "<br><br>" & s2 & "<br>" _
            & "<img src='cid:mon.png'" & "width='800' height='500'><br><br>" _
            & s3 & "</font><br><font face=""AmplitudeTF"" color=""#7d6608"">" & s4 _
            & "</font><font face=""AmplitudeTF"" color=""#1a5276""><br><br>Regards,<br>" _
            & "<img src='cid:gps.png'" & "<br>" _
            & s5 & "</font></span>"
.display
End With
End If
Next xlCell
Set objOutlook = Nothing
End Sub

1 Ответ

0 голосов
/ 13 сентября 2018

Код «открывает все содержимое в одном электронном письме Outlook», поскольку создается только одно электронное письмо.

Перемещение Set olMail = otlApp.CreateItem(0) внутри цикла For Each для создания нового сообщения электронной почты каждый раз, когда xlCell не является пустым.

...