将电子邮件设置为对同一电子邮件主题的回复[重复]

Question

我之前已经成功（在 PEH 的帮助下）创建了一个宏，将地址电子邮件和工作簿附加到正确的发件人。代码在下面的链接地址Return value of dynamically determined cell ，我也会贴在下面。

我的经理现在希望我在此宏下附加特定电子邮件主题的对话（回复历史）。所以当收件人收到发件人发来的邮件并按下按钮进行回复时，邮件应附加到相同的邮件主题，并添加双方之间的历史记录，而不仅仅是工作簿文档。

我找到了这个Excel VBA, how to Reply to a specific email message ，但我无法理解如何将它设置为我自己的代码。

这可以对我拥有的东西进行吗？或者代码的结构应该改变吗？

Sub mail()

Dim A As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim wb As Workbook

Dim check

Set wb = Excel.ActiveWorkbook
Set sh1 = wb.Worksheets(1)
Set sh2 = wb.Worksheets(2)

For A = 2 To sh1.Cells(Rows.Count, "A").End(xlUp).Row
    check = Application.match(sh1.Cells(A, 1).Value, sh2.Columns(1), 0)

    If IsError(check) And Not IsEmpty(sh1.Cells(A, 1)) Then
        MsgBox "No email was found!"
    Else
        h = sh2.Cells(check, 2).Value


        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.createItem(olmailitem)
        Set wb2 = ActiveWorkbook
        wb.Save

        With OutMail
            .Display
            .To = h
            .cc = ""
            .BCC = ""
            .Subject = "Test - " 
            .htmlbody = "<p style='font-family:calibri;font-size:15'>" & "Hi " & C & "<BR/>" & "<BR/>" & "Please check the attached template." & "<br/>" & "<BR/>" & "Change data if required." & "<BR/>" & "<br/>" & "This e-mail has been automatically send! " & "<br/>" & "<br/>" & "With best regards," & "<br/>" & "<br/>"
            .attachments.Add wb2.FullName
        End With

        wb.Close
    End If
Next

End Sub

Answer 1

您可以使用.Find 方法查找特定主题，然后在找到该主题时回复该主题，如果未找到该主题，您可以创建新电子邮件。

Sub mail()

    Dim A As Long
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim wb As Workbook

    Dim check

    Set wb = Excel.ActiveWorkbook
    Set sh1 = wb.Worksheets(1)
    Set sh2 = wb.Worksheets(2)

    For A = 2 To sh1.Cells(Rows.Count, "A").End(xlUp).Row
        check = Application.Match(sh1.Cells(A, 1).Value, sh2.Columns(1), 0)

        If IsError(check) And Not IsEmpty(sh1.Cells(A, 1)) Then
            MsgBox "No email was found!"
        Else
            h = sh2.Cells(check, 2).Value


            Set OutApp = CreateObject("Outlook.Application")

            'check if we can answer
            Dim OutNs As Namespace
            Set OutNs = OutApp.GetNamespace("MAPI")
            Dim OutFldr As MAPIFolder
            Set OutFldr = OutNs.GetDefaultFolder(olFolderInbox) 'default inbox folder (where we want to search for the subject)

            Dim OutMail As Variant
            Set OutMail = OutFldr.Items.Find("[Subject] = """ & "YOUR SUBJECT YOU WANT TO ANSWER TO" & """") 'search for specific subject
            If Not (OutMail Is Nothing) Then
                'we found something to reply to
                OutMail.Reply
            Else
                'we found nothing … so create new mail
                Set OutMail = OutApp.CreateItem(olMailItem)
            End If

            Set wb2 = ActiveWorkbook
            wb.Save

            With OutMail
                .Display
                .To = h
                .CC = ""
                .BCC = ""
                .Subject = "Test - "
                .HTMLBody = "<p style='font-family:calibri;font-size:15'>" & "Hi " & c & "<BR/>" & "<BR/>" & "Please check the attached template." & "<br/>" & "<BR/>" & "Change data if required." & "<BR/>" & "<br/>" & "This e-mail has been automatically send! " & "<br/>" & "<br/>" & "With best regards," & "<br/>" & "<br/>"
                .Attachments.Add wb2.FullName
            End With

            wb.Close
        End If
    Next

End Sub

Answer 2

不要使用OutApp.createItem(olmailitem)，而是使用当前选定的电子邮件 (OutApp.ActiveExplorer.Selection(1)) 并对其调用回复 - 它将返回一个新的 MailItem 对象，其中包含适当的主题、正文和收件人。您只需要将文件附加到它。

Set OutMail = OutApp.ActiveExplorer.Selection(1).Reply
Set wb2 = ActiveWorkbook
wb.Save
With OutMail
   .attachments.Add wb2.FullName
   .Display
End With