Outlook中有几个邮件帐户。
有一个代码可以生成一个消息框,其中包含主邮箱中新邮件的属性。它适用于我的主要邮件帐户。
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
MessageInfo = "" & _
"Sender : " & Item.SenderEmailAddress & vbCrLf & _
"Sent : " & Item.SentOn & vbCrLf & _
"Received : " & Item.ReceivedTime & vbCrLf & _
"Subject : " & Item.Subject & vbCrLf & _
"Size : " & Item.Size & vbCrLf & _
"Message Body : " & vbCrLf & Item.Body
Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
还有另一个邮箱“ Specification Estimation RU41”。我的任务是为该邮箱收到新的传入邮件相同的弹出消息。我换了线
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
与
Set inboxItems = objectNS.Folders("Specification Estimation RU41") _
.Folders("Inbox").Items
这样整个代码看起来像这样:
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.Folders("Specification Estimation RU41") _
.Folders("Inbox").Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
MessageInfo = "" & _
"Sender : " & Item.SenderEmailAddress & vbCrLf & _
"Sent : " & Item.SentOn & vbCrLf & _
"Received : " & Item.ReceivedTime & vbCrLf & _
"Subject : " & Item.Subject & vbCrLf & _
"Size : " & Item.Size & vbCrLf & _
"Message Body : " & vbCrLf & Item.Body
Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
但这是行不通的。没有错误消息,但是对新邮件没有反应。
我该如何运作?
您是否尝试过使用NameSpace.GetSharedDefaultFolder方法(Outlook)MSDN
在委派方案中使用此方法,在该方案中,一个用户已将另一用户的一个或多个默认文件夹委派给另一用户
例
Private WithEvents RU41_Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Set olNs = Application.GetNamespace("MAPI")
Dim RU41_Recip As Outlook.Recipient
Set RU41_Recip = olNs.CreateRecipient("0m3r@email.com")
Dim RU41_Inbox As Outlook.MAPIFolder
Set RU41_Inbox = olNs.GetSharedDefaultFolder(RU41_Recip, olFolderInbox)
Set RU41_Items = RU41_Inbox.Items
End Sub
Private Sub RU41_Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
DoEvents
'''code here
End If
End Sub
是的,这可行,谢谢!