Ce programme recherche dans un répertoire (en ses sous-répertoires) les images qui sont en double, et permet d'en supprimer une selon plusieurs critères (la plus grosse, la plus petite, la plus ancienne...)
La comparaison se fait sur la transformée en faisceaux d'ondelettes, une méthode beaucoup plus performante qu'une comparaison pixel par pixel. L'algorithme de comparaison détectera les images qui ont changé de résolution, de contraste ou qui sont plus nettes ou plus floues. Des valeurs "normalles" de similarité maximale sont comprises entre 80% et 100%. Il faut d'abord cliquer sur le boutton "Search" et ensuite sur le boutton "Compare", une boite de dialogue demande quelle image supprimer à chaque fois (boutton "Skip" pour ne rien faire) et donne la possibilité d'utiliser le même critère à chaque fois (pour ne pas avoir à cliquer 200 fois sur le même boutton).
Notez bien que je ne suis pas responsable de l'utilisation que vous ferez du programme, si vous perdez images importantes ce ne sera pas de ma faute! De toute façon le programme permet d'envoyer les fichiers à la corbeille plutôt que de les supprimer, donc il est possible d'annuler la suppression.
Voilà, je crois que j'ai tout dit, merci de me tenir au courant des éventuels bugs.
Note: si vous voulez que le programme puisse lire plus de fichiers d'images (pour l'instant, seuls JPEG, BMP, WMF et ICO) sont pris en compte, il faudra simplement rajoutter dans les uses de MainFormUnit.pas une unité qui permet la lecture des formats additionnels (si celle-ci est bien programmée et intégrée à Delphi ça devrait fonctionner). En particulier ça devrait fonctionner avec l'unité GifImage téléchargeable je ne sais plus où (voir Google).
Source / Exemple :
unit MainFormUnit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ShlObj, Buttons, StdCtrls, ExtCtrls, ToolWin, ComCtrls, ExtDlgs,
ImgList, Menus, StrUtils, SearchProgressFormUnit, CompareProgressFormUnit,
DecisionFormUnit, ShellAPI, JPEG;
type
TMainForm = class(TForm)
GroupBox1: TGroupBox;
Edit1: TEdit;
SpeedButton1: TSpeedButton;
CheckBox1: TCheckBox;
BitBtn1: TBitBtn;
GroupBox2: TGroupBox;
ListView1: TListView;
ImageList1: TImageList;
ImageList2: TImageList;
ToolBar1: TToolBar;
ToolButton1: TToolButton;
PopupMenu1: TPopupMenu;
Details1: TMenuItem;
List1: TMenuItem;
Details2: TMenuItem;
Smallicons1: TMenuItem;
ImageList3: TImageList;
ToolButton2: TToolButton;
PopupMenu2: TPopupMenu;
Byname1: TMenuItem;
Bydimensions1: TMenuItem;
Byfilesize1: TMenuItem;
Bydate1: TMenuItem;
N1: TMenuItem;
Ascendant1: TMenuItem;
Descendant1: TMenuItem;
BitBtn2: TBitBtn;
Panel1: TPanel;
TrackBar1: TTrackBar;
ComboBox1: TComboBox;
ToolButton3: TToolButton;
Panel2: TPanel;
ImageList4: TImageList;
ToolButton4: TToolButton;
Panel3: TPanel;
ComboBox2: TComboBox;
procedure FormCreate(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
procedure Smallicons1Click(Sender: TObject);
procedure ListView1Compare(Sender: TObject; Item1, Item2: TListItem;
Data: Integer; var Compare: Integer);
procedure ListView1ColumnClick(Sender: TObject; Column: TListColumn);
procedure BitBtn2Click(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure Descendant1Click(Sender: TObject);
procedure Bydate1Click(Sender: TObject);
procedure ComboBox2Change(Sender: TObject);
private
FAscendantOrder:Boolean; // Ordre de classement croissant/décroissant
FColumnSortID:Integer; // Critère de classement
public
CurrentFolder:string; // Variables utilisées par les fenêtres de progression
FileCount,FolderCount:Integer;
CompareProgress:Single;
procedure ClearData; // Pour nettoyer le ListView (la propriété Data des TListItem contient un pointeur vers une matrice de coefficients)
end;
TTriVertex=packed record
x:Longint;
y:Longint;
Red:Word;
Green:Word;
Blue:Word;
Alpha:Word;
end;
TSingleArray=array[0..$FFFFFF] of Single;
PSingleArray=^TSingleArray;
TSearchThread=class(TThread) // Thread de recherche de fichiers images
private
FSearchData:TSearchRec; // Variables utilisées dans la méthode synchronisée
FPicture:TPicture;
FBitmap1,FBitmap2:TBitmap;
FRect1,FRect2:TRect;
FPath,FSubPath:string;
FSize:Integer;
FBuffer:PSingleArray;
protected
procedure Execute;override;
procedure Finished; // Méthode appelée à la fin du thread pour enlever la fenêtre de progression
procedure AddFile; // Méthode synchronisée avec le thread principal pour manipuler le ListView1
end;
TCompareThread=class(TThread) // Thread de comparaison des fichiers images trouvés
private
FFile1,FFile2:string; // Variables utilisées dans la méthode synchronisée
FAction:TImageAction;
FSimilarity:Single;
protected
procedure Execute;override;
procedure Finished; // Méthode appelée à la fin du thread pour enlever la fenêtre de progression
procedure FileAction; // Méthode synchronisée avec le thread principal pour manipuler le ListView1 et lancer le dialogue de suppression
end;
var
MainForm: TMainForm;
implementation
{$R *.dfm}
function CallBack(Wnd:HWND;uMsg:UINT;wParam,lpData:LPARAM):Integer;stdcall; // Fonction de "callback" appelée à l'initialisation de la
begin // boîte de sélection de répertoire pour définir le répertoire
if uMsg=BFFM_INITIALIZED then // par défaut
SendMessage(Wnd,BFFM_SETSELECTION,1,lpData);
Result:=0;
end;
function SelectFolder(var Folder:string;const AllowCreateNew:Boolean=False;const Title:string=''):Boolean; // Fonction pour demander à l'utilisateur de
const // choisir un répertoire
BIF_NEWDIALOGSTYLE=$0040; // Folder: le répertoire par défaut
var // qui contiendra le répertoire
BI:TBrowseInfo; // choisi en cas de confirmation
p:PItemIDList; // AllowCreateNew: autorise ou non la possibilité
begin // de créer un nouveau dossier
ZeroMemory(@BI,SizeOf(BI)); // Title: titre de la boîte de dialogue
with BI do begin // Résultat: True si l'utilisation a cliqué
hwndOwner:=Application.Handle; // sur OK, False sinon
pszDisplayName:=PChar(Folder);
lpszTitle:=PChar(Title);
ulFlags:=BIF_RETURNONLYFSDIRS;
if AllowCreateNew then
ulFlags:=ulFlags or BIF_NEWDIALOGSTYLE;
if Folder<>'' then begin
lParam:=Integer(PChar(Folder));
lpfn:=CallBack;
end;
end;
p:=SHBrowseForFolder(BI);
if Assigned(p) then begin
SetLength(Folder,MAX_PATH);
Result:=SHGetPathFromIDList(p,PChar(Folder));
GlobalFreePtr(p);
SetLength(Folder,Length(PChar(Folder)));
end else
Result:=False;
end;
{ TSearchThread }
procedure TSearchThread.AddFile; // Procédure synchronisée avec le thread principal pour ajoutter un item dans le TListView
function BuildWavelet:PSingleArray; // Fonction qui construit la transformée en ondelettes de Haar de l'image
var
a,b,c,d,e:Integer;
s:PByteArray;
begin
GetMem(Result,FBitmap2.Width*FBitmap2.Height*3*SizeOf(Single));
for b:=0 to FBitmap2.Height-1 do begin
s:=FBitmap2.ScanLine[b];
for a:=0 to 3*FBitmap2.Width-1 do
Result[FSize*b*3+a]:=s[a];
end;
c:=FSize;
while c>1 do begin // Transformée en paquets d'ondelettes...
e:=c div 2;
for d:=0 to 2 do begin // On fait successivement la transformée des 3 canaux RGB
for a:=0 to FSize-1 do begin // Transformée horizontale
for b:=0 to c-1 do
FBuffer[b]:=Result[(FSize*a+b)*3+d];
for b:=0 to e-1 do begin
Result[(FSize*a+b)*3+d]:=0.5*(FBuffer[2*b]+FBuffer[2*b+1]);
Result[(FSize*a+b+e)*3+d]:=0.5*(FBuffer[2*b+1]-FBuffer[2*b]);
end;
end;
for a:=0 to FSize-1 do begin // Transformée verticale
for b:=0 to c-1 do
FBuffer[b]:=Result[(FSize*b+a)*3+d];
for b:=0 to e-1 do begin
Result[(FSize*b+a)*3+d]:=0.5*(FBuffer[2*b]+FBuffer[2*b+1]);
Result[(FSize*(b+e)+a)*3+d]:=0.5*(FBuffer[2*b+1]-FBuffer[2*b]);
end;
end;
end;
c:=c div 2; // Passage à l'échelle suivante
end;
end;
begin
MainForm.CurrentFolder:=FSubPath; // Variables utilisées par la fenêtre de progression...
FPicture.LoadFromFile(FPath+'\'+FSearchData.Name);
FBitmap1.Canvas.StretchDraw(FRect1,FPicture.Graphic);
FBitmap2.Canvas.StretchDraw(FRect2,FPicture.Graphic);
with MainForm,ListView1.Items.Add do begin
Data:=BuildWavelet;
Caption:=FSubPath+FSearchData.Name;
SubItems.Add(Format('%d x %d',[FPicture.Width,FPicture.Height]));
{$WARNINGS OFF}
SubItems.Add(IntToStr(Int64(FSearchData.FindData.nFileSizeHigh) shl 32+FSearchData.FindData.nFileSizeLow));
{$WARNINGS ON}
SubItems.Add(DateTimeToStr(FileDateToDateTime(FileAge(FPath+'\'+FSearchData.Name))));
ImageIndex:=ImageList1.Add(FBitmap1,nil);
ImageList2.Add(FBitmap2,nil);
end;
Inc(MainForm.FileCount);
end;
procedure TSearchThread.Execute;
var
l:TStringList;
procedure ListFolder(Path:string;SubPath:string); // Parcours récursif (en fonction de CheckBox1.Checked) d'un répertoire
var
f:TSearchRec;
begin
Inc(MainForm.FolderCount);
if FindFirst(Path+'\*',faAnyFile or faDirectory,f)=0 then
try
repeat
if Terminated then
Break;
if f.Attr and faDirectory=faDirectory then begin
if MainForm.CheckBox1.Checked and (f.Name<>'.') and (f.Name<>'..') then
ListFolder(Path+'\'+f.Name,SubPath+f.Name+'\');
end else
if l.IndexOf(ExtractFileExt(f.Name))>-1 then begin // Si l'extension est une extension graphique connue (en l'occurence *.JPEG, *.BMP, *.ICO, *.WMF)
try
FSearchData:=f;
FSubPath:=SubPath;
FPath:=Path;
Synchronize(AddFile); // Synchronisation de la méthode d'ajout
except
;
end;
end;
until FindNext(f)<>0;
finally
FindClose(f);
end;
end;
begin
l:=TStringList.Create;
l.Text:=AnsiReplaceText(AnsiReplaceStr(GraphicFileMask(TGraphic),';',#13),'*',''); // Extraction de la liste des extensions graphiques connues
l.CaseSensitive:=False;
FPicture:=TPicture.Create;
FBitmap1:=TBitmap.Create;
FBitmap1.Width:=MainForm.ImageList1.Width;
FBitmap1.Height:=MainForm.ImageList1.Height;
FRect1:=Rect(0,0,FBitmap1.Width,FBitmap1.Height);
FBitmap2:=TBitmap.Create;
FBitmap2.Width:=MainForm.ImageList2.Width;
FBitmap2.Height:=MainForm.ImageList2.Height;
FBitmap2.PixelFormat:=pf24bit; // Format RGB24
SetStretchBltMode(FBitmap2.Canvas.Handle,HALFTONE); // Meilleur redimensionnement
FRect2:=Rect(0,0,FBitmap2.Width,FBitmap2.Height);
FSize:=FBitmap2.Width;
GetMem(FBuffer,FSize*SizeOf(Single)); // Buffer de travail...
MainForm.ListView1.Items.BeginUpdate; // Pour éviter des réaffichages multiples
try
ListFolder(MainForm.Edit1.Text,'');
finally
MainForm.ListView1.Items.EndUpdate;
FreeMem(FBuffer);
FBitmap2.Destroy;
FBitmap1.Destroy;
FPicture.Destroy;
l.Destroy;
if not Terminated then
Synchronize(Finished); // On cache la fenêtre de progression si elle est encore visible
end;
end;
procedure TSearchThread.Finished; // On cache la fenêtre de progression si elle est encore visible
begin
if SearchProgressForm.Visible then
SearchProgressForm.ModalResult:=mrOk;
end;
{ TCompareThread }
procedure TCompareThread.Execute;
var
a,b,c,n:Integer;
t:PSingleArray;
r,m:Single;
const
u:array[0..1,0..1] of Single=((0.25,1),(1,1));
function Dist(p,q:PSingleArray):Single; // Distance de 2 transformées d'ondelettes
var
a,b,c:Integer;
begin
Result:=0;
for a:=0 to n-1 do begin
if Result>m then // Si les 2 images sont déjà assez différentes, pas besoin de faire le calcul jusqu'au bout.
Exit;
for b:=0 to n-1 do
for c:=0 to 2 do
Result:=Result+t[n*a+b]*Abs(p[(n*a+b)*3+c]-q[(n*a+b)*3+c]); // Ajout des différences pondérées des 2 transformées en ondelettes
end;
end;
begin
n:=MainForm.ImageList2.Width;
GetMem(t,n*n*SizeOf(Single)); // Matrice de pondération multi-échelle
c:=1;
r:=1/16;
t[0]:=1;
while c<n do begin // remplissage de la matrice de pondérations
for a:=0 to c-1 do
for b:=0 to c-1 do begin
t[n*(a+c)+b]:=r*u[1,0];
t[n*a+b+c]:=r*u[0,1];
t[n*(a+c)+b+c]:=r*u[1,1];
end;
c:=2*c;
r:=r*u[0,0];
end;
m:=100-MainForm.TrackBar1.Position/10;
DecisionForm.Canceled:=False;
DecisionForm.CheckBox1.Checked:=False;
try
a:=0;
with MainForm do
while a<ListView1.Items.Count do begin
MainForm.CompareProgress:=a/(ListView1.Items.Count+1);
for b:=ListView1.Items.Count-1 downto a+1 do begin
FSimilarity:=100-Dist(ListView1.Items[a].Data,ListView1.Items[b].Data);
if (FSimilarity>=TrackBar1.Position/10) then begin
FFile1:=Edit1.Text+'\'+ListView1.Items[a].Caption;
FFile2:=Edit1.Text+'\'+ListView1.Items[b].Caption;
Synchronize(FileAction); // Synchronisation de l'affichage du dialogue de suppression
case FAction of // Mise à jour du ListView1 en fonction de l'action choisie par l'utilisateur
iaDelete1:begin
FreeMem(ListView1.Items[a].Data);
ListView1.Items.Delete(a);
Dec(a);
Break;
end;
iaDelete2:begin
FreeMem(ListView1.Items[b].Data);
ListView1.Items.Delete(b);
end;
end;
end;
if DecisionForm.Canceled or Terminated then // Action annulée...
Break;
end;
if DecisionForm.Canceled or Terminated then // Action annulée...
Break;
Inc(a);
end;
finally
FreeMem(t);
end;
if not Terminated then
Synchronize(Finished); // On ferme la fenêtre de progression si elle est encore visible...
end;
procedure TCompareThread.FileAction;
procedure DoDeleteFile(FileName:string); // Suppression d'un fichier
var
FOS:TSHFileOpStruct;
begin
if MainForm.ComboBox1.ItemIndex=1 then begin
if not DeleteFile(FileName) then // Suppression irréversible
RaiseLastOSError;
end else begin
ZeroMemory(@FOS,SizeOf(FOS)); // Envoi à la corbeille
with FOS do begin
wFunc:=FO_DELETE;
pFrom:=PChar(FileName+#0#0);
fFlags:=FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
end;
if ShFileOperation(FOS)<>0 then
RaiseLastOSError;
end;
end;
begin
FAction:=DecisionForm.Execute(FFile1,FFile2,FSimilarity); // On demande son avis à l'utilisateur...
case FAction of // Et on fait ce qu'il a décidé...
iaDelete1:DoDeleteFile(FFile1);
iaDelete2:DoDeleteFile(FFile2);
end;
end;
procedure TCompareThread.Finished;
begin
if CompareProgressForm.Visible then
CompareProgressForm.ModalResult:=mrOk; // On ferme la fenêtre de progression si elle est encore visible...
end;
{ TMainForm }
procedure TMainForm.FormCreate(Sender: TObject);
begin
Edit1.Text:=GetCurrentDir; // On se met dans le répertoire de travail
end;
procedure TMainForm.BitBtn1Click(Sender: TObject);
const
T:array[0..3] of Integer=(16,32,64,128); // Qualités de la transformée en ondelettes: Low, Average, Good, Very good
begin
ClearData; // On efface les données précédantes
ImageList2.Width:=T[ComboBox2.ItemIndex]; // La taille de ImageList2 va définir la taille de la transformée en ondelettes (en fonction de la qualité désirée)
ImageList2.Height:=T[ComboBox2.ItemIndex];
CurrentFolder:=''; // Initialisations diverses...
FileCount:=0;
FolderCount:=0;
with TSearchThread.Create(False) do begin // Lancement du thread de recherche
if SearchProgressForm.ShowModal=mrCancel then begin // Affichage de la fenêtre de progression: si l'utilisateur appuie dur "cancel"...
Terminate; // ...alors on arrête le thread
WaitFor;
end;
Destroy;
end;
GroupBox2.Caption:=Format('%d graphic files',[ListView1.Items.Count]); // Nombre de fichiers trouvés
BitBtn2.Enabled:=True; // On peut passer à l'étape suivante
end;
procedure TMainForm.SpeedButton1Click(Sender: TObject);
var
s:string;
begin
s:=Edit1.Text;
if SelectFolder(s) then begin // Changement du répertoire de recherche
Edit1.Text:=s;
ClearData;
end;
end;
procedure TMainForm.Smallicons1Click(Sender: TObject);
var
a:Integer;
begin // En fonction du menu coché, on adapte l'affichage du ListView
for a:=0 to PopupMenu1.Items.Count-1 do
if PopupMenu1.Items[a].Checked then
ListView1.ViewStyle:=TViewStyle(a);
end;
procedure TMainForm.ListView1Compare(Sender: TObject; Item1,
Item2: TListItem; Data: Integer; var Compare: Integer);
function BoolSgn(x:Boolean):Integer;
begin
if x then
Result:=1
else
Result:=-1;
if FAscendantOrder then
Result:=-Result;
end;
function StrToDim(s:string):Integer;
var
a:Integer;
begin
a:=Pos(' x ',s);
Result:=StrToInt(Copy(s,1,a-1))*StrToInt(Copy(s,a+3,Length(s)));
end;
begin
case FColumnSortID of // Différentes méthodes de comparaison en fonction de la colonne cliquée
0:Compare:=BoolSgn(Item1.Caption>Item2.Caption);
1:Compare:=BoolSgn(StrToDim(Item1.SubItems[0])>StrToDim(Item2.SubItems[0]));
2:Compare:=BoolSgn(StrToInt(Item1.SubItems[1])>StrToInt(Item2.SubItems[1]));
3:Compare:=BoolSgn(StrToDateTime(Item1.SubItems[2])>StrToDateTime(Item2.SubItems[2]));
end;
end;
procedure TMainForm.ListView1ColumnClick(Sender: TObject;
Column: TListColumn);
begin
if Column.Index=FColumnSortID then begin // Si on a cliqué 2 fois sur la même colonne
FAscendantOrder:=not FAscendantOrder; // alors on inverse l'ordre de classement
Ascendant1.Checked:=not FAscendantOrder; // Mise à jour du menu coché
Descendant1.Checked:=FAscendantOrder;
end;
FColumnSortID:=Column.Index;
PopupMenu2.Items[FColumnSortID].Checked:=True; // Mise à jour du menu coché
ListView1.CustomSort(nil,0); // on classe les items
end;
procedure TMainForm.ClearData; // libération de la mémoire occupée par les transformées en ondelette et on vide le ListView1
var
a:Integer;
begin
BitBtn2.Enabled:=False;
ListView1.Items.BeginUpdate;
try
for a:=0 to ListView1.Items.Count-1 do
FreeMem(ListView1.Items[a].Data);
ListView1.Clear;
finally
ListView1.Items.EndUpdate;
end;
ImageList1.Clear; // on efface les listes d'images
ImageList2.Clear;
ListView1.Repaint;
end;
procedure TMainForm.BitBtn2Click(Sender: TObject);
begin
with TCompareThread.Create(False) do begin // Lancement du thread de comparaison
if CompareProgressForm.ShowModal=mrCancel then begin // Si l'utilisateur annule l'opération
Terminate; // on arrête le thread
WaitFor;
end;
Destroy;
end;
GroupBox2.Caption:=Format('%d graphic files',[ListView1.Items.Count]); // Nombre de fichiers restants
end;
procedure TMainForm.TrackBar1Change(Sender: TObject);
begin
Panel1.Caption:=Format('Max similarity value: %f %%',[TrackBar1.Position/10]); // Mise à jour de l'interface
end;
procedure TMainForm.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
with ComboBox1,ComboBox1.Canvas do begin // Affichage des icônes de la ComboBox
if odSelected in State then
Brush.Color:=clHighlight;
Dec(Rect.Right,1);
FillRect(Rect);
ImageList4.Draw(Canvas,Rect.Left+1,Rect.Top,Index);
TextOut(Rect.Left+21,Rect.Top+2,Items[Index]);
end;
end;
procedure TMainForm.Descendant1Click(Sender: TObject);
begin
FAscendantOrder:=Ascendant1=Sender; // Changement de l'ordre d'affichage
ListView1ColumnClick(nil,ListView1.Columns[FColumnSortID]);
end;
procedure TMainForm.Bydate1Click(Sender: TObject);
begin
FColumnSortID:=PopupMenu2.Items.IndexOf(TMenuItem(Sender)); // Changement du critère d'affichage
ListView1ColumnClick(nil,ListView1.Columns[FColumnSortID]); // On range de nouveau les items
end;
procedure TMainForm.ComboBox2Change(Sender: TObject);
begin
ClearData; // On doit recalculer les transformées en ondelettes donc on efface tout
end;
end.
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.