Discussion :

[cincap]

Os XP et Delphi 6

Bonjour à toutes et à tous,

Dans une application, je réalise un redimensionnement (paramétrable) sur toutes les photos contenues dans un dossier en utilisant un TlistBox.

Ma question, avec un seul Tedit, serait t'il possible d'écrire un texte dans le bas droit de chaque image et être appliqué en une seule fois soit sur ce lot de photos ?

Personnellement cela me paraît compliqué mais on ne sait jamais.

Merci d'avance.

@+,

Cincap

[Droïde Système7]

Ça ne doit pas être le Pérou

Sachant que tu peux écrire dans cette image au travers son Canvas et via sa procédure TextOut.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Img01.Canvas.TextOut(70, 20, GetOldLed);

Alors avec une boucle chargeant tes pictures dans un dossier affecté ; au passage à chacune tu écris dessus...

@+

[Montor]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
with Img01 do 
    Canvas.TextOut(right-Canvas.TextWide, bottom-Canvas.Texthieght, GetOldLed);

[cincap]

Bonjour à toutes et à tous,

@ Droïde Système7 et @ Montor, merci pour vos réponses.

Donc à partir du code qui sert à dimensionner tous le lot d'images (admettons 10 images) il serait possible d'ajouter un texte car j'ai déjà une boucle.

Par contre, dans vos propositions, je ne vois pas ou je rentre mon texte !

Le but serait de pouvoir modifier sa couleur et le fond de couleurs en transparence.

Code de redimentionnement que j'utilise : lbFiles = Tlistbox

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
 
---
 if lbFiles.Items.Count = 0 then
  begin
    MessageDlg(GNoImages, mtError, [mbAbort], 0);
    Exit;
  end;
 
  try
    SetControlsEnabled(Self, False);
    FRedimThread := TRedimThread.Create;
    with FRedimThread do
    begin
      FreeOnTerminate := True;
      OnProgress := RedimFile;
      OnTerminate := RedimTerminate;
      SourceFiles.Assign(lbFiles.Items);
      DestDir := EdtDestDirectory.Text;
      Width := StrToInt(FrmOptions.EdtWidth.Text);
      Height := StrToInt(FrmOptions.EdtHeight.Text);
      Quality := StrToInt(FrmOptions.EdtQuality.Text);
      BackgroundColor := FrmOptions.ColorBox.Selected;
      if FrmOptions.rbFixedDimentions.Checked then
        Method := rmFixedSize
      else
        Method := rmMaxSize;
     // PB.Min := 0;
      PB.Maximum := SourceFiles.Count;
 
      PB.Position := 0;
      Resume;
         end;
  except
    SetControlsEnabled(Self, True);
    raise;
  end;

@ Montor, ton code génère ceci :

[Erreur] Unit1.pas(30): Identificateur non déclaré : 'right'
[Erreur] Unit1.pas(30): Identificateur non déclaré : 'TextWide'
[Erreur] Unit1.pas(30): Identificateur non déclaré : 'Texthieght'
[Erreur] Unit1.pas(30): Identificateur non déclaré : 'GetOldLed'
[Erreur fatale] Project1.dpr(5): Impossible de compiler l'unité utilisée 'Unit1.pas'

@+,

Cincap

[Archimède]

En effet, il ya du soucis....lol

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Canvas.TextOut(canvas.cliprect.right-Canvas.TextWidth, canvas.cliprect.bottom-Canvas.Textheight, GetOldLed ?);

GetoldLed ? ton texte...
J'ai pas regardé ton code.

[cincap]

@ Archimède et @ Droïde Système7, bien entendu, j'avais supposé l'erreur concernant le Tedit dans mon dernier test.

Mais ce code telquel présente aussi une erreur "Pas assez de paramètres originaux".

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Canvas.TextOut(canvas.cliprect.right-Canvas.TextWidth, ici canvas.cliprect.bottom-Canvas.Textheight, Edit1.Text);

Autant pour moi, j'avais effacé les variables !
je suis en erreur

Ceci dit le tout est de l'insérer dans ma boucle qui existe déjà mais c'est une autre histoire !

@+,

Cincap

[Montor]

le code cité contient des errrurs ... je vais revenir ...

[Droïde Système7]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Canvas.TextOut(canvas.cliprect.right-Canvas.TextWidth(Text), canvas.cliprect.bottom-Canvas.Textheight(Text), Edit1.Text);

