Aide pour ce qui ressemble à un bug dans mon programme svp ...Résolu

Question

Bonjour,
Voici mon problème je cherche à réaliser une fonction qui récupere une image TBitmap la découpe en 16 zones égales et retourne un tableau de 16 images de même taille que l'original et représentant des portions agrandies de l'image d'origine.
Voici ma fonction : 
type
  TZonesCar = array[1..16] of TBitmap;
function TAnalysCar.DecoupeCar(car : TBitmap) : TZonesCar;// agrandit l'image
// 4 fois puis la découpe en 4col et 4 lignes
var zones :TZonesCar;
    gdImg : TBitmap;
    i,x,y,l,h : Integer;
begin
gdImg:=TBitmap.Create;
gdImg.FreeImage;
if not(car.Width mod 2 = 0)
   then gdImg.Width:=car.Width+1
   else gdImg.Width:=car.Width;
if not(car.Height mod 2 = 0)
   then gdImg.Height:=car.Height+1
   else gdImg.Height:=car.Height;
gdImg.FreeImage;
gdImg.Width:= gdImg.Width * 4;
gdImg.Height:= gdImg.Height * 4;
l:=gdImg.Width div 4;
h:=gdImg.Height div 4;
// ici agrandi image (stretch) merci delphiprog
gdImg.Canvas.StretchDraw(gdImg.Canvas.ClipRect, car);
for i:=0 to 15  do begin
  x:=(i mod 4)*l;                     <=== ici l vaut 22
  y:=(i div 4)*h;                      <=== ici h vaut 32
  zones[i]:=TBitmap.Create;    <=== ERREUR ICI : je suppose ...
  zones[i].Height:=h;                    <=== après l'appel de TBitmap.Create, h change de valeur (11032976) 
  zones[i].Width:=l;
  bitblt (zones[i].Canvas.Handle,0, 0, l, h, gdImg.Canvas.Handle, x, y, srccopy);
end;
Ca ressemble à un débordement de mon tableau zones je suppose mais je ne comprend pas où je me trompe. Merci d'avance de m'aiguiller dans la bonne direction :)

f0xi · Accepted Answer

sinon voila une petite modif qui fonctionne trés bien et affiche de bonne performances :

type
  TZoom = array[0..3,0..3] of TBitmap;

var
  ZM  : TZoom;
  BMP : TBitmap;

procedure CreateZoom(var Dest : TZoom);
var X,Y: integer;
begin
  for Y := 0 to 3 do
      for X := 0 to 3 do
          Dest[Y,X] := TBitmap.Create;
end;

procedure DestroyZoom(var Dest : TZoom);
var X,Y: integer;
begin
  for Y := 0 to 3 do
      for X := 0 to 3 do
          FreeAndNil(Dest[Y,X]);
end;

procedure CutZoom(Src : TBitmap; var Dest : TZoom);
var nX,nY,CX,CY,NW,NH : integer;
    Buffer : TBitmap;
begin
  NW := Src.Width  shl 2;
  NH := Src.Height shl 2;

  Buffer := TBitmap.Create;
  Buffer.Assign(Src);
  Buffer.Width  := NW;
  Buffer.Height := NH;
  Buffer.Canvas.StretchDraw(Rect(0,0,Buffer.Width,Buffer.Height),Src);

  CX := NW shr 2;
  CY := NH shr 2;

  for nY := 0 to 3 do 
      for nX := 0 to 3 do 
          with Dest[nY,nX] do begin
             PixelFormat := Buffer.PixelFormat;
             Width  := CX;
             Height := CY;
             Canvas.CopyRect( Rect(0, 0, CX, CY), 
                              Buffer.Canvas, 
                              Rect(nX*CX, nY*CY, (nX+1)*CX, (nY+1)*CY)
                             );
          end;
      
  Buffer.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  BMP := TBitmap.create;
  BMP.LoadFromFile('blablabla.bmp');
  CreateZoom(ZM);
  CutZoom(BMP,ZM);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  DestroyZoom(ZM);
  BMP.free;
end;

<hr size="2" width="100%" />Croc (click me)

f0xi · Answer

soit tu fait :

TZonesCar = array[0..15] of TBitmap;

sinon tu fait :

for i := 0 to 15  do begin
  x:=(i mod 4)*l; 
  y:=(i div 4)*h; 
  zones[i+1]:=TBitmap.Create;
  zones[i+1].Height:=h;                
  zones[i+1].Width:=l;
  bitblt (zones[i+1].Canvas.Handle,0, 0, l, h, gdImg.Canvas.Handle, x, y, srccopy);
end;

<hr size="2" width="100%" />Croc (click me)

japee · Answer

Hello,

Oui, tu déclares un array[1..16] of TBitmap, mais dans ta fonction tu fais une boucle i := 0 to 15...

De plus, tu libères plusieurs fois gdImg, ça coince.

A mon avois, tu peux simplifier :
if not(car.Width mod 2 = 0)
   then gdImg.Width:=car.Width+1
   else gdImg.Width:=car.Width;
if not(car.Height mod 2 = 0)
   then gdImg.Height:=car.Height+1
   else gdImg.Height:=car.Height;
gdImg.Width:= gdImg.Width * 4;
gdImg.Height:= gdImg.Height * 4;

ainsi :
gdImg.Width := (car.Width + car.Width mod 2) * 4;
gdImg.Height := (car.Height + car.Height mod 2) * 4;

Voici pour finir le code retouché, j'ai testé, ça fonctionne aux petits oignons :

type
  TZonesCar = array[1..16] of TBitmap;

var
  ZonesCar: TZonesCar;

procedure FreeZonesCar;
var i: Integer;
begin
  for i := 1 to 16 do
    if Assigned(ZonesCar[i]) then
      ZonesCar[i].Free;
