VBA Filter возвращает только половину элементов с ограниченными критериями

Question

Я пишу VBA для Outlook, чего я не часто делаю. У меня есть странная проблема со следующим кодом:

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 и т. д. вдвое уменьшаю количество найденных сообщений каждый раз.Я не понимаю, почему это так. Любые идеи?

Я должен упомянуть, что это работает в Outlook 2010, используя . Обмен

Спасибо для смотреть - все ответы наиболее высоко

Cheers, Марк

Answer 1

Так meting like:

'... 
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 
'... 

Answer 2

Для каждой проблемы объясняется, и здесь описан другой способ перемещения или удаления элементов, отсчитываемых назад.

For Each loop: Just deletes the very first attachment

Answer 3

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 

«StatusForm» форма пользователя, называется это полностью статическая форма, которая просто говорит «Архивация ...», так что пользователь имеет меньше шансов попробовать отводом вокруг в Outlook, в то время как выполняется макрос.