[Montor]

voici le bon code mais pas de transparance...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
procedure TForm1.BitBtn1Click(Sender: TObject);
 var Sz:TSize;
 S:string;
begin
   S:='456465465465';
   with Image1 do
   begin
     Sz:=Canvas.TextExtent(S);
     Sz.cx:=Width-Sz.cx;
     Sz.cy:=Height -Sz.cy;
     Canvas.TextOut(Sz.cx-1,Sz.cy-1,S);
  end;
end;

[cincap]

@ Montor et @ Droïde Système7, c'est correct vos deux solutions, merci de perdre votre temps.

Reste à l'implanter dans mon code actuel et là bug sur bug jusqu'à présent :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
 
---
 if lbFiles.Items.Count = 0 then
  begin
    MessageDlg(GNoImages, mtError, [mbAbort], 0);
    Exit;
  end;
 
  try
    SetControlsEnabled(Self, False);
    FRedimThread := TRedimThread.Create;
    with FRedimThread do
    begin
      FreeOnTerminate := True;
      OnProgress := RedimFile;
      OnTerminate := RedimTerminate;
      SourceFiles.Assign(lbFiles.Items);
      DestDir := EdtDestDirectory.Text;
      Width := StrToInt(FrmOptions.EdtWidth.Text);
      Height := StrToInt(FrmOptions.EdtHeight.Text);
      Quality := StrToInt(FrmOptions.EdtQuality.Text);
      BackgroundColor := FrmOptions.ColorBox.Selected;
      if FrmOptions.rbFixedDimentions.Checked then
        Method := rmFixedSize
      else
        Method := rmMaxSize;
     // PB.Min := 0;
      PB.Maximum := SourceFiles.Count; //TProgressBar
 
      PB.Position := 0;
      Resume;
         end;
  except
    SetControlsEnabled(Self, True);
    raise;
  end;

@+,

Cincap

[Droïde Système7]

Transparence...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Brush.Style := bsClear;

@+

[cincap]

@ Droïde Système7, avec ton code, je n'ai pas tout ce qui se trouve dans mon Tedit avec celui de Montor c'est correct.

La transparence ne fonctionne pas.

autant pour moi, il fallait que je rajoute :

Canvas.Brush.Style := bsClear;

@+,

Cincap

[cincap]

Ohé, il y a quelqu'un !

Pour la boucle, faut il rappeller les photos après le traitement du redimensionnement et puis appliquer le texte, puisque nous avons le dossier ou se trouvent les photos retravaillées ou...

Mes tests sont holé holé.

Pour info voici le code pour le traitement :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
 
 
---
 if lbFiles.Items.Count = 0 then
  begin
    MessageDlg(GNoImages, mtError, [mbAbort], 0);
    Exit;
  end;
 
  try
    SetControlsEnabled(Self, False);
    FRedimThread := TRedimThread.Create;
    with FRedimThread do
    begin
      FreeOnTerminate := True;
      OnProgress := RedimFile;
      OnTerminate := RedimTerminate;
      SourceFiles.Assign(lbFiles.Items);
      DestDir := EdtDestDirectory.Text;
      Width := StrToInt(FrmOptions.EdtWidth.Text);
      Height := StrToInt(FrmOptions.EdtHeight.Text);
      Quality := StrToInt(FrmOptions.EdtQuality.Text);
      BackgroundColor := FrmOptions.ColorBox.Selected;
      if FrmOptions.rbFixedDimentions.Checked then
        Method := rmFixedSize
      else
        Method := rmMaxSize;
     // PB.Min := 0;
      PB.Maximum := SourceFiles.Count; //TProgressBar
 
      PB.Position := 0;
      Resume;
         end;
  except
    SetControlsEnabled(Self, True);
    raise;
  end;

A moins qu'il ne faudrait le code de la procédure "FRedimThread".

Merci de me tenir au courant.

@+,

Cincap

[Montor]

voici le code opérationnel tu n'as qu'a le mettre dans Exceute de thread

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
 
procedure SaveJPG(const FileName:string;AInPut:TBitmap;ACompress:byte);
var
   ImJPEG : TJPEGImage;
begin
     if not Assigned(AInPut) then Exit;
     ImJPEG := TJPEGImage.Create;
     try
       ImJPEG.Assign(AInPut);
       ImJPEG.CompressionQuality:=ACompress;
       ImJPEG.Compress();
       ImJPEG.SaveToFile(Filename);
     finally
       ImJPEG.Free();
     end;
