Question

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

我的经理现在要我在这个宏下附上特定电子邮件主题（回复历史）的对话。因此，当收件人收到发件人的电子邮件并通过按下按钮回复时，电子邮件应附加到相同的电子邮件主题，并在双方之间添加历史记录，而不仅仅是工作簿文档。< / p>

我发现了这个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

将电子邮件设置为回复同一电子邮件主题

2 个答案: