通过 senderemailaddress Outlook 宏移动电子邮件 [英] Move e-mails by senderemailaddress outlook macro
问题描述
我想将收件箱中的一些邮件移动到子文件夹
,但此代码(我从其他论坛复制的)不起作用.你能告诉我出了什么问题吗?你认为它不工作是因为我在这个 Outlook 中有两个不同的帐户?
I want to move some messages from Inbox to a subfolder
but this code (that I have copied from other forum) is not working. Can you tell me what is going wrong? Do you think it is not working because of the fact that I have two different accounts in this Outlook?
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim Items As Outlook.Items
Dim lngCount As Long
On Error GoTo MsgErr
Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = Application.ActiveExplorer.CurrentFolder
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Inbox.Items.Count To 1 Step -1
Set Item = Inbox.Items.Item(lngCount)
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
'// Email_One
Case "bb"
// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("BB")
Set Item = Items.Find("[SenderEmailAddress] = 'bb@gmail.com'")
If TypeName(Item) <> "Nothing" Then
// Mark As Read
Item.UnRead = False
// Move Mail Item to sub Folder
Item.Move SubFolder
End If
'// Email_Two
Case "aa"
'// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("AA")
Set Item = Items.Find("[SenderEmailAddress] = 'aa@gmail.com'")
If TypeName(Item) <> "Nothing" Then
'// Mark As Read
Item.UnRead = False
'// Move Mail Item to sub Folder
Item.Move SubFolder
End If
Case Else:
Exit Sub
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
推荐答案
您的 Select Case 设置不正确-
Your Select Case is not set correctly-
Case "bb"
应该是 Case "bb@gmail.com"
&Case "aa"
应该是 Case "aa@gmail.com"
Case "bb"
should be Case "bb@gmail.com"
& Case "aa"
should be Case "aa@gmail.com"
also Set SubFolder = Inbox.Folders("BB")
BB
应该是你的子文件夹名称
also Set SubFolder = Inbox.Folders("BB")
BB
should be your subfolder name
__
Option Explicit
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Folder As Outlook.MAPIFolder '<- has been added
Dim olNs As Outlook.NameSpace
Dim Item As Outlook.MailItem
Dim Items As Outlook.Items
Dim lngCount As Long
' On Error GoTo MsgErr
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Folder = Application.Session.PickFolder
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Inbox.Items.Count To 1 Step -1
Set Item = Inbox.Items.Item(lngCount)
Debug.Print Item.Subject
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "bb@gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'bb@gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
' // Email_Two
Case "aa@gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'aa@gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
这篇关于通过 senderemailaddress Outlook 宏移动电子邮件的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!