Question

我想将一些邮件从收件箱移到subfolder，但是这段代码（我从其他论坛复制过的）无效。你能告诉我出了什么问题吗？你认为它不起作用是因为我在这个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

Answer 1

您的选择案例未正确设置 -

Case "bb"应为Case "bb@gmail.com"＆amp; Case "aa"应为Case "aa@gmail.com"

Set SubFolder = Inbox.Folders("BB") BB也应该是您的子文件夹名称

__

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宏移动电子邮件

1 个答案: