我正在为Outlook编写一些VBA，这不是我经常做的事情。我对以下代码有一个奇怪的问题：
Sub Archive()
Dim objSourceFolder As Folder
Dim OldMessages As Outlook.Items
Dim Allmessages As Outlook.Items
Dim objMessage As MailItem
Dim dtDate As Date
Dim strDate As String
Dim strProblemFiles As String
Dim objTargetFolder As Outlook.MAPIFolder
'how old is too old? give a number in months
'-----------------------------------------------
Const iMonthAge = 6
'-----------------------------------------------
strProblemFiles = ""
'locate the sourcefolder as the inbox
Set objSourceFolder = Application.Session.GetDefaultFolder(olFolderInbox)
'locate the target folder as the only one that can work according to IT - they will make this folder consistent apparently
Set objTargetFolder = Application.Session.Folders.GetFirst
Set objTargetFolder = objTargetFolder.Folders("Archive")
'There is this crappy thing on the filtering of messages where it takes a date string, not a date. So we need to calculate and then convert
'to the format that MS lists on the MSDN site
dtDate = DateAdd("M", -iMonthAge, Now())
strDate = Format(dtDate, "ddddd h:nn AMPM")
'apply a filter to only show messages older than the specified date, which have been read.
Set Allmessages = objSourceFolder.Items
Set OldMessages = Allmessages.Restrict("[Received] <= '" & strDate & "' AND [Unread] = False")
'let the poor user know what's going on - they can bail out now if they want
If MsgBox("There are " & OldMessages.Count & " old items to archive. They will be moved from your " & objSourceFolder.Name & _
" folder to your " & objTargetFolder.Name & " folder.", vbYesNo, "Archive Files Now?") = vbYes Then
'go through all the messages in the big list of messages older than the specified date, moving them if possible.
For Each objMessage In OldMessages
If TypeName(OldMessages.GetFirst) = "MailItem" Then
'do our shizzle
Else
'PRETTY MINIMAL ERROR CATCHING NEEDS IMPROVING
'write down the name of anything that isn't mail, I guess... need to work on this
strProblemFiles = strProblemFiles + vbCrLf + objMessage.Subject
GoTo errorcatch
'GoTo CarryOn
End If
'make a note for anyone who can look
Debug.Print objMessage.Subject
If objTargetFolder.DefaultItemType = olMailItem Then
If objMessage.Class = olMail Then
'There's nothing in errorcatch, but there will be
On Error GoTo errorcatch
'Move the item if you can
objMessage.Move objTargetFolder
End If
End If
'after an error, we jump here to go to the noxt item
CarryOn:
Next
Else
'if the user doesn't want to do it, we need to shut up shop and get the hell out of here
Set objSourceFolder = Nothing
Set OldMessages = Nothing
Set objMessage = Nothing
Set objTargetFolder = Nothing
Exit Sub
End If
'now we have done the whole thing, we can wipe down for fingerprints and exit through the window
Set objSourceFolder = Nothing
Set OldMessages = Nothing
Set objMessage = Nothing
Set objTargetFolder = Nothing
'reset the errors
On Error GoTo 0
'probably not going to be any that weren't mail items, but didn't cause a real error, but I guess we should show any we skipped.
If strProblemFiles <> "" Then MsgBox strProblemFiles
Exit Sub
'pathetic
errorcatch:
GoTo CarryOn
End Sub
Function FileExists(FileName As String) As Boolean
FileExists = (Dir(FileName) <> "")
End Function
一切正常......差点儿。我第一次运行宏时，它告诉我有（例如128项准备存档。它运行，我注意到我的收件箱中仍然有旧邮件，所以我再次运行它告诉我有64项准备存档...然后32,16等每次减少找到的邮件数量。我不明白为什么会这样做。有什么想法吗？
我应该提一下，这是在使用Exchange的Outlook 2010上运行。
感谢您的关注 - 所有答案都非常感谢！
干杯， 标记
答案 0 :(得分：0)
类似的东西：
'...
Dim colMove As New Collection
'...
For Each objMessage In OldMessages
If objTargetFolder.DefaultItemType = olMailItem Then
If objMessage.Class = olMail Then colMove.Add objMessage
End If
Next
For Each objMessage In colMove
objMessage.Move objTargetFolder
Next
'...
答案 1 :(得分：0)
解释了For Each问题，此处描述了另一种移动或删除倒计数项的方法。
答案 2 :(得分：0)
Option Explicit
Sub Archive()
Dim objSourceFolder As Folder
Dim OldMessages As Outlook.Items
Dim AllMessages As Outlook.Items
Dim objMessage As Object
Dim dtDate As Date
Dim strDate As String
Dim strProblemFiles As String
Dim objTargetFolder As Outlook.MAPIFolder
Dim colMove As New Collection
Dim objFolder As Outlook.MAPIFolder
Dim lngSize As Long
Dim objAnything As Object
Dim iMaxMBSize As Integer
Dim boolSentItems As Boolean
Dim catCategory As category
' Dim boolCatExists As Boolean
' Dim iColour As Integer
Set objSourceFolder = Nothing
Set OldMessages = Nothing
Set objMessage = Nothing
Set objTargetFolder = Nothing
'iColour = 18
'we are moving files, that's all, so we don't really need to worry too much about errors - if there is a problem, we can just skip the file
'without great negative effects.
On Error Resume Next
'how old is too old? give a number in months
'-----------------------------------------------
Const iMonthAge = 6
iMaxMBSize = 50
'-----------------------------------------------
'locate the sourcefolder as the inbox
boolSentItems = (MsgBox("Your inbox will be archived." & vbCrLf & _
"Do you want to also archive sent items?", vbYesNo, "Archive Options") = vbYes)
Set objSourceFolder = Application.Session.GetDefaultFolder(olFolderInbox)
'----------------------------------------------------------------------------------------------------------------------------------------
StartAgain:
'If you wish to assign a category to the folders rather than keep the folder structure when you archive, use this code and some other bits
'later on, which mention the categories and the variables mentioned here.
'Set objSourceFolder = Application.Session.GetDefaultFolder(olFolderInbox)
' boolCatExists = False
'For Each catCategory In Application.Session.Categories
' If catCategory.Name = "Archived from " & objSourceFolder.Name Then
' boolCatExists = True
' End If
'Next
'If boolCatExists = False Then
' Application.Session.Categories.Add "Archived from " & objSourceFolder.Name, iColour
'End If
'locate the target folder, which must be either in the same level as the inbox or lower
'----------------------------------------------------------------------------------------------------------------------------------------
Set objTargetFolder = SearchFolders(objSourceFolder.Parent, "Archive")
'if the target folder was not found, then we need to make it, in the root directory (the same level as the inbox - this is stipulated by IT)
If objTargetFolder Is Nothing Then
Set objTargetFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add("Archive")
End If
'we are going to maintain the folder structure in the archive folder, for the inbox and sent items. This means we know exactly what to look for. If it isn't there,
'we just create it. I have used the search, rather than specifying the folders so that if the archiving is extended to more than just the inbobx and sent items, no
'change is needed.
If SearchFolders(objTargetFolder, objSourceFolder.Name) Is Nothing Then
Set objTargetFolder = objTargetFolder.Folders.Add(objSourceFolder.Name)
Else
Set objTargetFolder = objTargetFolder.Folders(objSourceFolder.Name)
End If
'There is this crappy thing on the filtering of messages where it takes a date string, not a date. So we need to calculate and then convert
'to the format that MS lists on the MSDN site
dtDate = DateAdd("M", -iMonthAge, Now())
strDate = Format(dtDate, "ddddd h:nn AMPM")
'apply a filter to only show messages older than the specified date, which have been read.
Set OldMessages = objSourceFolder.Items
Set OldMessages = OldMessages.Restrict("[Received] <= '" & strDate & "' AND [Unread] = False")
'let the poor user know what's going on - they can bail out now if they want
If OldMessages.Count > 0 Then
' If MsgBox("There are " & OldMessages.Count & " old items in your " & objSourceFolder.Name & ". Do you want to move them from your " & objSourceFolder.Name & _
' " folder to your " & objTargetFolder.Name & " folder.", vbYesNo, UCase(objSourceFolder.Name) + " Archive") = vbYes Then
'----------------------------------------------------------------------------------------------------------------------------------------
'go through all the messages in the big list of messages older than the specified date, moving them if possible.
'StatusForm.Show vbModeless
For Each objMessage In OldMessages
If TypeName(objMessage) = "MailItem" Then
'do our shizzle
Else
'if it is not a mailitem, there may be problems moving it - add it to the list instead.
strProblemFiles = strProblemFiles + vbCrLf + objSourceFolder.Name + ": " + objMessage.Subject
End If
'make a note for anyone who can look
Debug.Print objMessage.Subject
'probably pointless since we are only looking in the inbox and sent items, and making the mirrors ourselves, but check the folder is correct
If objTargetFolder.DefaultItemType = olMailItem Then
If objMessage.Class = olMail Then
'put the message in a nice stable collection for now - that way, we don't have to worry about the count changing etc
colMove.Add objMessage
End If
End If
Next objMessage
'----------------------------------------------------------------------------------------------------------------------------------------
'and here we have the actual move (and some optional text if you are using the categories)
For Each objMessage In colMove
'Move the item if you can
'objMessage.Categories = "Archived from " & objSourceFolder.Name
'objMessage.Save
objMessage.Move objTargetFolder
Next objMessage
'----------------------------------------------------------------------------------------------------------------------------------------
'Else
' 'if the user doesn't want to do it, we need to shut up shop and get the hell out of here
' Set objSourceFolder = Nothing
' Set OldMessages = Nothing
' Set objMessage = Nothing
' Set objTargetFolder = Nothing
' Exit Sub
'End If
Else
'if the count of all the old messages is not greater than 0
MsgBox "There are no messages from more than " & iMonthAge & " months ago in your " & objTargetFolder.Name & _
", so nothing will be archived.", vbExclamation, "Mailbox is Clean"
End If
'----------------------------------------------------------------------------------------------------------------------------------------
'finally, loop through literally all the items in the target folders and add up the sizes to see how much we have archived in total.
For Each objAnything In objTargetFolder.Parent.Items
lngSize = lngSize + objAnything.size
Next
'if they want to include the sent items in the archive, then change over the folder and do it all again
If boolSentItems = True Then
boolSentItems = False
Set objSourceFolder = SearchFolders(objSourceFolder.Parent, "Sent Items")
'iColour = iColour + 1
GoTo StartAgain
End If
'----------------------------------------------------------------------------------------------------------------------------------------
'once we have done all we can, let the user know about all the files that were skipped.
If strProblemFiles <> "" Then
MsgBox "The following items were skipped, so will still be in your mailbox" & vbCrLf & strProblemFiles, vbOKOnly, "Non-Mail Items"
Else
MsgBox "Archive complete", vbOKOnly, "Files Moved"
End If
'----------------------------------------------------------------------------------------------------------------------------------------
'the size of each file is listed in Bytes, so convert to MB to check the MB size and display, for convenience.
If lngSize / (1024 ^ 2) >= iMaxMBSize Then
MsgBox "Your archive folder takes up " & Round(lngSize / (1024 ^ 2), 0) & "MB; it is time to call IT to ask them to clear out the files", vbOKOnly, _
"Archive folder bigger than " & iMaxMBSize & "MB"
End If
'now we have done the whole thing, we can wipe down for fingerprints and exit through the window
Set objSourceFolder = Nothing
Set OldMessages = Nothing
Set objMessage = Nothing
Set objTargetFolder = Nothing
StatusForm.Hide
On Error GoTo 0
Exit Sub
'ErrorCatch:
'If you decide to add some error checking, put it in here, although as I say, I haven't bothered (see Declaration section at top)
End Sub
Public Function SearchFolders(objTopFolder As Outlook.MAPIFolder, strName As String)
Dim objFolder As Outlook.MAPIFolder
'look through all the sub folders at the level we started
For Each objFolder In objTopFolder.Folders
'If we find the one that we are looking for, great! we can get it and get out
If objFolder.Name = strName Then
Set SearchFolders = objFolder
Exit Function
'if we haven't found our magic folder yet, we need to carry on, by looking for any sub-sub folders this is done by calling the function itself on
'the current folder (which is by definition already one level lower than the starting location). if nothing is found, we,ll just carry on
Else
If objFolder.Folders.Count > 0 Then
Call SearchFolders(objFolder, strName)
End If
End If
Next
'the only way to exit the loop at this point is if all the folders have been searched and the folder we were looking for was not found.
Set SearchFolders = Nothing
End Function
＆＃34; StatusForm＆＃34;提到的用户表单是一个完全静态的表单，只是说＆＃34;存档...＆＃34;因此，当宏运行时，用户不太可能在Outlook中尝试乱码。