Do for all open emails and move to a folder

问题

Our company is using the Enterprise Vault system to store archived emails. 10% of the time I am able to retrieve my email. So I am making the switch to store them on my computer.

Here is what I am going to do:

1. Count x number of emails in "archived" folder
2. Open n email item in "archived" folder
3. copy n email item
4. move n email item to "computer" folder (note: the email must be open and moved.
5. close n email window
6. Repeat until n = x

I have a .pst folder on my computer.

Could someone help me develop the simplest code to accomplish step 2?

This is what I have so far...

Sub MoveToFolder()

Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim x As Integer
Dim iCount As Integer

mailboxNameString = "Emails Stored on Computer"
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders(mailboxNameString).Folders("Archived")
Set olCompFolder = olNameSpace.Folders(mailboxNameString).Folders("Computer")

'Make some kind of loop that counts the emails in the folder "Computer"
'opens it up, and then moves it to the folder "Archived"
Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
Set myCopiedInspectors = myInspectors.copy
myCopiedInspectors.Move (olCompFolder)
'next email

回答1:

Well Guys, guess I'm teaching myself after all. This works for what i wanted.

Sub MoveToFolder()

Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim M As Integer
Dim iCount As Integer

Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Archived")
Set olCompFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Computer")


For M = 1 To olArcFolder.items.Count
    Set myItem = olArcFolder.items(M)
    myItem.Display
    Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
    Set myCopiedInspectors = myInspectors.copy
    myCopiedInspectors.Move olCompFolder
    myInspectors.Close olDiscard
Next M



End Sub

来源：https://stackoverflow.com/questions/17198895/do-for-all-open-emails-and-move-to-a-folder