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