仅当我将新邮件传输给自己时,在收到电子邮件时运行的Outlook脚本才起作用

时间:2018-09-20 13:51:37

标签: vba outlook

我编写了一个代码,该代码将在特定文件夹中接收传入的电子邮件(首先创建一条规则,以便将邮件移至该文件夹,然后启动脚本)。

问题在于规则有效(将邮件移至文件夹),但脚本无效。

问题是,当我收到新邮件并将其发送给自己时(我的电子邮件也在规则的收件人中),该脚本可以正常工作。

这是我认为可能是错误的代码的开头。

Sub Script(item As Outlook.MailItem) 


Dim strMailID As String
Dim objMail As Outlook.MailItem
Dim objNamespace As Outlook.NameSpace

strMailID = item.EntryID
Set objNamespace = Application.GetNamespace("MAPI")
Set objMail = objNamespace.GetItemFromID(strMailID)
Dim objpf As MAPIFolder

If objMail.MessageClass = "IPM.Note" Then

任何帮助将不胜感激

1 个答案:

答案 0 :(得分:0)

您需要将事件侦听器添加到默认的本地收件箱,它与Outlook 2016一起使用。

此代码会将事件侦听器添加到默认的本地收件箱。将对收到的电子邮件采取措施。您需要在下面的代码中添加所需的操作:

                Private WithEvents Items As Outlook.Items 
                Private Sub Application_Startup() 
                Dim olApp As Outlook.Application 
                Dim objNS As Outlook.NameSpace 
                Set olApp = Outlook.Application 
                Set objNS = olApp.GetNamespace("MAPI") 
                ' default local Inbox
                Set Items = objNS.GetDefaultFolder(olFolderInbox).Items 
                End Sub
                Private Sub Items_ItemAdd(ByVal item As Object) 

                On Error Goto ErrorHandler 
                 Dim Msg As Outlook.MailItem 
                 If TypeName(item) = "MailItem" Then
                Set Msg = item 
                ' ******************
                ' do something here
                ' ******************
                End If
                ProgramExit: 
                  Exit Sub
                ErrorHandler: 
                MsgBox Err.Number & " - " & Err.Description 
                Resume ProgramExit 
                End Sub

将代码粘贴到ThisOutlookSession模块中之后,必须重新启动Outlook。