Vba Outlook的自定义主题行

我正在努力实现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

子发送提醒邮件（）
Dim OutLookApp作为对象
Dim OutLookMailItem作为对象
作为整数的Dim I计数器
将MailDest设置为字符串
模糊主题为字符串
设置OutLookApp=CreateObject（“Outlook.application”）
设置OutLookMailItem=OutLookApp.CreateItem（0）
使用OutLookMailItem
.SUBJECT=“”
对于iCounter=1的工作表function.CountA（第（4）列）
如果SUBJECT=“”和单元格（iCounter，4）.Offset（0，-1）=“发送提醒”，则
.SUBJECT=单元格（iCounter，6）.值
ElseIf主题“”和单元格（iCounter，4）。偏移量（0，-1）=“发送提醒”，然后
主题=主题&“；”和单元格（iCounter，6）。值
如果结束
下一个iCounter
MailDest=“”
对于iCounter=1的工作表function.CountA（第（4）列）
如果MailDest=“”和单元格（iCounter，4）.Offset（0，-1）=“发送提醒”，则
MailDest=单元格（iCounter，4）.值
ElseIf MailDest“”和单元格（iCounter，4）。偏移量（0，-1）=“发送提醒”，然后
MailDest=MailDest&“；”&单元格（iCounter，4）。值
如果结束
下一个iCounter
.BCC=MailDest
.Body=“提醒：联系本公司的时间到了”
.发送
以
Set-OutLookMailItem=无
Set-OutLookApp=无
端接头

我目前面临的问题：

电子邮件发送到正确的电子邮件地址，但主题始终是第6行的主题-“提醒发送电子邮件”。对于其他联系人，它不会改变。我需要的主题，以改变每一封电子邮件，以每个不同的联系人

我注意到，如果我有不同的联系人姓名，但它们列在同一电子邮件地址下，则宏将仅使用相同的电子邮件向第一个条目发送电子邮件，而不会向第二个条目发送电子邮件

---

感谢您的帮助。谢谢

我相信您正在寻找这两行之间的所有内容：

带有OutLookMailItem

这条线呢

以

为电子表格中的每一行运行一次，对吗？对于每一行，如果在

单元格（iCounter，4）

中有“发送提醒”文本，则需要向该人发送电子邮件

如果是这样的话，那是永远不会发生的，因为您要从1一直迭代到6

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

如果您实际上想要构建

OutlookMailItem

的

.SUBJECT

属性，您需要在它前面加上一个句点，因为您想引用

.SUBJECT

——OutlookMailItem的属性，而不是变量

SUBJECT

（顺便说一句，这很容易混淆）

其他一些注意事项：

您的

For

循环不需要从1开始，因为那是您的标题行。将来做这样的事情可能更容易：

lastRow = Range("D" & Rows.Count).End(xlUp).Row

For iCounter = 2 to lastRow step 1
  '/ VBA will iterate through each row until it hits the end
  '/ Assuming column D has data in it to your actual "last row"
Next iCounter

---

使用F8单步执行代码。打开“局部变量”窗口，观察每一步变量的变化情况。将光标悬停在黄线或任何前一行上，以查看该点上的变量/函数，或前一行完成执行时的变量/函数

特别注意你的主题变量

此位也可能没有执行您希望它执行的操作：

For iCounter = 1 To WorksheetFunction.CountA(Columns(4))

如果我把它放到一个电子表格中，在a到J列中有一堆值，然后运行这个：

Sub testing()
Dim X
X = WorksheetFunction.CountA(Columns(4))
End Sub

X是0 我猜想您希望最后一行的值在D列中

Sub lastrow()
Dim X
X = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
End Sub

这给了我19分。D列中的最后一个单元格具有值。你不想计数或计数，因为它不会计数空白。因此，您可能有20行数据，但如果D列中只有5行有值，那么您的循环将经过5次，因为它是基于带值的单元格，而不是行

主要是，如果你要经常这样做，在这样做的同时使用F8和你的View/Locals窗口，你就会开始看到哪里出了问题

然后，在尝试修改更大的复杂块之前，制作一个非常简单的子块，像这样处理单个代码块，直到您理解它为止。这将帮助你学会钓鱼

---

我没有outlook，因此无法测试您的其余代码，但即使其他一切都很完美，该块也会给您带来麻烦。

我很想省去注释，但您仍有可能错过它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

---

如果您研究发现的代码并了解它的功能，您可以轻松解决第一个问题，这是一个巨大的按钮…默认情况下不会安装Microsoft outlook对象库-我认为有几行依赖于它。你加载了吗？是的-但是代码没有按预期运行，因为

主题

标题前缺少句点。谢谢Brian！我在遗漏的一段时间里加了一句，修正了只把主题作为“提醒安德鲁发电子邮件”的问题。但是，现在所有的电子邮件主题都是“提醒发送电子邮件”Nerr；提醒发送电子邮件Roo；提醒发送电子邮件Andrew“我尝试取出代码的后半部分

ElseIf SUBJECT“”和单元格（iCounter，4）。偏移量（0，-1）=“发送提醒”，然后SUBJECT=SUBJECT&“；”&单元格（iCounter，6）.Value

但这使得主题现在都默认为第一个主题，“提醒邮件Nerr”非常感谢@findwindow，代码工作得非常完美！我非常感谢你花时间写出来。我是堆栈溢出的新手，这个社区非常棒

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