Pour se débarasser des doublons d'images dans les "bibliothèques d'images" (ou photos) perso, de son dd.
Ce programme fonctionne en deux temps :
1/ il recherche tout les fichiers images contenu dans le dossier et sous-dossiers, puis il en extrait les informations de dimensions XY, format et taille du fichier.
A partir de cette liste, il compare les dimensions des images pour trouver les résolutions identique, puis validé si le format et/ou la taille sont identique
2/ il ouvre les image et réalise une comparaison pixel par pixel des images qui "semble identique" avec le test 1
Une fenêtre de bilan (rapport) ainsi que de prévisu (visio) est disponible pour lire les résultats de l'analyse.
grâçe au système de recherche en 2 passes, dont l'une pour le de dégrossissement étant très rapide (100% en ram), on atteint des performance de 10 minutes de travail pour trouvé 900 images identique dans une collection de 17000 images (et grâçe au rapport, on a vu que un dossier complet étais dupliqué) sur un système 1GHz, là où des freeware mettent 5 jours!
interêt de la source :
- recherche dans les dossiers et sous-dossier avec la fonction Dir()
- récupération des headers des fichiers BMP, JPG, GIF et PNG (plus a venir)
- ouverture bitmap et comparaison bit-à-bit beaucoup plus rapide que GetPixel ou .Point grâçe à GetBitmapBits (alter-ego de GetDIBits)
- et en plus les résultats sont exhaustif à 99,5% :)
remarques :
- Si l'image est corrompu ou partiellement endommagé, le programme l'ignorera.
- Certain fichiers portant l'extension .jpg ne sont pas au format JFIF mais Exif (cas des photos numérique) et le programme à quelques difficultés à trouvé les dimensions XY de ces dernières (considéré alors comme = 0, donc ignoré par les tests)
Pensez à compilé le programme, il est 30% plus rapide en version .exe !
Source / Exemple :
'beaucoup trop long, voir Zip
'extrait de CompKern.bas : la récupération de la résolution XY :
Private Sub GET_PicXYRes(InFormat As Long, OutXres As Long, OutYres As Long)
Dim bMarker As Byte
Dim iLength As Byte
Dim lSeek As Long
Dim iXres As Integer
Dim iYres As Integer
Dim Checking As Integer
Dim HWtbl(1 To 4) As Byte
Dim JpegDebug As Long
Select Case InFormat
Case 1 ' BMP
Get #1, 19, OutXres
Get #1, 23, OutYres
Case 2 ' JPG
'le format JPEG standard est rarement respecté, aussi il faut procéder a différent "saut"
'avant de trouver le marqueur SOF0, auquel est rattaché la résolution
Get #1, 3, Checking
If Checking <> &HE0FF Then
'non-JFIF (exif ?)
i = 5
ts = LOF(1) - 1
Do Until Checking = &HE0FF Or Checking = &HD8FF Or Checking = &HC0FF
Get #1, i, Checking
i = i + 1
If i >= ts Then
'format jpeg incompatible ou inconnu
OutXres = 0
OutYres = 0
Exit Sub
End If
Loop
lSeek = i
Else
'JFIF
lSeek = 21
End If
JpegMarkSeek:
Get #1, lSeek, bMarker
If bMarker = 255 Then
Get #1, lSeek + 1, bMarker
If bMarker >= 192 And bMarker <= 195 Then 'marqueur SOF0 , SOF1 ou SOF2 de base
Get #1, lSeek + 5, HWtbl
OutYres = HWtbl(1) * 256 + HWtbl(2)
OutXres = HWtbl(3) * 256 + HWtbl(4)
'OutXres = CLng(iXres)
'OutYres = CLng(iYres)
Get #1, LOF(1) - 1, Checking
If Checking <> &HD9FF And Checking <> 0 Then
'image buggé (fin incorrect)
OutXres = 0
OutYres = 0
End If
Else
lSeek = lSeek + 1
GoTo JpegMarkSeek
End If
Else
lSeek = lSeek + 1
GoTo JpegMarkSeek
'non-JFIF
OutXres = 0
OutYres = 0
End If
Case 3 ' GIF
Get #1, 7, iXres
Get #1, 9, iYres
OutXres = CLng(iXres)
OutYres = CLng(iYres)
Case Else
OutXres = 0
OutYres = 0
End Select
End Sub
Conclusion :
mode d'emploi :
1/ choisissez le dossier de base de votre collection d'image a trier
2/ cliquer sur "build" pour lister les images existantes
3/ cliquer sur "begin" pour entamer le comparatif rapide puis bit-à-bit.
4/ cliquer, le cas échéant (résultat > 0) sur "visio" et "rapport" pour connaitre les images en double trouvé.
bug connus :
- quelques format jpeg corrompu/malformé non géré.
update mai 2003 :
- module Dir.bas optimisé (vitesse +5% )
- module CompKern.bas optimisé (vitesse pass1 x10! )
La fonction "kill!" : en fait tu choisi toute les images a supprimer, et une fois la selection faite, tu cliques sur "valider" et le prog supprimera d'un coup toute la liste de choix. Je n'aime pas trop cette methode de suppression, manque de sécurité. Vé faire ta suggestion, c pas bête :)
Merci.
Skywalker13, essaye de savoir quel image est à l'origine de cette erreur, pour débogué il faut que je puisse faire le test chez moi.
Je n'ai pas modifié le code si ce n'est la nature des variables de types Integer que j'ai changer en Long (en faisant "Remplacer...", portée : Projet).
J'ai traité 5500 images, j'ai eu 2088 doublons sur la première étape et 117 sur la deuxième.
Une petite suggestion. Dans la fenêtre rapport ce serait bien que l'action du clique sur le bouton Kill fasse aussi passer à la photo suivante. Ou alors qu'il y ait une possibilité de tout effacer en bloque.
Ma note --> 10/10
@+, VIC
correctif :
remplacer iXres par OutXres et pour la ligne du dessus, iYres par OutYres .
have fun!
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.