Mercredi 29 Mars 2017  
Navigation
FAQ Outlook
» Foire Aux Questions «
Recherche
Téléchargements
Forums Outlook
Plan du site
Liens
Login

Les inscriptions sont fermées

Pseudo

Mot de passe

Se souvenir de moi



Mot de passe oublié ? Mot de passe oublié ?
Connexions
Bienvenue à [FAMACLUB]
le 1,414ème membre
Visiteurs en ligne : 4
Membres en ligne : 0

 callaghi 1 jour
 Alphator 9 semaines
 ande 15 semaines
 Oliv 17 semaines
 cubitus 20 semaines
 JièL 25 semaines
 angel 31 semaines
 Quartzkyte 39 semaines
 grouilau 40 semaines
 miguy973 49 semaines

Non activés :0

Nombre de visiteurs
depuis le : 12/11/2008

Aujourd'hui:3 928
En ligne :4
Max. en ligne:312
Max. / jour:66 529
Total hier:6 355
Total ce mois:151 094
Total visites:17 271 592
Moyenne/jour:5 648

Dernières 24h

























Publicité ; elle permet de financer le site
Navigation parmi les catégories/articles
« Catégorie     Q15000 Macros - VBA (41)  Catégorie »
[<<]  « Article  (Catégorie » ) Article »
R15930 [VBA] Eliminer les doublons

Voici une macro permettant d'éliminer les doublons, elle est le fruit du travail de Mll.


Cette macro faisant appel à un userform il convient de télécharger le fichier suivant CleanDuplicates_V1.18.zip

Option Explicit


'Great for pop3 servers going awry, or PDA synch that screws up.
'This removes duplicates in the current folder, if it contains either e-mails, contacts (and distributionlists) or appointments.
'The user can choose to either simulate (no deletion), send to deleted items, or permanently remove.
'He can also choose to process only unread items.
'The way the app does items comparison is explained in the comments of the ItemsSimilar procedure.
'Please note that this is not designed to be a standalone procedure. There's a VBA form associated to it, but I just don't know how to upload binaries.

'Changelog
'V1.17 2008-03-13
'- by OLIV'
'- Add DOEVENTS for the progress bar display
'- more verbose confirmation message
'- create dupes subfolder only if necessary

'V1.16 2006-02-14
'- "only unread items" checked by default only if active folder is a mail foder
'- user may chose to avoid comparing company names for contact items
'
'V1.15 2006-02-03
'- new function "relocate item to subfolder"
'
'V1.14 2006-01-31
'- algorithm enhancements to detect even more duplicate contacts
'- cosmetic changes
'
'V1.13 2005-09-15
'- In case of dupe appointments, we keep the heaviest one
'

Private Sub Search_Click()
Call CleanDuplicates
End Sub


Private Sub CleanDuplicates()

Dim myNameSpace As NameSpace
Dim fldTrash As MAPIFolder
Dim myFolderDeletedItems As MAPIFolder
Dim myFolder As MAPIFolder
Dim myItem1 As Long, myNextItem1 As Long
Dim myItem2 As Long, myNextItem2 As Long
Dim myItem1Name As String
Dim myItemToDelete As Variant
Dim myCounter As Single
Dim nbItems As Long
Dim myItems As Items
Dim SizeSaved As Double, NumberSaved As Double
Dim ItemsType As Long
Dim ItemsClass As String
Dim DontDelete As Boolean
Dim KeepWhat As Byte
Dim CheckAgainstCompanyName As Boolean
Dim sort As String


' *** Init variables
Set myNameSpace = GetNamespace("MAPI")
Set fldTrash = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
Set myFolder = Application.ActiveExplorer.CurrentFolder

'définition du dossier doublon ou création
On Error Resume Next
If CleanDuplicates_Form.Delete_relocate.Value = True Then
Set myFolderDeletedItems = myFolder.Folders(CleanDuplicates_Form.SubfolderName.Value)
If Err <> 0 Then
Set myFolderDeletedItems = myFolder.Folders.add(CleanDuplicates_Form.SubfolderName.Value)
Err.Clear
End If
On Error GoTo 0
End If

CleanDuplicates_Form.Folder.Value = myFolder.Name

CleanDuplicates_Form.Log.Value = ""
CleanDuplicates_Form.CurItem.Value = ""


' *** Check the folder contains items manageable by this procedure
ItemsType = myFolder.DefaultItemType

If (ItemsType <> olMailItem And ItemsType <> olContactItem And ItemsType <> olAppointmentItem) Then
CleanDuplicates_Form.Log.Value = "Ce n'est pas un dossier d'objets gérés." & vbLf & "Interruption"
Exit Sub
End If


' *** Scan only unread items if the user wants it so
Set myItems = myFolder.Items
If Me.Unread_only Then Set myItems = myItems.Restrict("[Unread] = True")


' *** Sort items list, and process the special case of distribution lists
' The sorting is important, since duplicates are detected through consecutive items comparison
Select Case ItemsType
Case olMailItem
Set myItems = myItems.Restrict("[MessageClass] = 'IPM.Note'")
myItems.sort "[Subject]"
Case olContactItem
Select Case MsgBox("Agir sur les contacts (OUI) ou les listes de ditribution (NON) ou sur une valeur à définir (ANNULER) ?", vbQuestion + vbYesNoCancel + vbDefaultButton1)
Case vbYes
ItemsType = olContactItem
ItemsClass = "IPM.Contact"
Case vbNo
ItemsType = olDistributionListItem
ItemsClass = "IPM.DistList"
Case Else
ItemsType = olContactItem
ItemsClass = InputBox("Entrez la classe d'objets à traiter", , "IPM.Contact.GroupContact")
If ItemsClass = CStr(vbCancel) Then Exit Sub
End Select
Set myItems = myItems.Restrict("[MessageClass] = '" & ItemsClass & "'")
'myItems.Sort "[CompanyName]"
myItems.sort "[FullName], [CompanyName]"
CheckAgainstCompanyName = MsgBox("Inclure le nom de la société dans la comparaison ?", vbQuestion + vbYesNo + vbDefaultButton1) <> vbNo
Case olAppointmentItem
Set myItems = myItems.Restrict("[MessageClass] = 'IPM.Appointment'")
myItems.sort "[Subject], [Start], [End]"
End Select


' *** Inform the user of the volume to test, and ask for confirmation
nbItems = myItems.Count

CleanDuplicates_Form.CurItem.Value = nbItems & " éléments à tester"
CleanDuplicates_Form.Repaint

If nbItems <= 1 Then
CleanDuplicates_Form.Log.Value = "Moins de 2 éléments à vérifier - opération annulée"
Exit Sub
End If
' on indique le sort des doublons
If CleanDuplicates_Form.Delete_none Then
sort = " Justé testés"
ElseIf CleanDuplicates_Form.Delete_relocate Then
sort = " Déplacés vers " & myFolderDeletedItems.FolderPath
ElseIf CleanDuplicates_Form.Delete_move Then
sort = " Déplacés vers " & fldTrash.FolderPath
ElseIf CleanDuplicates_Form.Delete_remove Then
sort = " Détruits"
End If
If MsgBox(nbItems & " éléments à tester" & vbCr & "Les doublons seront : " & vbCr & sort & vbCrLf & vbCr & "Continuer ?", vbQuestion + vbYesNo + vbDefaultButton1, myFolder.FolderPath) <> vbYes Then
CleanDuplicates_Form.Log.Value = "Annulé par l'utilisateur"
Exit Sub
End If



' *** Initialize variables before loop
SizeSaved = 0
NumberSaved = 0
myCounter = Timer

myNextItem1 = 1
myNextItem2 = 2


' *** Loop through items
Do
' The idea is to check myItem1 against myItem2. They may not be consecutive (inbetween items may have been deleted)
myItem1 = myNextItem1
myItem2 = myNextItem2

' *** Display some information for the user
Select Case ItemsType
Case olMailItem
myItem1Name = myItem1 & "/" & nbItems & "|" & myItems(myItem1).Subject & "|" & myItems(myItem1).SenderName & "|" & myItems(myItem1).SentOn & "|..."
Case olContactItem
myItem1Name = myItem1 & "/" & nbItems & "|" & myItems(myItem1).FullName & "|" & myItems(myItem1).FileAs & "|" & CStr(myItems(myItem1).UnRead) & "|..."
' Dim toto As Outlook.ContactItem
' Set toto = myItems(5)
Case olDistributionListItem
myItem1Name = myItem1 & "/" & nbItems & "|" & myItems(myItem1).Subject & "|" & myItems(myItem1).MemberCount & "|" & CStr(myItems(myItem1).UnRead) & "|..."
Case olAppointmentItem
myItem1Name = myItem1 & "/" & nbItems & "|" & myItems(myItem1).Subject & "|" & myItems(myItem1).Start & "|" & myItems(myItem1).End & "|..."
End Select
'Debug.Print myItem1Name
CleanDuplicates_Form.CurItem.Value = myItem1Name
'CleanDuplicates_Form.Repaint

' *** Determine the item to compare to myItem1
' Find myItem2 when the items are not consecutive
Do Until IsObject(myItems(myItem2)) Or myItem2 = nbItems
myItem2 = myItem2 + 1
Loop
' Exit if there's no more item to compare to myItem1
If Not IsObject(myItems(myItem2)) Then Exit Do


' *** See if items are similar, and if it's the case, guess which one to keep
KeepWhat = ItemsSimilar(ItemsType, myItems(myItem1), myItems(myItem2), CheckAgainstCompanyName)

' *** Process similar items
If KeepWhat <> 0 Then
' Inform the user
CleanDuplicates_Form.Log.Value = CleanDuplicates_Form.Log.Value & vbLf & myItem1Name & vbLf & " similaire à " & myItem2

DontDelete = False
' *** Check if the case is dubious
If ItemsType = olMailItem Then
If myItems(myItem1).SenderName = "" Then
CleanDuplicates_Form.Log.Value = CleanDuplicates_Form.Log.Value & " douteux"
DontDelete = True
End If
ElseIf ItemsType = olContactItem Then 'nothing done with them yet
ElseIf ItemsType = olDistributionListItem Then 'nothing done with them yet
ElseIf ItemsType = olAppointmentItem Then 'nothing done with them yet
End If

' *** If not a dubious case, do the cleaning
If DontDelete = False Then

' Flag the item to delete, inform the user, and prepare for the next loop
If KeepWhat = 1 Then
Set myItemToDelete = myItems(myItem2)
CleanDuplicates_Form.Log.Value = CleanDuplicates_Form.Log.Value & vbLf & " " & myItem2 & " à supprimer..."
myNextItem1 = myItem1
myNextItem2 = myItem2 + 1
ElseIf KeepWhat = 2 Then
Set myItemToDelete = myItems(myItem1)
CleanDuplicates_Form.Log.Value = CleanDuplicates_Form.Log.Value & vbLf & " " & myItem1 & " à supprimer..."
myNextItem1 = myItem1 + 1
myNextItem2 = myItem2 + 1
End If

SizeSaved = SizeSaved + myItemToDelete.Size
NumberSaved = NumberSaved + 1
' Do the user-selected action (respectively: do nothing (simulate), move to deleted items, or definitive deletion)
If CleanDuplicates_Form.Delete_none Then
CleanDuplicates_Form.Log.Value = CleanDuplicates_Form.Log.Value & " non supprimé"
ElseIf CleanDuplicates_Form.Delete_relocate Then
myItemToDelete.Move myFolderDeletedItems
CleanDuplicates_Form.Log.Value = CleanDuplicates_Form.Log.Value & " déplacé"
ElseIf CleanDuplicates_Form.Delete_move Then
myItemToDelete.Move fldTrash
CleanDuplicates_Form.Log.Value = CleanDuplicates_Form.Log.Value & " supprimé"
'NbItems = NbItems - 1
ElseIf CleanDuplicates_Form.Delete_remove Then
myItemToDelete.Delete
CleanDuplicates_Form.Log.Value = CleanDuplicates_Form.Log.Value & " détruit"
'nbItems = nbItems - 1
End If
Else
myNextItem1 = myItem1 + 1
myNextItem2 = myItem2 + 1
End If

' CleanDuplicates_Form.Repaint

' *** If different items, just prepare the next loop
Else
myNextItem1 = myItem2
myNextItem2 = myItem2 + 1
If myItem2 - myItem1 > 1 Then CleanDuplicates_Form.Log.Value = CleanDuplicates_Form.Log.Value & vbLf & "___________________"
End If


' *** User information (progress bar, guess remaining time...)
CleanDuplicates_Form.Done.Value = myItem1 / nbItems * 100
CleanDuplicates_Form.RemainingTime.Value = CInt((Timer - myCounter) * (nbItems / myItem1 - 1)) & "s"
CleanDuplicates_Form.Repaint
DoEvents
Set myItemToDelete = Nothing

Loop Until myNextItem2 > myItems.Count

CleanDuplicates_Form.Done.Value = 100
CleanDuplicates_Form.RemainingTime.Value = CInt((Timer - myCounter) * (nbItems / myItem1 - 1)) & "s"
CleanDuplicates_Form.Repaint


Beep
CleanDuplicates_Form.CurItem.Value = "Terminé - " & VBA.Format(SizeSaved / 1024, "Standard", vbMonday) & " ko gagné(s) dans " & NumberSaved & " éléments."
CleanDuplicates_Form.Repaint


Set myFolder = Nothing
Set myFolderDeletedItems = Nothing
Set myNameSpace = Nothing

End Sub

Private Function ItemsSimilar(ItemsType As Long, Item1 As Variant, Item2 As Variant, Optional CheckAgainstCompanyName As Boolean = True) As Byte
'ItemsSimilar:
' 0: not similar
' 1: similar, keep Item1
' 2: similar, keep Item2

ItemsSimilar = 0

Select Case ItemsType
' *** For e-mails, 2 items are considered similar if they have:
' - the same subject,
' - the same sender,
' - the same sending date,
' - and roughly the same size (dunno why, but wanting 'exactly' the same size would cause similar items miss).
' Then, we arbitrarly choose to keep the item1
Case olMailItem
If ( _
Item1.Subject = Item2.Subject _
And Item1.SenderName = Item2.SenderName _
And Item1.SentOn = Item2.SentOn _
And Item1.Size * 0.95 < Item2.Size _
And Item1.Size * 1.05 > Item2.Size) _
Then ItemsSimilar = 1
' *** For Contacts, 2 items are considered similar if they have:
' - the same subject (kinda display name IIRC),
' - the same full name,
' - and the same company name.
' DEPRECATED: Then, we choose to keep the item that has the longest category field.
' Then, we choose to keep the item that has the biggest size.
Case olContactItem
If ( _
Item1.Subject = Item2.Subject _
And Item1.FullName = Item2.FullName _
And IIf(CheckAgainstCompanyName, Item1.CompanyName = Item2.CompanyName, True) _
) _
Then
If Item2.Size > Item1.Size Then ItemsSimilar = 2 Else ItemsSimilar = 1
' If Len(Item2.Categories) > Len(Item1.Categories) Then ItemsSimilar = 2 Else ItemsSimilar = 1
End If
' *** For Distribution Lists, 2 items are considered similar if they have the same subject.
' Then, we arbitrarly choose to keep the item1.
Case olDistributionListItem
If ( _
Item1.Subject = Item2.Subject) _
Then ItemsSimilar = 1
' *** For Appointments, 2 items are considered similar if they have:
' - the same subject,
' - the same start date & time,
' - the same end date & time,
' - and if both of them are recurring or non-recurring.
' Then, we choose to keep the item that has the biggest size.
Case olAppointmentItem
If ( _
Item1.Subject = Item2.Subject _
And Item1.Start = Item2.Start _
And Item1.End = Item2.End _
And Item1.IsRecurring = Item2.IsRecurring) _
Then
If Item2.Size > Item1.Size Then ItemsSimilar = 2 Else ItemsSimilar = 1
End If
End Select
End Function

