Отправка электронных писем различным получателям с различными типами сообщений - список элементов с другим уровнем содержания - PullRequest
Новая
       7

Отправка электронных писем различным получателям с различными типами сообщений - список элементов с другим уровнем содержания

0 голосов
/ 20 апреля 2020

Я пишу из Испании с небольшой проблемой, которая у меня есть в моем макросе. Я должен признать, что я все еще изучаю VBA, пробуя разные решения на разных форумах, но некоторые вещи для меня загадочны.

Мой проект - это макрос для автоматической отправки электронных писем на основе определенной таблицы с данными - эта таблица включена в текст сообщения. Мой макрос прекрасно работает до одной точки: я могу отправлять электронные письма определенному списку получателей, фильтруя таблицу данных, создавая список элементов - имя получателя. К сожалению, я должен включить другое условие в фильтр, который должен определить тип сообщения, которое будет отправлено. Поэтому мне пришлось бы создать два фильтра, чтобы иметь два уровня списка содержимого. Как и на рисунке ниже, первый уровень списка содержимого - это столбец «F» - название места / получателя, а второй - столбец «N» типа сообщения.

Columns to be filtered

Таким образом, для каждого местоположения в столбце «F» на самом деле нужно отправить 3 типа сообщений, которые можно поместить в столбец «N».

Items

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

Sub SendMail()

Dim OutApp As Object
Dim OutMail As Object
Dim list As Object, item As Variant
Set list = CreateObject("System.Collections.ArrayList")
Dim rng As Range
Dim StrBodyStart As String
Dim StrBodyEnd As String

With Hoja7
    For Each item In .Range("F2", .Range("F" & .Rows.Count).End(xlUp))
        If Not list.Contains(item.Value) Then list.Add item.Value
    Next
End With

For Each item In list
    Sheets("Destino").Select
    ActiveSheet.Range("$A:$F").AutoFilter Field:=6, Criteria1:=item

    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Set rng = Selection


    'I need the macro to copy the item to another Sheet("Contactos") this is where I cross the information of the location name with corresponding email address - preferably the type of the message would be copied to cell C1 in sheet "Contactos".
    Sheets("Contactos").Select
    If IsNull(item) Then Worksheets("Contactos").Range("A1").Value = 0 Else
    Worksheets("Contactos").Range("A1").Value = item

    'Create email in Outlook
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.logon
    Set OutMail = OutApp.CreateItem(0)

    'These are two parts of the message that are going to be copied to the Outlook email
    StrBodyStart = Worksheets("Contactos").Range("D1").Value
    StrBodyEnd = Worksheets("Contactos").Range("E1").Value

    With OutMail
        .To = Worksheets("Contactos").Range("B1").Value
        .CC = Worksheets("Contactos").Range("F1").Value
        .Subject = "Test email " & item & Format(Date, " ddmmyyyy")
        .HTMLBody = StrBodyStart & RangetoHTML(rng) & StrBodyEnd
        .Send

    End With
    On Error GoTo 0

    Set rng = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing

Next

    ThisWorkbook.Save

End Sub

Function RangetoHTML(rng As Range)
'This function copies the table of data to use it for the message.

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to paste the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Если у вас, ребята, есть какие-либо Предложения по созданию второго уровня списка здесь я был бы более чем благодарен. Я пытался добавить аналогичный l oop, как для первого списка элементов, но макрос не работал. Я буду продолжать расследование, и если что-то появится, я обновлю пост. Большое спасибо заранее и хорошего дня.

...