问题
My mails in Outlook has all specific subjects. I have a Excel Sheet which has subject and Folder Name.
I have already this code from 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
I want the code to read the active sheet columns, as follow:
Subject.mail folder_name
A 1
B 2
C 3
For example Mail in the Inbox with subject "A" then it has to place that mail in folder "1".
How do I loop? to look at the Sheet1 and to read to which sub folder it has to move ?
回答1:
You have few options to do this, the painless one is to run Outlook VBA code from inside outlook so you don't need to go through a lot of referencing problem, but at the same time if you are insisting in having your list of subjects and folder in an Excel file, then it is better to run it from Excel, but here is the issue: You'd better not try to run the code from Excel because Microsoft is not supporting that method, so the best way is to write the code in Excel VBA, and again you can do late (runtime) binding or early binding, but I prefer early binding to use intellisence for better referencing outlook objects and avoid late binding performance and/or debugging problems.
Here is the code and how you should use it:
Go to the excel file that you have your subject and folders list or create a new one. Hit ALT+F11 to go to VBE. On the left panel (project explorer) right click and insert a module. Paste this code in there:
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
Set Reference:
To use outlook objects, in Excel VBE go to Tools, References and check Microsoft Outlook object library.
Set Excel Sheet:
In an Excel sheet, create a table with two columns that the first column contains email subjects and the second column contains folders to which you want those emails to be moved.
Then, insert a shape and right click on that and Assign a Macro, find the name of the macro (MoveEmailsToFolders) and click ok.
Suggestions:
You can develop the code more to disregard matchcase. To do that replace this line:
arr(i, 1) = Item.Subject
with:
Ucase(arr(i, 1)) = Ucase(Item.Subject)
Also, you can move the emails that contain the subject rather than matching an exact title, for example if an email subject had "test", or begins with "test", or ends with "test", then move it to the corresponding folder. Then, the comparison clause would be:
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
Hope this helps! Please hit the check mark to make this as the right answer to your questions if it did
回答2:
I would use an explicit reference to your sheet instead of ActiveSheet unless you are actually running the Macro on a bunch of different sheets. And I'm just assuming your data is in column A and B and starts at row 2 for examples sake. This is how you would loop through your data and trying to match the subject, then move it to a folder with the name in the next column if it matches.
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
There are ways you could check without using a loop as well such as the Find method
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
回答3:
Use Do Until IsEmpty loop, Make sure to set Excel Object Referees...
See Example on how to loop from 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
来源：https://stackoverflow.com/questions/41130247/how-can-i-move-mails-items-from-outlook-inbox-with-specific-subject-to-specific