Outlook的自定义主题行

Question

我正在自动化Excel数据库,因此通过单击按钮,宏将使用该特定行条目的电子邮件,主题和正文自动发送电子邮件.

例如,我想按下按钮,宏会自动将电子邮件发送到填充红色的单元格,并将其发送到具有自定义主题的各自电子邮件中.

我在网上找到了一些代码,一旦按下,就会发送一封自动发送的电子邮件.但是,主题行不是自定义的.

这是我正在处理的代码:

Sub SendReminderMail()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
Dim SUBJECT As String

Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)

With OutLookMailItem
.SUBJECT = ""
For iCounter = 1 To WorksheetFunction.CountA(Columns(4))
If SUBJECT = "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
.SUBJECT = Cells(iCounter, 6).Value
ElseIf SUBJECT <> "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
SUBJECT = SUBJECT & ";" & Cells(iCounter, 6).Value

End If
Next iCounter

MailDest = ""
For iCounter = 1 To WorksheetFunction.CountA(Columns(4))
If MailDest = "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
MailDest = Cells(iCounter, 4).Value
ElseIf MailDest <> "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then
MailDest = MailDest & ";" & Cells(iCounter, 4).Value
End If

Next iCounter


.BCC = MailDest
.Body = "Reminder: Time to contact this firm"
.Send

End With

Set OutLookMailItem = Nothing
Set OutLookApp = Nothing



End Sub

我面临的当前问题:

1. 电子邮件发送到正确的电子邮件地址,但主题始终是第6行中的主题 - "提醒给安德鲁发送电子邮件".其他联系人不会改变.我需要针对每个不同联系人的每封电子邮件更改主题.

2. 我注意到如果我有不同的联系人姓名,但他们列在同一个电子邮件地址下,那么宏只会用同一封电子邮件发送到第一个条目,而不是第二个.

任何帮助表示赞赏.谢谢

Answer 1

很想放弃评论,但仍有可能你会错过XD

Sub SendReminderMail()

Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim lastRow As Long
Dim iCounter As Long
Dim MailDest As String
Dim subj As String

lastRow = ThisWorkbook.WorkSheets("Sheet6").Cells(Rows.Count, "D").End(xlUp).Row 'change worksheet

For iCounter = 2 To lastRow

    Set OutLookApp = CreateObject("Outlook.application")
    Set OutLookMailItem = OutLookApp.CreateItem(0)

    With OutLookMailItem
        subj = ""
        MailDest = ""

        If Cells(iCounter, 3) = "Send Reminder" Then
            subj = Cells(iCounter, 6).Value
            MailDest = Cells(iCounter, 4).Value

            .BCC = MailDest
            .SUBJECT = subj
            .Body = "Reminder: Time to contact this firm"
            .Send
        End If

    End With

Next iCounter

End Sub