在 Outlook 2013 中按 Alt F11 打开 VBA 编辑器。在左侧项目窗口中展开 Project1 Microsoft Outlook Objects ThisOutlookSession。将以下代码粘贴到右侧的代码窗口中ThisOutlookSession-NewMailEx事件驱动方案完整代码 功能收件人仅有自己zhangsan在抄送中 → 自动移动到指定文件夹 无需创建规则无需运行脚本选项 PrivateSubApplication_NewMailEx(ByValEntryIDCollectionAsString)OnErrorGoToErrHandlerDimarrIDs()AsStringDimiAsLongDimobjMailAsObjectarrIDsSplit(EntryIDCollection,,)ForiLBound(arrIDs)ToUBound(arrIDs)SetobjMailApplication.Session.GetItemFromID(arrIDs(i)) 仅处理邮件项跳过会议请求、通知等IfTypeName(objMail)MailItemThenMoveMailIfOnlyMeAndZhangsanCCobjMailEndIfSetobjMailNothingNextiExitSub:ExitSubErrHandler:Debug.PrintNewMailEx Error: Err.Number - Err.DescriptionResumeExitSubEndSub 核心判断与移动逻辑 PublicSubMoveMailIfOnlyMeAndZhangsanCC(ByValMyMailAsMailItem)OnErrorGoToErrHandlerDimobjRecipAsRecipientDimbOnlyMeAsBooleanDimbZhangsanInCCAsBooleanDimtargetFolderAsMAPIFolderDimtoCountAsLongDimmyAddressAsString 【配置区】请根据实际情况修改以下两个参数 ConstTARGET_FOLDER_PATHAsString个人文件夹\待处理邮件 目标文件夹路径相对于邮箱根目录用\分隔层级ConstCC_NAMEAsStringzhangsan 抄送人匹配关键字不区分大小写模糊匹配 获取当前用户的SMTP地址 myAddressOnErrorResumeNextmyAddressApplication.Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddressIfmyAddressThenmyAddressApplication.Session.CurrentUser.AddressOnErrorGoToErrHandler---条件1检查收件人是否【仅有自己】---bOnlyMeTruetoCount0ForEachobjRecipInMyMail.RecipientsIfobjRecip.TypeolToThentoCounttoCount1 比较地址兼容Exchange和POP3/IMAPIfLCase(GetRecipientSMTP(objRecip))LCase(myAddress)And_LCase(objRecip.Address)LCase(myAddress)ThenbOnlyMeFalseExitForEndIfEndIfNextTo收件人必须恰好为1个IftoCount1ThenbOnlyMeFalse---条件2检查抄送人中是否包含 zhangsan---bZhangsanInCCFalseForEachobjRecipInMyMail.RecipientsIfobjRecip.TypeolCCThenIfInStr(1,objRecip.Name,CC_NAME,vbTextCompare)0Or_InStr(1,objRecip.Address,CC_NAME,vbTextCompare)0ThenbZhangsanInCCTrueExitForEndIfEndIfNext---两个条件同时满足时执行移动---IfbOnlyMeAndbZhangsanInCCThenSettargetFolderGetFolderPath(TARGET_FOLDER_PATH)IfNottargetFolderIsNothingThenMyMail.MovetargetFolderDebug.PrintMoveMail: 邮件已移动到 [TARGET_FOLDER_PATH] | 主题: MyMail.SubjectElseDebug.PrintMoveMail: ⚠ 未找到目标文件夹 [TARGET_FOLDER_PATH]EndIfEndIfExitSub:SetobjRecipNothingSettargetFolderNothingExitSubErrHandler:Debug.PrintMoveMail Error: Err.Number - Err.DescriptionResumeExitSubEndSub 辅助函数通过多级路径获取文件夹对象 PrivateFunctionGetFolderPath(ByValFolderPathAsString)AsMAPIFolderOnErrorGoToErrHandlerDimfolders()AsStringDimiAsLongDimnsAsNameSpaceDimfldAsMAPIFolderSetnsApplication.GetNamespace(MAPI)foldersSplit(FolderPath,\) 从邮箱根目录开始查找收件箱的父级即为邮箱根目录 Set fld ns.GetDefaultFolder(olFolderInbox).Parent For i LBound(folders) To UBound(folders) If Trim(folders(i)) ThenSetfldfld.Folders(Trim(folders(i)))EndIfNextiSetGetFolderPathfldExitFunctionErrHandler:SetGetFolderPathNothingEndFunction 辅助函数安全获取收件人的SMTP地址 PrivateFunctionGetRecipientSMTP(recipAsRecipient)AsStringOnErrorResumeNextDimexUserAsExchangeUserSetexUserrecip.AddressEntry.GetExchangeUserIfNotexUserIsNothingThenGetRecipientSMTPexUser.PrimarySmtpAddressElseGetRecipientSMTPrecip.AddressEndIfOnErrorGoTo0EndFunction修改配置区将 TARGET_FOLDER_PATH 改为你实际的目标文件夹路径。例如目标文件夹是收件箱下的zhangsan邮件则改为 “收件箱\zhangsan邮件”。保存 VBA 项目按 Ctrl S。设置宏安全文件 信任中心 信任中心设置 宏设置 → 选择启用所有宏或为所有宏启用通知。重启 OutlookNewMailEx 事件只有在 Outlook 重新启动后才会注册生效。删除旧规则如果之前创建了相关的规则请在规则和警报中将其删除避免重复触发。发测试邮件验证给自己发一封邮件并抄送 zhangsan观察是否自动移动。可在 VBA 编辑器中按 Ctrl G 打开立即窗口查看调试输出。