end;
 
 
procedure ImgResize(ABitmap:TBitmap;H,W:integer);
var
  Bmp,t:TBitmap;
begin
  if not Assigned(ABitmap) then Exit;
  Bmp:=TBitmap.Create() ;
  Bmp.Assign(ABitmap);
  try
    with ABitmap do
    begin
     Height :=  H;
     Width  :=  W;
     Canvas.CopyRect(Canvas.ClipRect,Bmp.Canvas,Bmp.Canvas.ClipRect);
    end;
  finally
    Bmp.Free()
  end;
end;
 
function LoadImage(const FileName:string;AOut:TBitmap):boolean;
var
   ImJPEG : TJPEGImage;
   Ext:string;
begin
    result:=false;
    if not Fileexists(FileName) then Exit;
    if not Assigned(Aout) then Exit;
 
    Ext:=ExtractFileext(FileName);
 
   if SameText(Ext,'.JPG') then
    begin
       ImJPEG := TJPEGImage.Create;
       try
        ImJPEG.LoadFromFile(FileName);
        AOut.Assign(ImJPEG);
        result:=true;
       finally
        ImJPEG.Free();
       end;
    end
   else if SameText(Ext,'.BMP') then
    begin
       AOut.LoadFromFile(Filename);
       result:=true;
    end;
end;
 
procedure ProcessImg(const inFilname,outFilname,Txt:string;
                    Quality:byte;
                    NewH,NewW:integer;AFont:TFont=nil);
var
  Sz  :TSize;
  bmp :TBitmap;
begin
   if not Fileexists(inFilname) then Exit;
   if Trim(Txt)='' then Exit;
   bmp :=TBitmap.Create();
   try
     if  LoadImage(inFilname,bmp) then
     with bmp do
     begin
         ImgResize(bmp,NewH,NewW);
         if Assigned(AFont) then
         begin
            Canvas.Font:= AFont;
         end;
         Canvas.Brush.Style:=bsClear;
         Sz:=Canvas.TextExtent(Txt);
         Sz.cx:=Width  -Sz.cx;
         Sz.cy:=Height -Sz.cy;
         Canvas.TextOut(Sz.cx-1,Sz.cy-1,Txt);
         SaveJPG(outFilname,bmp,Quality);
    end;
   finally
     bmp.Free();
   end;
end;

execution

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  sPath,dFile:string;
  i:integer;
begin
  sPath := 'C:\dest'; {dossier de destination}
  sPath:=IncludeTrailingBackslash(sPath);
  if not DirectoryExists(sPath)then Exit;
 
  for i := 0 to lbFiles.Items.Count-1 do
  begin
     dFile:=sPath+ChangeFileExt(ExtractFilename(lbFiles.Items[i]),'.jpg') ;
     ProcessImg
           (
              lbFiles.Items[i],  {fichier source}
              dFile,             {fichier destination}
              '1111111111111111',{texte a ajouter}
              80,                {Compression Quality }
              400,               {Height}
              400,               {Width}
              nil                {size,style,police,couleur de Font => memo1.Font}
           );
 
  end;
end;

[cincap]

@ Montor, merci pour ton code, petite question quand tu me dis de mettre ce code dans exécute de thread, c'est dans sa propre procédure ou dans le code du boutton pour redimentionner déjà cité ?

Complètement à la traîne cette fois, je testerai demain.

Bonsoir à tous.

@+,

Cincap

[Montor]

normalement c'est dans l Execute de TRedimThread
j'ai testé le code il marche pour les image jpg bmp
ADieu

[cincap]

Bonjour à toutes et à tous;

@ Montor, tu avais l'unité URedimThread.pas pour ton test car sinon la voiçi et ma question se portait sur s'il fallait virer ce qui était dans la procédure execute de cette unité et remplacer par ton code ou placer ton code dans la fiche principale au niveau du code du boutton appliquer le resize dont le code est communiqué, parceque là je suis perdu ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
 
unit URedimThread;
 
interface
 
uses
  SysUtils, Classes, Graphics, ImageUtils;
 
type
  TRedimMethod = (rmMaxSize, rmFixedSize);
 
  TRedimProgressEvent = procedure (ActualFile, NumFiles: Integer) of object;
 
  TRedimThread = class(TThread)
  private
    FWidth: Integer;
    FHeight: Integer;
    FQuality: Integer;
    FMethod: TRedimMethod;
    FBackColor: TColor;
    FSourceFiles: TStringList;
    FActualFile: Integer;
    FDestDir: string;
    FOnProgress: TRedimProgressEvent;
  protected
    procedure Execute; override;
    procedure DoProgress;
  public
    constructor Create;
    destructor Destroy; override;
    property SourceFiles: TStringList read FSourceFiles;
    property DestDir: string read FDestDir write FDestDir;
    property Width: Integer read FWidth write FWidth;
    property Height: Integer read FHeight write FHeight;
    property Quality: Integer read FQuality write FQuality;
    property Method: TRedimMethod read FMethod write FMethod;
    property BackgroundColor: TColor read FBackColor write FBackColor;
    property OnProgress: TRedimProgressEvent read FOnProgress write FOnProgress;
  end;
 
implementation
 
constructor TRedimThread.Create;
begin
  inherited Create(True);
  FWidth := 100;
  FHeight := 100;
  FQuality := 90;
  FMethod := rmFixedSize;
  FBackColor := clWhite;
  FSourceFiles := TStringList.Create;
end;
 
destructor TRedimThread.Destroy;
begin
  FSourceFiles.Free;
  inherited Destroy;
end;
 
procedure TRedimThread.Execute;
var
  SourceBmp, DestBmp: TBitmap;
  W, H: Integer;
  DestFileName: string;
begin
  FActualFile := 0;
  FDestDir := IncludeTrailingPathDelimiter(FDestDir);
  while not Terminated and (FActualFile < FSourceFiles.Count) do
  begin
    {>> Trouve le nom de fichier de destination }
    DestFileName := FDestDir + ExtractFileName(FSourceFiles[FActualFile]);
    DestFileName := ChangeFileExt(DestFileName, '.jpg');
 
    {>> Traitement suivant la mthode }
    case FMethod of
      rmMaxSize:
      begin
        SourceBmp := TBitmap.Create;
        try
          LoadImage(FSourceFiles[FActualFile], SourceBmp);
          W := FWidth;
          H := FHeight;
          CalcSize(SourceBmp.Width, SourceBmp.Height, W, H);
          DestBmp := CreateBmp(W, H);
          try
            StretchGraphic(SourceBmp, SourceBmp.Canvas.ClipRect,
              DestBmp, DestBmp.Canvas.ClipRect);
            SaveBitmapAsJpeg(DestFileName, DestBmp, FQuality);
          finally
            DestBmp.Free;
          end;
        finally
          SourceBmp.Free;
        end;
      end;
 
      rmFixedSize:
      begin
        DestBmp := CreateBmp(FWidth, FHeight);
        try
          LoadImage(FSourceFiles[FActualFile], DestBmp, FBackColor);
          SaveBitmapAsJpeg(DestFileName, DestBmp, FQuality);
        finally
          DestBmp.Free;
        end;
      end;
    end;
 
    {>> Evenement }
    DoProgress;
    Inc(FActualFile);
  end;
end;
 
procedure TRedimThread.DoProgress;
begin
  if Assigned(FOnProgress) then
    FOnProgress(FActualFile, FSourceFiles.Count);
end;
 
end.

Merci au cas ou l'adieu n'était qu'un aurevoir.

@+,

Cincap

[cincap]

Bon, je vais délester ce topic puisque malgré mes tests, je bug.

Merci à tous ceux qui ont proposé une aide.

@+,

Cincap

[Montor]

pas obligatoire pour utiliser TRedimThread

j'avais fais le test avec SpeedButton tu peux voir sur le code tu dois faire un minimum effort bien lire le code c'e pas la première fois que tu fais ça

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

procedure TForm1.SpeedButton1Click(Sender: TObject);

[cincap]

@ Montor,

je pensais avoir bien lu ton code, mais lors de mes tests, j'avais une exception au niveau de "ProcessImg" identificateur non déclaré donc conséquence j'ai abandonné.

Voila voilou,

Edit: Ok je constate l'erreur due aux nombreux tests, seul bémol, les photos ne sont plus de qualité.

Autant pour moi, avec des dimensions 400x400 c'était normal.

et encore merci à tous et spécialement à Montor.

@+,

Cincap