Private Sub UserForm_Initialize()
' Me.Delete_relocate = True

Me.Unread_only = (Application.ActiveExplorer.CurrentFolder.DefaultItemType = olMailItem)

Const DupesFolderName As String = "Doublons"
Me.SubfolderName.Value = DupesFolderName

End Sub

Publié par Oliv le mardi 01 juillet 2008 09:38 5 Commentaires 64150 Lecture(s) Imprimer
Commentaires
#1 | miaouaf le mardi 29 juillet 2008 16:07
Parfait ; j'ai mis à jour la page de mon site : http://mll2.free.fr/?p=11
#2 | mll le mardi 21 septembre 2010 12:29
mmmh, je ne suis pas miaouaf, et pourtant mll2.free.fr c'est bien mon site !

sinon, j'ai fait un v1.18 que je tiens à disposition
#3 | JièL le mercredi 22 septembre 2010 00:05
Oups, petit bug lors de la suppression de vieux compte je pense...
Merci pour l'info, c'est super d'avoir un suivi en plus.
#4 | Eric le samedi 29 janvier 2011 12:01
Bonjour mll
où peut-on récupérer la 1.18 ?? je suis intéressé...
#5 | mll le mardi 15 mars 2011 07:51
Eric : en attendant que JièL mette à jour la présente page, la v1.18 est dispo à http://mll2.free.fr/?p=11
Copyright et partage
Ce site est sous licence Creative Commons.
Vous pouvez utiliser toutes les informations présentent ici, mais il vous est interdit de les reproduire sans citer la source.

Creative Commons License
OUI au partage
NON au « copillage »

Ajouter aux favoris / partager : 
URL :
BBcode :
HTML :
Cliquez ci dessus sur le lien que vous voulez copier et [Ctrl] + [C] ou cliquez sur le bouton [ C ]
Articles similaires
Articles Catégories
R06032 Utiliser l'archivage automatique avec les dates de réception Q06000 Les fichiers d'Outlook
R15045 [VBA] Ouvrir l'arborescence des pst contenant une boîte de réception Q15000 Macros - VBA
R15930 [VBA] Création de menu dans outlook Q15000 Macros - VBA
R17070 VSTO et les formulaires d'Outlook 2007 Q17000 Formulaires
R15380 [VBA] Envoi via VBA : suppression de la confirmation d'envoi Q15000 Macros - VBA
Nuage de tags
R17005 Création d'éléments basique, R10040 Sauvegardez ses règles de gestion des messages, R09150 Publipostage à partir des contacts d'Outlook, R06070 Classer automatiquement les messages reçus ou envoyés, R12020 Naviguer dans le calendrier, R15400 [VBA] Changer les parametres POP des COMPTES, R09125 Exporter les contacts d'Outlook vers Outlook Express, R15300 [VBA] Enregistrer dans un dossier après envoi, R12030 Créer un rendez-vous rapidement, R10020 Sauvegarder les paramètres et fichiers .PST d'Outlook 2002 (Windows XP seulement), R03070 Créer son papier à lettres personnel, R15360 [VBA] Pas de compte par defaut --> Obliger le choix entre 2 comptes ou plus, R01160 Configurer un compte « POP before SMTP » (exemple : Laposte.net), R11070 Restaurer les fichiers de paramètres d'Outlook, R10040 Sauvegardez ses règles de gestion des messages

aucun Crack, CrackZ, no-CD, DownloadZ, TelechargementZ, Serial, Numéro de série, N0 de série, Serialz ni Keygen pour Outlook sur ce site.

Blague aléatoire
Publicité
Météo Marseille
[/\] Copyright JièL / Jean-Louis Goubert © 2003-2009 [/\]