end;

function DecoupeCar(car : TBitmap) : TZonesCar;
var gdImg : TBitmap;
    i,x,y,l,h : Integer;
begin
  gdImg:=TBitmap.Create;
  gdImg.Width := (car.Width + car.Width mod 2) * 4;
  gdImg.Height := (car.Height + car.Height mod 2) * 4;
  l:=gdImg.Width div 4;
  h:=gdImg.Height div 4;
  gdImg.Canvas.StretchDraw(gdImg.Canvas.ClipRect, car);
  for i:=1 to 16  do
  begin
    x:=(i mod 4)*l;
    y:=(i div 4)*h;
    Result[i] := TBitmap.Create;
    Result[i].Height:=h;
    Result[i].Width:=l;
    bitblt (Result[i].Canvas.Handle,0, 0, l, h, gdImg.Canvas.Handle, x, y, srccopy);
  end;
  gdImg.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin  // test
  ZonesCar := DecoupeCar(Image1.Picture.Bitmap);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FreeZonesCar; // libérer les TImages du tableau
end;

Et n'oublie pas de libérer ton tableau de Bitmaps quand tu n'en as plus besoin (avant de fermer l'appli par exemple) avec la procedure FreeZonesCar.

Tout ça m'a épuisé, je vais me coucher... 

Bonne nuit everybody,

japee

japee · Answer

Salut f0xi,

J'ai décidément encore un train de retard... 

Mais bon, le sujet m'intéressait, je m'y suis absorbé, quoi... 

A +

cerber943 · Answer

Merci à tous pour vos réponses complètes et rapides,

Japee j'ai testé tes modifs, c'est exactement ce que j'espérais.

f0xie je n'ai pas encore eu le temps de tester ta réponse qui semble intéressante, je chercherais à optimiser ensuite donc tes conseils m'intéresse ;)
Si j'ai bien compris je remplace :
      - les x / 2 par x shl 2 ?
      - l'utilisation de bitblp par canvas.copyrect ?
      - et le tableau de 16 cases par un tableau à 2 dimensions de 4x4 (est ce pour simplifier les déplacement ou cela apporte-il autre chose ?)

Bien que la réponse soit accepté, je serais intéressé par une explication sur les points précédents.
Encore merci à vous !

japee · Answer

Salut,

En fait, il faut opter pour un tableau de 0..15, sinon les calculs sont faussés.
Ce qui donne :

type
  TZonesCar = array[0..15] of TBitmap;

var
  ZonesCar: TZonesCar;

procedure FreeZonesCar;
var i: Integer;
begin
  for i := 0 to 15 do
    if Assigned(ZonesCar[i]) then
      ZonesCar[i].Free;
end;

function DecoupeCar(car : TBitmap) : TZonesCar;
var gdImg : TBitmap;
    i,x,y,l,h : Integer;
begin
  gdImg:=TBitmap.Create;
  gdImg.Width := (car.Width + car.Width mod 2) * 4;
  gdImg.Height := (car.Height + car.Height mod 2) * 4;
  l:=gdImg.Width div 4;
  h:=gdImg.Height div 4;
  gdImg.Canvas.StretchDraw(gdImg.Canvas.ClipRect, car);
  for i:=0 to 15  do
  begin
    x:=(i mod 4)*l;
    y:=(i div 4)*h;
    Result[i] := TBitmap.Create;
    Result[i].Height:=h;
    Result[i].Width:=l;
    bitblt (Result[i].Canvas.Handle,0, 0, l, h, gdImg.Canvas.Handle, x, y, srccopy);
  end;
  gdImg.Free;
end;

Cette fois c'est la bonne !

Bonne prog'

cerber943 · Answer

Yes merci japee !
J'espère néanmoins avoir toujours quelques nouvelles de f0xie concernant l'optimisation de ce code ...
A bientôt ;)

f0xi · Answer

bah les seules que je vois c'est ça (en reprennant le code de japee) :

type
  TZonesCar = array[0..15] of TBitmap;

var
  ZonesCar: TZonesCar;

procedure FreeZonesCar;
var i: Integer;
begin
  for i := 0 to 15 do
    if Assigned(ZonesCar[i]) then
      ZonesCar[i].Free;
end;

procedure DecoupeCar(car : TBitmap; var ZoneCar : TZonesCar);
var gdImg : TBitmap;
    i,x,y,l,h : Integer;
begin
  gdImg := TBitmap.Create;
  with gdImg do begin
     Width  := (car.Width  + car.Width mod 2) shl 2;
     Height := (car.Height + car.Height mod 2) shl 2;
     l := Width shr 2;
     h := Height shr 2;
     Canvas.StretchDraw(Canvas.ClipRect, car);
  end;
  for i:=0 to 15  do
  begin
    x := (i mod 4) * l;
    y := (i shr 2) * h;
    ZoneCar[i] := TBitmap.Create;
    with ZoneCar[i] do begin
       Height := h;
       Width  := l;
       bitblt(Canvas.Handle,0, 0, l, h, gdImg.Canvas.Handle, x, y, srccopy);
    end;
  end;
  gdImg.Free;
end;

par contre je vois pas trop pourquoi l'utilisation de BitBlt. Canvas.CopyRect fonctionne aussi bien .

<hr size="2" width="100%" />Croc (click me)

cerber943 · Answer

Ok merci
Concernant l'utilisation de bitblt, je ne connaissais pas CopyRect et je m'étais inspiré d'un code sur ce site de reconnaissance de caractères où il utilisait cette fonction la pour extraire une portion de l'écran dans un TBitmap. Mais je vais utiliser CopyRect pour être un peu plus cohérent ;)

Encore merci à vous

Aide pour ce qui ressemble à un bug dans mon programme svp ...

9 réponses

Votre réponse

Discussions similaires