如何将Outlook收件箱中的邮件项目移动到特定文件夹/子文件夹的特定主题？

时间：2016-12-13 20:45:30

标签： excel vba outlook outlook-vba

我在Outlook中的邮件包含所有特定主题。我有一个Excel表格，其中包含主题和文件夹名称。

我已经从Stackoverflow

获取此代码 
Option Explicit
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 lngCount As Long
    Dim Items As Outlook.Items

    On Error GoTo MsgErr
    '// Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

    '// Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items.Item(lngCount)

        Debug.Print Item.Subject

        If Item.Class = olMail Then
            '// Set SubFolder of Inbox
            Set SubFolder = Inbox.Folders("Temp")
            '// Mark As Read
            Item.UnRead = False
            '// Move Mail Item to sub Folder
            Item.Move SubFolder
        End If
    Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = 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

我希望代码能够读取活动工作表列，如下所示：

Subject.mail   folder_name
    A                1
    B                2
    C                3

例如，收件箱中的主题为“A”的邮件，则必须将该邮件放在文件夹“1”中。

我如何循环？查看Sheet1并读取它必须移动到哪个子文件夹？

3 个答案:

答案 0 :(得分：1)

你没有什么选择可以做到这一点，无痛的选择是从内部运行Outlook VBA代码，这样你就不需要经历很多引用问题，但同时如果你坚持要求将您的主题和文件夹列在Excel文件中，然后最好从Excel运行它，但问题是：您最好不要尝试从Excel运行代码，因为Microsoft不支持该方法，所以最好的方法是在Excel VBA中编写代码，再次你可以做晚（运行时）绑定或早期绑定，但我更喜欢早期绑定使用intellisence来更好地引用outlook对象并避免后期绑定性能和/或调试问题

以下是代码以及如何使用它：

转到包含主题和文件夹列表的Excel文件或创建一个新文件。点击ALT + F11进入VBE。在左侧面板（项目浏览器）上右键单击并插入模块。将此代码粘贴在那里：

Option Explicit
Public Sub MoveEmailsToFolders()
    'arr will be a 2D array sitting in an Excel file, 1st col=subject, 2nd col=folder name
    '   // Declare your Variables
    Dim i As Long
    Dim rowCount As Integer
    Dim strSubjec As String
    Dim strFolder As String

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim myFolder As Outlook.Folder
    Dim Item As Object

    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder

    Dim lngCount As Long
    Dim Items As Outlook.Items
    Dim arr() As Variant 'store Excel table as an array for faster iterations
    Dim WS As Worksheet

    'On Error GoTo MsgErr

    'Set Excel references
    Set WS = ActiveSheet
    If WS.ListObjects.Count = 0 Then
        MsgBox "Activesheet did not have the Excel table containing Subjects and Outlook Folder Names", vbCritical, "Error"
        Exit Sub
    Else
        arr = WS.ListObjects(1).DataBodyRange.Value
        rowCount = UBound(arr, 2)
        If rowCount = 0 Then
            MsgBox "Excel table does not have rows.", vbCritical, "Error"
            Exit Sub
        End If
    End If


    'Set Outlook Inbox Reference
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set myFolder = olNs.GetDefaultFolder(olFolderInbox)

    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

      '   // Loop through the Items in the folder backwards
      For lngCount = Items.Count To 1 Step -1
        strFolder = ""
        Set Item = Items.Item(lngCount)

        'Debug.Print Item.Subject

        If Item.Class = olMail Then
            'Determine whether subject is among the subjects in the Excel table
            For i = 1 To rowCount
                If arr(i, 1) = Item.Subject Then
                    strFolder = arr(i, 2)

                    '// Set SubFolder of Inbox, read the appropriate folder name from table in Excel
                    Set SubFolder = Inbox.Folders(strFolder)
                    '// Mark As Read
                    Item.UnRead = False
                    '// Move Mail Item to sub Folder
                    Item.Move SubFolder
                    Exit For
                    End If
                Next i
            End If

      Next lngCount

  MsgErr_Exit:
    Set Inbox = Nothing
      Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = 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

设置参考：

要使用Outlook对象，请在Excel VBE中转到“工具”，“引用”并检查Microsoft Outlook对象库。

设置Excel工作表：

在Excel工作表中，创建一个包含两列的表，第一列包含电子邮件主题，第二列包含要将这些电子邮件移动到的文件夹。

然后，插入一个形状并右键单击它并指定一个宏，找到宏的名称（MoveEmailsToFolders）并单击确定。

<强>建议：

您可以更多地开发代码以忽略matchcase。为此，请替换此行：

arr(i, 1) = Item.Subject

使用：

Ucase(arr(i, 1)) = Ucase(Item.Subject)

此外，您可以移动包含主题的电子邮件，而不是匹配确切的标题，例如，如果电子邮件主题具有＆＃34; test＆＃34;，或者以＆＃34; test＆＃34;开头，或者以＆＃34; test＆＃34;结束，然后将其移动到相应的文件夹。然后，比较子句将是：

 If arr(i, 1) Like Item.Subject & "*" Then 'begins with
 If arr(i, 1) Like  "*" & Item.Subject & "*" Then 'contains
 If arr(i, 1) Like  "*" & Item.Subject Then 'ends with

希望这有帮助！如果确实如此，请点击复选标记使其成为您问题的正确答案

答案 1 :(得分：0)

除非您在一堆不同的工作表上实际运行宏，否则我会使用对工作表的显式引用而不是ActiveSheet。我只是假设你的数据在A列和B列，并从第2行开始，例如。这是循环数据并尝试匹配主题的方式，然后将其移动到下一列中具有名称的文件夹（如果匹配）。 

If Item.Class = olMail Then

    For i = 2 To ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row

        If ActiveSheet.Range("A" & i).Value = Item.Subject Then
              '// Set SubFolder of Inbox
            Set SubFolder = Inbox.Folders(ActiveSheet.Range("B" & i).Value)
               '// Mark As Read
            Item.UnRead = False
               '// Move Mail Item to sub Folder
            Item.Move SubFolder
        End If

    Next

End If

有些方法可以在不使用循环的情况下进行检查，例如Find方法

Dim rnFind As Range

If Item.Class = olMail Then

    Set rnFind = ActiveSheet.Range("A2", ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp)).Find(Item.Subject)

        If Not rnFind Is Nothing Then
              '// Set SubFolder of Inbox
            Set SubFolder = Inbox.Folders(rnFind.Offset(, 1).Value)
               '// Mark As Read
            Item.UnRead = False
               '// Move Mail Item to sub Folder
            Item.Move SubFolder
        End If

End If

答案 2 :(得分：0)

使用 Do Until IsEmpty loop ，确保设置Excel对象裁判......

请参阅有关如何从Outlook循环的示例... 

Option Explicit
Public Sub Move_Items()
    '// Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Items As Outlook.Items
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim Item As Object
    Dim ItemSubject As String
    Dim SubFldr As String
    Dim lngCount As Long
    Dim lngRow As Long

    On Error GoTo MsgErr
    '// Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

    '// Excel Book Reference
    Set xlApp = New Excel.Application
    Set xlBook = xlApp.Workbooks.Open("C:\Temp\Book1.xlsx") ' Excel Book Path

    lngRow = 2 ' Start Row

    With xlBook.Worksheets("Sheet1") ' Sheet Name

        Do Until IsEmpty(.Cells(lngRow, 1))
            ItemSubject = .Cells(lngRow, 1).Value ' Subject
            SubFldr = .Cells(lngRow, 2).Value ' Folder Name

            '// Loop through the Items in the folder backwards
            For lngCount = Items.Count To 1 Step -1
                Set Item = Items.Item(lngCount)

                If Item.Class = olMail Then

                    If Item.Subject = ItemSubject Then

                        Debug.Print Item.Subject
                        Set SubFolder = Inbox.Folders(SubFldr) ' Set SubFolder

                        Debug.Print SubFolder
                        Item.UnRead = False ' Mark As Read
                        Item.Move SubFolder ' Move to sub Folder

                    End If

                End If
            Next
            lngRow = lngRow + 1
        Loop
    End With

    xlBook.Close

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing
    Set xlApp = Nothing
    Set xlBook = 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
相关问题
最新问题