Les e-mails d'un groupe de distribution ne sont pas des MailItems?

Question

J'essaye d'écrire un script VBA pour Outlook 2007 qui déplace le courrier d'un utilisateur vers un dossier "Expiré" s'il a plus de 89 jours. J'ai le code pour faire ceci, mais cela ne semble pas fonctionner pour les emails âgés qui étaient à un groupe de distribution qui inclut l'utilisateur final. Cela fonctionne pour les emails qui viennent d'être envoyés à l'utilisateur final.

I code combiné, j'ai trouvé en ligne pour a) des e-mails en mouvement quand ils sont un certain nombre de jours anciens (http://www.slipstick.com/developer/macro-move-aged-mail/), et b) récursion dans un dossier pour appliquer le code aux sous-dossiers et (Can I iterate through all Outlook emails in a folder including sub-folders?). Ce code récursif à travers le dossier Boîte de réception et les sous-dossiers pour déplacer tous les messages âgés.

Cela fonctionne plus ou moins, mais pour une raison quelconque, les courriels d'une liste de distribution incluant l'utilisateur final ne sont pas récupérés. Le seul contrôle remarquable est que je

If TypeName(oItem) = "MailItem" 

sont des courriels de la liste de distribution non considérés comme MailItems? Si non, comment puis-je m'assurer de les attraper aussi?

Voici le code complet:

Public Sub MoveAgedMail(Item As Outlook.MailItem) 

     Dim objOutlook As Outlook.Application 
     Dim objNamespace As Outlook.NameSpace 
     Dim objSourceFolder As Outlook.MAPIFolder 
     Dim objVariant As Variant 
     Dim lngMovedItems As Long 
     Dim intCount As Integer 
     Dim intDateDiff As Integer 
     Dim strDestFolder As String 
     Dim Folder As Outlook.MAPIFolder 

     Dim oFolder As Outlook.MAPIFolder 
     Dim oMail As Outlook.MailItem 

     Set objOutlook = Application 
     Set objNamespace = objOutlook.GetNamespace("MAPI") 
     Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox) 

     ' Call processFolder 
     processFolder objSourceFolder 


    End Sub 

    Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder) 

      Dim oFolder As Outlook.MAPIFolder 
      Dim oMail As Outlook.MailItem 
      Dim oItem As Object 
      Dim intCount As Integer 
      Dim intDateDiff As Long 
      Dim objDestFolder As Outlook.MAPIFolder 

     ' "Expired" folder at same level as Inbox for sending aged mail   
     Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired") 

      For Each oItem In oParent.Items 
       If TypeName(oItem) = "MailItem" Then 
        Set oMail = oItem 

        ' Check if email is older than 89 days 
        intDateDiff = DateDiff("d", oMail.SentOn, Now) 


        If intDateDiff > 89 Then 

        ' Move to "Expired" folder 
        oMail.Move objDestFolder 

        End If 
       End If 

      Next oItem 

     ' Recurse through subfolders 
      If (oParent.Folders.Count > 0) Then 
       For Each oFolder In oParent.Folders 
        processFolder oFolder 
       Next 
      End If 
      Set objDestFolder = Nothing 
    End Sub 

Answer 1

Tout d'abord, ne pas utiliser for each si vous modifiez une collection - qui fera votre code pour sauter la moitié des articles.

Deuxièmement, ne pas simplement traverser tous les éléments dans un dossier, c'est extrêmement inefficace. Utilisez Items.Restrict ou Items.Find/FindNext.

Essayez quelque chose comme ce qui suit (script VB):

d = Now - 89 
strFilter = "[SentOn] < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'" 
set oItems = oParent.Items.Restrict(strFilter) 
for i = oItems.Count to 1 step -1 
    set oItem = oItems.Item(i) 
    Debug.Print oItem.Subject & " " & oItem.SentOn 
next 

Answer 2

Essayez de ne pas traiter Expired Dossier

' Recurse through subfolders 
     If (oParent.Folders.Count > 0) Then 
      For Each oFolder In oParent.Folders 
      Debug.Print oFolder 
       ' No need to process Expired folder 
       If oFolder.Name <> "Expired" Then 
        processFolder oFolder 
       End If 
      Next 
     End If 

également essayer d'utiliser la boucle vers le bas lors du déplacement des articles de courrier, voir Dmitry Streblechenko exemple

---

Modifier

Items.Restrict Method (Outlook)

Code- complète Testé sur Perspectives 2010

Sub MoveAgedMail(Item As Outlook.MailItem) 
    Dim olNameSpace As Outlook.NameSpace 
    Dim olInbox As Outlook.MAPIFolder 

    Set olNameSpace = Application.GetNamespace("MAPI") 
    Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox) 

