20170711筛选OutLook主题并转发

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