Sub 筛选OutLook主题并转发()

    On Error Resume Next

    Dim OutApp As Application

    Set OutApp = Application

    Dim OutMail As MailItem

    Dim OneAccount As Account

    Dim UsingAccount As Account

    Dim OutNameSpace As NameSpace

    Dim OneFolder As Folder

    Dim subFolder As Folder

    Dim OneBody As String

    Dim ToName As String

    Dim FwdItem As MailItem

    Dim NewBody As String

    '要在OutLook里配置一个POP3的账户 用来发送邮件

    For Each OneAccount In Application.Session.Accounts

        If OneAccount.AccountType = olPop3 Then

            Set UsingAccount = OneAccount    '找到账户

            Debug.Print "测试账户>>"; UsingAccount.UserName

            Exit For

        End If

    Next OneAccount

    Set OutNameSpace = OutApp.GetNamespace("MAPI")

    For Each OneFolder In OutNameSpace.Folders

        If OneFolder.Name = "next@126.com" Then    '此处改为你收件OutLook的账户名（就是收到对不起XXX的那个邮箱名称）

            For Each subFolder In OneFolder.Folders    '循环所有的文件夹

                For Each OutMail In subFolder.Items    '循环所有邮件

                    Debug.Print OutMail.Subject

                    If InStr(1, OutMail.Subject, "对不起") > 0 Then    '如果标题含有对不起三个字

                        ToName = Split(outMailSubject, "-")(0)    '对不起，XXX后面是什么符号，  引号内则填什么符号  比如横杠-

                        ToName = Split(ToName, "，")(1)    '对不起和XXX之间什么符号，引号内就填什么符号 比如中文 逗号，

                        Set FwdItem = OutMail.Forward    '转发

                        '构建新的邮件内容

                        NewBody = "Hello " & ToName & vbCrLf

                        NewBody = NewBody & "        Your payment to " & ToName & " is declined" & vbCrLf

                        NewBody = NewBody & "Hi hi" & vbCrLf

                        NewBody = NewBody & FwdItem.Body

                        FwdItem.Recipients.Add ("8485@qq.com")    '填写转发地址

                        FwdItem.Recipients.Add ("7866@qq.com")    '添加更多的转发地址 就再复制一行

                        FwdItem.Subject = "Hello " & ToName  '转发的标题

                        FwdItem.Body = NewBody    '转发的内容

                        FwdItem.SendUsingAccount = UsingAccount    '发送使用的账户

                        FwdItem.Send    '发送

                    End If

                Next

            Next

        End If

    Next

    Set OutApp = Nothing

    Set OutNameSpace = Nothing

    Set OutMail = Nothing

    Set OneFolder = Nothing

    Set subFolder = Nothing

    Set UsingAccount = Nothing

End Sub