' // Call ProcessFolder 
    ProcessFolder olInbox 

End Sub 

Function ProcessFolder(ByVal Parent As Outlook.MAPIFolder) 
    Dim Folder As Outlook.MAPIFolder 
    Dim DestFolder As Outlook.MAPIFolder 
    Dim iCount As Integer 
    Dim iDateDiff As Long 
    Dim vMail As Variant 
    Dim olItems As Object 
    Dim sFilter As String 

    iDateDiff = Now - 89 
    sFilter = "[SentOn] < '" & Month(iDateDiff) & "/" & Day(iDateDiff) & "/" & Year(iDateDiff) & "'" 

' // Loop through the items in the folder backwards 
    Set olItems = Parent.Items.Restrict(sFilter) 

    For iCount = olItems.Count To 1 Step -1 
     Set vMail = olItems.Item(iCount) 

     Debug.Print vMail.Subject ' helps me to see where code is currently at 

'  // Filter objects for emails 
     If vMail.Class = olMail Then 
      Debug.Print vMail.SentOn 

'   // Retrieve a folder for the destination folder 
      Set DestFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Expired") 

'   // Move the emails to the destination folder 
      vMail.Move DestFolder 

'   // Count number items moved 
      iCount = iCount + 1 

     End If 
    Next 

' // Recurse through subfolders 
    If (Parent.Folders.Count > 0) Then 
     For Each Folder In Parent.Folders 
      If Folder.Name <> "Expired" Then ' skip Expired folder 
       Debug.Print Folder.Name 
       ProcessFolder Folder 
      End If 
     Next 
    End If 

    Debug.Print "Moved " & iCount & " Items" 

End Function 

Answer 3

Ceci est mon code maintenant. À l'origine, j'ai déplacé mon ancien courrier vers un dossier "Expiré" et j'avais supprimé automatiquement les messages, mais j'avais des problèmes avec autoarchive sur certaines machines. J'ai réécrit le script pour supprimer mon ancien email. Il utilise les suggestions de Dmitry Streblechenko, et cela semble fonctionner.

Public Sub DeleteAgedMail() 
    Dim objOutlook As Outlook.Application 
    Dim objNamespace As Outlook.NameSpace 
    Dim objSourceFolder As Outlook.MAPIFolder 
    Dim objSourceFolderSent As Outlook.MAPIFolder 

    Set objOutlook = Application 
    Set objNamespace = objOutlook.GetNamespace("MAPI") 
    Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox) 
    Set objSourceFolderSent = objNamespace.GetDefaultFolder(olFolderSentMail) 

    processFolder objSourceFolder 
    processFolder objSourceFolderSent 
    emptyDeleted 
End Sub 

Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder) 
    Dim oItems As Outlook.Items 
    Dim oItem As Object 
    Dim intDateDiff As Long 
    Dim d As Long 
    Dim strFilter As String  

    d = Now - 89 
    strFilter = "[SentOn] < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'" 
    Set oItems = oParent.Items.Restrict(strFilter) 
    For i = oItems.Count To 1 Step -1 
     Set oItem = oItems.Item(i) 
     If TypeName(oItem) = "MailItem" Then 
     oItem.UserProperties.Add "Deleted", olText 
     oItem.Save 
     oItem.Delete 
     End If 
    Next 
    If (oParent.Folders.Count > 0) Then 
     For Each oFolder In oParent.Folders 
      processFolder oFolder 
     Next 
    End If 
End Sub 

Public Sub emptyDeleted() 
    Dim objOutlook As Outlook.Application 
    Dim myNameSpace As Outlook.NameSpace 
    Dim objDeletedFolder As Outlook.MAPIFolder 
    Dim objProperty As Outlook.UserProperty 

    Set objOutlook = Application 
    Set myNameSpace = objOutlook.GetNamespace("MAPI") 
    Set objDeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems) 

    For Each objItem In objDeletedFolder.Items 
     Set objProperty = objItem.UserProperties.Find("Deleted") 
     If TypeName(objProperty) <> "Nothing" Then 
      objItem.Delete 
     End If 
    Next 
End Sub 

Si vous voulez simplement déplacer des e-mails et ne pas les supprimer, comme dans mon code d'origine, vous pouvez vous débarrasser de la fonction emptyDeleted(), changer

oItem.UserProperties.Add "Deleted", olText 
oItem.Save 
oItem.Delete 

Retour à

oItem.Move objDestFolder 

et ajouter ces deux lignes fonction de retour à la processFolder():

Dim objDestFolder As Outlook.MAPIFolder  
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired")