remplissage de zones de couleur avec scanline

**Basile le disciple** · 16/05/2013, 19h28

Bonjours tout le monde

Je voudrais, en utilisant scanline, remplir en jaune des zones de couleur différentes. Par exemple,si la couleur désignée par le pointeur de la souris est égale au rouge, alors toutes les zones rouges seront remplies de jaune. J'ai donc fait une procédure qui évidemment ne marche pas...

Et j'aimerais bien savoir pourquoi!!!
Voici ma procédure :

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
 
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;
 
type
  TRGBArray = array[0..10000] of TRGBTriple;
  pTRGBArray = ^TRGBArray;
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormDestroy(Sender: TObject);
  private
    { Déclarations privées }
    bmp : TBitmap;
    col : TColor;
    procedure fond(bitmap : TBitmap);
    function TripletoColor(RGBTriple : TRGBTriple) : TColor;
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
const
  tab : array[1..3] of TColor = (clred,clblue,$00FF00);
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered:=true;
  bmp:=TBitmap.Create;
  ClientWidth:=Image1.Picture.Width;
  ClientHeight:=Image1.Picture.Height;
  Paintbox1.Align:=AlClient;
  With bmp do
  begin
    Width:=self.Width;
    Height:=self.Height;
    PixelFormat:=pf24bit;
    Canvas.Draw(0,0,Image1.Picture.Metafile);
  end;
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  fond(bmp);
  Paintbox1.Canvas.Draw(0,0,bmp);
end;
 
procedure TForm1.fond(bitmap : TBitmap);
var bmp2 : TBitmap;
    x,y,i : integer;
    p : pTRGBArray;
begin
  bmp2:=TBitmap.Create;
  With bmp2 do
  begin
    PixelFormat:=pf24Bit;
    Assign(Bitmap);
  end;
  if col <> clyellow then bmp.Canvas.Draw(0,0,Image1.Picture.Metafile);
  For i:=1 to 3 do
  begin
  if col = tab[i] then
  begin
    For x:=0 to bitmap.Height-1 do
    begin
      p:=bmp2.ScanLine[x];
        For y:=0 to bmp2.Width-1 do
        begin
          if TripleToColor(p[y]) = tab[i]   then
          begin
            p[y].rgbtBlue:=0;
            p[y].rgbtGreen:=255;
            p[y].rgbtRed:=255;
          end;
        end;
        end;
       end;
    end;
  bitmap.Assign(bmp2);
  bmp2.Free;
end;
 
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  col:=getPixel(bmp.Canvas.Handle,x,y);
  Paintbox1.Invalidate;
end;
 
function TForm1.TripletoColor(RGBTriple : TRGBTriple) : TColor;
begin
  result:=rgb(RGBTriple.rgbtRed,RGBTriple.rgbtGreen,RGBTriple.rgbtBlue);
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  bmp.Free;
end;
 
end.

Ci joint mon image :

**ShaiLeTroll** · 17/05/2013, 09h47

Pour une seule zone, utilise FloodFill

Pour toute la couleur dans l'ensemble de l'image, ton algo me semble très complexe avec toutes ces boucles imbriquées

Envoyé par Basile le disciple

JJ'ai donc fait une procédure qui évidemment ne marche pas...

Et j'aimerais bien savoir pourquoi!!!

Faudrait nous dire en quoi cela ne fonctionne, on n'a pas forcément le temps de tester ton code, une réponse théorique est souvent suffisante pour t'orienter

MouseMove c'est un peu violent, un OnMouseDown ou un OnClick serait moins brutale pour commencer

le MouseMove pouvant se produire plusieurs fois avant même que le OnPaint réagisse

Sinon au lieu de TripleToColor, tu devrais plutôt faire une ColorToTriple, cela serait plus rapide

D'ailleurs pourquoi faire le Invalidate lors du OnMouseMove si tu sais déjà que Col ne sera pas égale à Rouge

Code :

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

1
2
3
4
5
6
7
8
9
  col:=getPixel(bmp.Canvas.Handle,x,y);
 
  doInv := false; 
  For i:=1 to 3 do
    if col = tab[i] then  
      doInv := true;
 
  if doInv then
     Paintbox1.Invalidate;

pour info, il existe clGreen

Code :

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

1
2
 
if col <> clyellow then bmp.Canvas.Draw(0,0,Image1.Picture.Metafile);

Etrange cette ligne, tu écrits dans le membre bmp mais la locale bitmap c'est le même objet passé à fond(), au final cela ne sert à rien puisque bmp2 remplace via Assign le contenu de Bitmap

**Gilbert Geyer** · 17/05/2013, 14h32

Bonjour,

Basile le disciple : Je voudrais, en utilisant scanline,...

Comme le disait ShaiLeTroll "Pour une seule zone, utilise FloodFill" c'est bien plus simple qu'avec Scanline ... mais si tu veux t'habituer à utiliser les Scanlines voici un bout de code qui marche :

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
function ColorVersRGBQuad(cl: tColor): tRGBQuad;
begin
  with Result do begin
    rgbRed := GetRValue(cl);
    rgbGreen := GetGValue(cl);
    rgbBlue := GetBValue(cl);
  end;
end;
 
function RGBQuadVersColor(c3: TRGBQuad): tColor;
begin
  Result := RGB(c3.rgbRed, c3.rgbGreen, c3.rgbBlue);
end;
 
function clQuadEgales(c1, c2: tRGBQuad): boolean;
begin
  Result := (c1.rgbRed = c2.rgbRed) and (c1.rgbGreen = c2.rgbGreen) and (c1.rgbBlue = c2.rgbBlue);
end;
 
procedure SwapColors(Bmp: TBitmap; const clOrigine, clRemplace: TColor);
var
  i: Integer; Pix: PRGBQuad;
  clQO, clQR: TRGBQuad;
begin
  if (bmp = nil) then EXIT;
 
  clQO := ColorVersRGBQuad(clOrigine); clQR := ColorVersRGBQuad(clRemplace);
 
  BMP.PixelFormat := pf32bit;
  Pix := Bmp.ScanLine[bmp.height - 1];
 
  for i := 0 to BMP.Width * BMP.height - 1 do begin
    if clQuadEgales(Pix^, clQO) then Pix^ := clQR;
    Inc(Pix);
  end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  SwapColors(ImageFond.Picture.Bitmap, clRed, clYellow);
  ImageFond.Repaint;
end;

... bon dans cet exemple j'appelle SwapColors dans un Button1Click() pour remplacer les Rouges par du Jaune mais vaut mieux l'appeler dans un OnMouseDown comme le conseille ShaiLeTroll

A+.

**Gilbert Geyer** · 17/05/2013, 15h50

Re-bonjour,

A Basile le disciple : voici quand-même ton code rectifié et incluant des commentaires qui t'éclaireront la lanterne à propos de

Et j'aimerais bien savoir pourquoi!!!

il ne fonctionnait pas.

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
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ExtCtrls;
 
type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Déclarations privées }
    bmp: TBitmap;
    col: TColor;
    procedure Fond(bitmap: TBitmap);
    function TripletoColor(RGBTriple: TRGBTriple): TColor;
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
type
  TRGBArray = array[0..10000] of TRGBTriple;
  pTRGBArray = ^TRGBArray;
 
const
  tab: array[1..3] of TColor = (clred, clblue, $00FF00);
 
function TForm1.TripletoColor(RGBTriple: TRGBTriple): TColor;
begin
  result := rgb(RGBTriple.rgbtRed, RGBTriple.rgbtGreen, RGBTriple.rgbtBlue);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := true;
  bmp := TBitmap.Create;
  //ClientWidth := Image1.Picture.Width;
  //ClientHeight := Image1.Picture.Height;
  //Paintbox1.Align := AlClient; <- AVEC ves 3 lignes Image1 recouvre entièrement la Paintbox1
  with bmp do
  begin
    Width := Image1.Picture.bitMap.Width; //self.Width;
    Height := Image1.Picture.bitMap.Height; // self.Height;
    PixelFormat := pf24bit;
    Canvas.Draw(0, 0, Image1.Picture.bitMap); //Metafile);
  end;
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  fond(bmp);
  Paintbox1.Canvas.Draw(0, 0, bmp);
end;
 
procedure TForm1.fond(bitmap: TBitmap);
var bmp2: TBitmap;
  x, y, i: integer;
  p: pTRGBArray;
begin
  bmp2 := TBitmap.Create;
  with bmp2 do
  begin
    PixelFormat := pf24Bit;
    Assign(Bitmap);
  end;
  if col <> clyellow then bmp.Canvas.Draw(0, 0, Image1.Picture.bitMap); //Metafile);
  for i := 1 to 3 do
  begin
    if col = tab[i] then
    begin
      for x := 0 to bitmap.Height - 1 do
      begin
        p := bmp2.ScanLine[x];
        for y := 0 to bmp2.Width - 1 do
        begin
          if TripleToColor(p[y]) = tab[i] then
          begin
            p[y].rgbtBlue := 0;
            p[y].rgbtGreen := 255;
            p[y].rgbtRed := 255;
          end;
        end;
      end;
    end;
  end;
  bitmap.Assign(bmp2);
  bmp2.Free;
end;
 
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
    col := getPixel(bmp.Canvas.Handle, x, y);
    PaintBox1Paint(Sender);  // <- Ajouté
end;
 
end.

Remarque : Quand je clique sur du Rouge de la PaintBox ses Rouges, Verts, et Bleus passent en Jaune, mais la première fois il faut cliquer deux fois puis si le troisième click s'effectue sur une couleur différente de ces dernières les couleurs initiales se rétablissent.

Pour arriver à faire fonctionner ton code j'ai été obligé :
1) de placer image1 à coté de la PaintBox de sorte que l'un ne cache pas l'autre comme c'était le cas avec ton FormCreate.
2) dans image1 j'ai placé un fichier *.bmp donc pas de MétaFile

A+.

**Basile le disciple** · 17/05/2013, 16h17

Merci beaucoup, je vais regardé toutes vos réponses avec attention.
Mais je suis obligé de mettre ma procédure dans le OnMouseMove de la Paintbox et d'utilisé une image vectorielle pour ne pas altérer sa qualité lors du redimensionnement.

En fait, je voudrais construire l’équivalent d'un petit Géographix pour moi(voici le lien :http://www.geographix.fr/).

Comme vous le voyez, je suis coincé!!!

P.S pour ShaiLeTroll je me suis rendu compte que clgreen n'est pas du vert pur et en cherchant j'ai trouvé que c'est cllime.

Merci encore pour vos remarques et commentaires très pertinents.

**ShaiLeTroll** · 17/05/2013, 17h31

Envoyé par Basile le disciple

P.S pour ShaiLeTroll je me suis rendu compte que clgreen n'est pas du vert pur et en cherchant j'ai trouvé que c'est cllime

Tout à fait, le "vrai" vert c'est clLime ($00FF00), et tu vois, je me fais avoir
clGreen c'est le vert foncé qui n'est que $008000
Ils ont fumés chez Borland quand ils ont choisi ces noms !

**ShaiLeTroll** · 17/05/2013, 17h40

Envoyé par Gilbert Geyer

Code :

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

1
2
3
4
 
  //ClientWidth := Image1.Picture.Width;
  //ClientHeight := Image1.Picture.Height;
  //Paintbox1.Align := AlClient; <- AVEC ves 3 lignes Image1 recouvre

Si Image1 est en Align alNone, tu peux lui donner la taille que tu veux, comme TImage et TPaintBox sont tous les deux des TGraphicControl, il suffit de jouer avec SendToBack\BringToFront

Faudrait surtout supprimer Image1 et utiliser TBitmap.LoadFromFile, cela éviterait les conflits de Z Order

Envoyé par Gilbert Geyer

Code :

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

1
2
3
4
5
6
7
 
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
    col := getPixel(bmp.Canvas.Handle, x, y);
    PaintBox1Paint(Sender);  // <- Ajouté
end;

Je ne suis pas trop d'accord !
Le Invalidate est justement bien plus élégant pour l'anti-clipping que l'appel manuel du gestionnaire OnPaint !
Là dès le moindre mouvement, cela dessine, le CPU doit en prendre un coup !

Envoyé par Gilbert Geyer

2) dans image1 j'ai placé un fichier *.bmp donc pas de MétaFile

C'est peut-être cela qui corrige son problème !
Vous n’êtes plus tous les deux dans les mêmes conditions

@Basile le disciple, le code qui suit est purement MetaFile une autre tout autre façon de procéder que ScanLine et devrait être plus performant avec le format EMF\WMF

Avec une Image Vectorielle, il a des techniques plus simples pour changer massivement une zone de couleur !
Il faut changer le 'scénario' de l'image

A partir de Metafile.Handle, tu peux utiliser EnumEnhMetaFile, la CallBack va te fournir les éléments qui composent le ficher WMF ou EMF qui sont des ENHMETARECORD, cherche les EMRCREATEPEN, EMRCREATEMONOBRUSH et peut être aussi EMREXTFLOODFILL (vu tes formes) et voir si tu peux substituer la valeur crColor et recréé ainsi l'image !

A lire Thread: Convert Metafile to gray scale dont voici le code reformaté et mis en situation

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
122
123
124
 
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;
 
type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Déclarations privées }
    tmpMF : TMetaFile;
 
    function ConvertMetaFileToYellow(MetaFile: TMetaFile, ExcludeColor: TColor): boolean;
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := true;
  ClientWidth := Image1.Picture.Width;
  ClientHeight := Image1.Picture.Height;
  Image1.Visible := false; // ou SendToBack();
 
  Paintbox1.Align := AlClient; 
  tmpMF := TMetaFile.Create(); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  tmpMF.Free;
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  tmpMF.Handle := CopyEnhMetafile(Image1.Picture.MetaFile.Handle, nil); // normalement tmpMF libéra la copie
  ConvertMetaFileToYellow(tmpMF, col);
  Paintbox1.Canvas.Draw(0,0, tmpMF);
end;
 
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin    
    col := getPixel(Image1.Picture.MetaFile, x, y);
    PaintBox1->Invalidate();
end;
 
// This function is called from EnumEnhMetaFile in the ConvertMetaFileToYellow procedure
function EnumCallBack_SetYellowColor(DC: HDC; var pHTable: THandleTable; var pEMFR: TEnhMetaRecord; nObj: integer; lpData: pointer): integer; stdcall;
begin
  case pEMFR.iType of
    EMR_CREATEPEN:
      begin
        with PEMRCreatePen(@pEMFR).lopn do
          if lopnColor = ColorToRGB(PColor(lpData)^) then
            lopnColor := ColorToRGB(clYellow);
      end;
 
    EMR_EXTCREATEPEN: 
      begin
        with PEMRExtCreatePen(@pEMFR).elp do
         if elpColor = ColorToRGB(PColor(lpData)^) then
           elpColor := ColorToRGB(clYellow);
      end;
 
    EMR_EXTFLOODFILL:
      begin
        with PEMRExtFloodFill(@pEMFR) do
         if crColor = ColorToRGB(PColor(lpData)^) then
           crColor := ColorToRGB(clYellow);
      end;
 
    EMR_CREATEBRUSHINDIRECT:
      begin
       with PEMRCreateBrushIndirect(@pEMFR).lb do
         if lbColor = ColorToRGB(PColor(lpData)^) then
           lbColor := ColorToRGB(clYellow);
    end;
 
    EMR_SETTEXTCOLOR, EMR_SETBKCOLOR: 
      begin
        with PEMRSETTEXTCOLOR(@pEMFR) do
          if crColor = ColorToRGB(PColor(lpData)^) then
            crColor := ColorToRGB(clYellow);
    end;
 
    EMR_BITBLT, 
    EMR_STRETCHBLT, 
    EMR_STRETCHDIBITS, 
    EMR_MASKBLT,
    EMR_PLGBLT: begin
      // TODO: change integrated image to gray scale...
    end
  end;
 
  if DC <> 0 then
    PlayEnhMetaFileRecord(DC, pHTable, pEMFR, nObj);
 
  Result:=1;
end;
 
function TForm1.ConvertMetaFileToYellow(MetaFile: TMetaFile, ExcludeColor: TColor): boolean;
var
   R: TRect;
begin
  R := Rect(0, 0, Metafile.Width, MetaFile.Height);
  Result := EnumEnhMetaFile(0, MetaFile.Handle,@EnumCallBack_SetYellowColor, @ExcludeColor, R);
end;

**Gilbert Geyer** · 18/05/2013, 10h39

Bonjour,

ShaiLeTroll : Je ne suis pas trop d'accord !

En fait je ne me suis pas trop cassé la tête, d'abord je voulais trouver pourquoi ça ne fonctionnait pas, et ensuite quand j'ai remarqué que Basile continuait à utiliser des boucles imbriquées pour les Scanline malgré le fait qu'AndNotOr nous aie rappelé dans l'autre discussion qu'on pouvait se contenter d'une boucle unique en parcourant le BitMap du bas vers le haut j'étais un peu déçu que le "disciple" n'aie pas tenu compte de la leçon, donc la seule priorité c'était de faire fonctionner son code.
... Mais bon je comprends aussi qu'il ne sait pas trop où donner de la tête vu qu'il est assailli de réponses multiples et diverses.

A+.

**Basile le disciple** · 18/05/2013, 19h27

Excusez moi.

A vrai dire j'avais regardé les réponses mais je n'avais pas tout compris!!

Maintenant j'ai rectifié le tir en faisant fumer la cacahuète jusqu'à ébullition. Et après refroidissement(dans la glace), je vous poste le fruit d'un dur labeur qui à l'air de fonctionner!! Je pense avoir utilisé tous vos conseils dans la mesure de mes possibilités car il y en a certains que je n'ai pas pu recréer par manque de connaissances. Ci-joint mon (puissant) code :

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
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;
 
type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormDestroy(Sender: TObject);
  private
    { Déclarations privées }
    bmp,bmpmemoire : TBitmap;
    col : TColor;
    procedure fond(bitmap : TBitmap);
    function TripletoColor(RGBTriple :  pRGBTriple) : TColor;
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
const
  tab : array[1..3] of TColor = (clred,clblue,cllime);
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered:=true;
  bmp:=TBitmap.Create;
  bmpmemoire:=TBitmap.Create;
  ClientWidth:=Image1.Picture.Width;
  ClientHeight:=Image1.Picture.Height;
    With bmpmemoire do
  begin
    Width:=self.Width;
    Height:=self.Height;
    PixelFormat:=pf24bit;
    Canvas.Draw(0,0,Image1.Picture.Metafile);
  end;
  bmp.Assign(bmpmemoire);
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  Paintbox1.Canvas.Draw(0,0,bmp);
end;
 
procedure TForm1.fond(bitmap : TBitmap);
var bmp2 : TBitmap;
    y : integer;
    p : pRGBTriple;
begin
 try
  bitmap.Assign(bmpmemoire);
  bmp2:=TBitmap.Create;
  with bmp2 do
  begin
    PixelFormat:=pf24Bit;
    Assign(Bitmap);
  end;
 
   p:=bmp2.ScanLine[bmp2.Height-1];
   For y:=0 to bmp2.Width*bmp2.Height-1 do
   begin
     if tripletocolor(p) = col  then
     begin
       p^.rgbtBlue:=0;
       p^.rgbtGreen:=255;
       p^.rgbtRed:=255;
       bitmap.Assign(bmp2);
     end;
     inc(p);
   end;
  finally
   bmp2.Free;
  end;
end;
 
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
  var i : integer;
begin
  col:=getPixel(bmp.Canvas.Handle,x,y);
  for i:=1 to 3 do
  begin
    if (col = tab[i]) then
    begin
     fond(bmp);
     break;
    end else if col <> clyellow then bmp.Assign(bmpmemoire);
  end;
  Paintbox1.Invalidate;
end;
 
function TForm1.TripletoColor(RGBTriple : PRGBTriple) : TColor;
begin
  result:=rgb(RGBTriple.rgbtRed,RGBTriple.rgbtGreen,RGBTriple.rgbtBlue);
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  bmp.Free;
  bmpmemoire.Free;
end;
 
 
end.

il reste quand même une incertitude : dans les cartes que j'ai créées, il n'y a pas 3 couleurs mais maximum 49 et dans le OnMouseMove, ça risque de ramer. Si vous avez des conseils, je suis preneur!

**Gilbert Geyer** · 19/05/2013, 12h03

Salut Basile le disciple,

D'abord

pour le remplacement des boucles imbriquées par une boucle unique.
Mais comme le bitmap.Assign(bmp2); placé en plein dans la boucle de Form1.fond(BitMap: TBitmap) m'a intrigué j'ai pu constater qu'il est possible de simplifier :

A) Ton code avec commentaires expliquant en bref les simplifications :

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
procedure TForm1.fond(BitMap: TBitmap);
var
  //bmp2: TBitmap; <- Inutile car on peut agir directement sur le BitMap passé en paramètre 
  y: integer;
  p: pRGBTriple;
begin
  try
    //bitmap.Assign(bmpmemoire); <- Inutile car c'est déjà fait via le PaintBox1MouseMove

   { bmp2 := TBitmap.Create;
    with bmp2 do
    begin
      PixelFormat := pf24Bit;
      Assign(Bitmap);
    end; }
    bitmap.PixelFormat := pf24Bit;

    p := bitmap.ScanLine[bitmap.Height - 1];   //p := bmp2.ScanLine[bmp2.Height - 1];
   
    for y := 0 to bitmap.Width * bitmap.Height - 1 do  //for y := 0 to bmp2.Width * bmp2.Height - 1 do
    begin
      if tripletocolor(p) = col then
      begin
        p^.rgbtBlue := 0;
        p^.rgbtGreen := 255;
        p^.rgbtRed := 255;
        //bitmap.Assign(bmp2); ??? en plein dans la boucle !!!
      end;
      inc(p);
    end;
    //bitmap.Assign(bmp2);
  finally
    //bmp2.Free;
  end;
end;

B) Le même après simpification :

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
procedure TForm1.fond(BitMap: TBitmap);
var
  y: integer;
  p: pRGBTriple;
begin
  try
    bitmap.PixelFormat := pf24Bit;
    p := bitmap.ScanLine[bitmap.Height - 1];
    for y := 0 to bitmap.Width * bitmap.Height - 1 do
    begin
      if tripletocolor(p) = col then
      begin
        p^.rgbtBlue := 0;
        p^.rgbtGreen := 255;
        p^.rgbtRed := 255;
      end;
      inc(p);
    end;
  finally
  end;
end;

A+.

**Basile le disciple** · 19/05/2013, 14h04

merci pour les modifications.

Maintenant, le problème, c'est que j'ai essayé avec une de mes cartes et cela ne marche pas(les zones se colorient bien en bleu mais en rayures et d'autres zones se remplissent sans qu'elles aient la même couleur). Ci-joint mon code et mon image:

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
 
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;
 
type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormDestroy(Sender: TObject);
  private
    { Déclarations privées }
    bmp,bmpmemoire : TBitmap;
    col : TColor;
    procedure fond(bitmap : TBitmap);
    function TripletoColor(RGBTriple :  pRGBTriple) : TColor;
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
const
   tab : array[0..49] of TColor = ($F9FFFF,$FFFFFE,$FFFEFF,$FEFFFF,$FFFFFD,$FDFFFD,$FDFDFF,$FFFDFC,$FEFCFD,$FFFDFD,$FEFEFF,$FFFEFE,$FEFFFE,$FDFFFF,$FFFDFF,$FEFEFE,$FDFDFD,$FFFFFC,$FFFCFF,$FCFFFF,$FFFCFC,$FCFFFC,$FCFCFC,$FFFEFC,$FCFEFF,$FEFFFC,$FFFEFD,$FDFEFF,$FCFDFE,$FEFBFF,$FBFEFF,$FBFFFE,$FBFFFF,$FFFAFF,$FFFFFB,$FBFFFB,$FFFAFB,$FBFBFF,$FFFCFB,$FBFCFF,$FCFBFF,$FBFDFF,$FFFDFE,$FFFFFA,$FAFFFF,$FFF9FF,$FDFBFF,$FFFEFA,$FEFEFA,$FFFDFA);
   max : integer = 49;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered:=true;
  bmp:=TBitmap.Create;
  bmpmemoire:=TBitmap.Create;
  ClientWidth:=Image1.Picture.Width;
  ClientHeight:=Image1.Picture.Height;
    With bmpmemoire do
  begin
    Width:=self.Width;
    Height:=self.Height;
    PixelFormat:=pf24bit;
    Canvas.Draw(0,0,Image1.Picture.Metafile);
  end;
  bmp.Assign(bmpmemoire);
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  Paintbox1.Canvas.Draw(0,0,bmp);
end;
 
procedure TForm1.fond(bitmap : TBitmap);
var y : integer;
    p : pRGBTriple;
begin
    bitmap.PixelFormat := pf24Bit;
    p := bitmap.ScanLine[bitmap.Height - 1];
    for y := 0 to bitmap.Width * bitmap.Height - 1 do
    begin
      if tripletocolor(p) = col then
      begin
        p^.rgbtBlue := 255;
        p^.rgbtGreen := 0;
        p^.rgbtRed := 0;
      end;
      inc(p);
    end;
end;
 
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
  var i : integer;
begin
  col:=getPixel(bmp.Canvas.Handle,x,y);
  for i:=0 to max do
  begin
    if (col = tab[i]) then
    begin
     fond(bmp);
     break;
    end else if col <> clblue then bmp.Assign(bmpmemoire);
  end;
  Paintbox1.Invalidate;
end;
 
function TForm1.TripletoColor(RGBTriple : PRGBTriple) : TColor;
begin
  result:=rgb(RGBTriple.rgbtRed,RGBTriple.rgbtGreen,RGBTriple.rgbtBlue);
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  bmp.Free;
  bmpmemoire.Free;
end;
 
 
end.

**Gilbert Geyer** · 19/05/2013, 16h23

Re-salut Basile,

Voici 2 bouts de code : Places cette fonction devant ta TForm1.FormCreate() :

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
function BMP24fromFile(const nomFichierImg: string): tBitMap; // ajouter dans le uses Jpeg et axCtrls pour TOleGraphic , pas besoin de GIFImage
const FormatsSupportes = '.BMP.DIB.GIF.ICO.JIF.JPG.WMF.EMF';
var OleGraphic: TOleGraphic; FS: TFileStream; ext: string;
  JPEGImage: TJPEGImage; img: tImage; pl: tPanel;
begin
  if not FileExists(nomFichierImg) then begin
    showMessage(nomFichierImg + ' : n''existe pas'); Result := nil; EXIT;
  end;
  ext := UpperCase(ExtractFileExt(nomFichierImg));
  if (ext = '') or (pos(ext, FormatsSupportes) = 0) then
  begin showMessage(ext + ' = Format non supporté par BMP24fromFile');
    Result := nil; EXIT;
  end;
  if ext = '.BMP' then begin
    Result := tBitmap.create;
    Result.PixelFormat := pf24Bit;
    Result.LoadFromFile(nomFichierImg);
    EXIT;
  end;
  if ext = '.JPG' then begin
    try
      JPEGImage := TJPEGImage.Create;
      Result := TBitmap.Create;
      Result.PixelFormat := pf24Bit;
      try // test de chargement
        JPEGImage.LoadFromFile(nomFichierImg);
        JPEGImage.DIBNeeded;
        Result.Assign(JPEGImage);
      finally
        JPEGImage.Free;
      end;
    except
      Result := nil;
    end;
    EXIT;
  end;
  OleGraphic := TOleGraphic.Create;
  FS := TFileStream.Create(nomFichierImg, fmOpenRead or fmSharedenyNone);
  img := tImage.Create(pl); //<- petit inconvénient : nécessite un AOwner
  // et on peut ignorer l'[Avertissement] ... La variable 'pl' n'est peut-être pas initialisée
  // ça marche quand-même.
  try
    OleGraphic.LoadFromStream(FS);
    img.Picture.Assign(OleGraphic);
    Result := tBitmap.create;
    with Result do
    begin PixelFormat := pf24Bit;
      Width := img.Picture.Width;
      Height := img.Picture.Height;
      Canvas.Draw(0, 0, img.Picture.Graphic);
    end;
  finally
    fs.Free;
    img.free;
    OleGraphic.Free;
  end;
end; // BMP24fromFile

Puis remplace ta TForm1.FormCreate() par celle-ci :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := true;
  bmpmemoire := BMP24fromFile('E:\D_Fi_img\Basile\Afrique.EMF');
  ClientWidth:=bmpmemoire.Width;
  ClientHeight:=bmpmemoire.Height;
  PaintBox1.Width := bmpmemoire.Width;
  PaintBox1.Height := bmpmemoire.Height;
  bmp := TBitmap.Create;
  bmp.Assign(bmpmemoire);
end;

J'ai aussi viré Imge1 qui ne servait que comme relais.

... avec ces modifs ça fonctionne et ceci sans rayures que du Bleu!

A+.

P.S : Pour le cas où tu voudrais réutiliser la function BMP24fromFile(const nomFichierImg: string) dans un Dialog évite l'OpenPictureDialog et utilises le OpenDialog simple (avec OpenPictureDialog et un *.GIF plantage).

Petite question : à quoi correspondent les couleurs de tab: array[0..49] of TColor = ($F9FFFF, $FFFFFE, $FFFEFF, $FEFFFF, $FFFFFD, $FDFFFD, $FDFDFF, $FFFDFC, $FEFCFD, $FFFDFD, $FEFEFF, $FFFEFE, $FEFFFE, $FDFFFF, $FFFDFF, $FEFEFE, $FDFDFD, $FFFFFC, $FFFCFF, $FCFFFF, $FFFCFC, $FCFFFC, $FCFCFC, $FFFEFC, $FCFEFF, $FEFFFC, $FFFEFD, $FDFEFF, $FCFDFE, $FEFBFF, $FBFEFF, $FBFFFE, $FBFFFF, $FFFAFF, $FFFFFB, $FBFFFB, $FFFAFB, $FBFBFF, $FFFCFB, $FBFCFF, $FCFBFF, $FBFDFF, $FFFDFE, $FFFFFA, $FAFFFF, $FFF9FF, $FDFBFF, $FFFEFA, $FEFEFA, $FFFDFA);
sur l'image d'origine en noir et blanc ???

**Gilbert Geyer** · 19/05/2013, 16h41

Re-salut,

Pigé : les couleurs de tab: array[0..49] of TColor sont des "presque blancs".

A+.

**Basile le disciple** · 19/05/2013, 18h08

Bravo, ça marche!!!

Cependant, Vers le Maroc, l'Algérie et le Sahara Occidental, cela remplit 2 pays quand on va assez vite(et ça ne vient pas de ma carte, j'ai testé...).
Sinon, c'est génial!!!

**ShaiLeTroll** · 20/05/2013, 09h39

Pense au bouton

Sinon, ma proposition purement TMetaFile était théorique, aurais-tu le temps de la tester ?
Je serais curieux de savoir si le TMetaFile conserve bien ses propriétés vectorielles !

**Basile le disciple** · 20/05/2013, 11h14

En fait, j'ai déjà regardé mais ça ne compile pas. J'ai essayé de faire quelques modifications mais il y en a certaines que je n'ai pas pu résoudre :

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
122
123
124
125
 
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;
 
type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Déclarations privées }
    col,crcolor : tcolor;
    tmpMF : TMetaFile;
 
    function ConvertMetaFileToYellow(MetaFile: TMetaFile; ExcludeColor: TColor): boolean;
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := true;
  ClientWidth := Image1.Picture.Width;
  ClientHeight := Image1.Picture.Height;
  Image1.Visible := false; // ou SendToBack();
 
  Paintbox1.Align := AlClient; 
  tmpMF := TMetaFile.Create(); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  tmpMF.Free;
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  tmpMF.Handle := CopyEnhMetafile(Image1.Picture.MetaFile.Handle, nil); // normalement tmpMF libéra la copie
  ConvertMetaFileToYellow(tmpMF, col);
  Paintbox1.Canvas.Draw(0,0, tmpMF);
end;
 
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
    col := getPixel(Image1.Canvas.Handle, x, y);
    PaintBox1.Invalidate();
end;
 
// This function is called from EnumEnhMetaFile in the ConvertMetaFileToYellow procedure
function EnumCallBack_SetYellowColor(DC: HDC; var pHTable: THandleTable; var pEMFR: TEnhMetaRecord; nObj: integer; lpData: pointer): integer; stdcall;
begin
  case pEMFR.iType of
    EMR_CREATEPEN:
      begin
        with PEMRCreatePen(@pEMFR).lopn do
          if lopnColor = ColorToRGB(PColor(lpData)^) then
            lopnColor := ColorToRGB(clYellow);
      end;
 
    EMR_EXTCREATEPEN: 
      begin
        with PEMRExtCreatePen(@pEMFR).elp do
         if elpColor = ColorToRGB(PColor(lpData)^) then
           elpColor := ColorToRGB(clYellow);
      end;
 
    EMR_EXTFLOODFILL:
      begin
        with PEMRExtFloodFill(@pEMFR) do
         if crColor = ColorToRGB(PColor(lpData)^) then
           crColor := ColorToRGB(clYellow);
      end;
 
    EMR_CREATEBRUSHINDIRECT:
      begin
       with PEMRCreateBrushIndirect(@pEMFR).lb do
         if lbColor = ColorToRGB(PColor(lpData)^) then
           lbColor := ColorToRGB(clYellow);
    end;
 
    EMR_SETTEXTCOLOR, EMR_SETBKCOLOR: 
      begin
        with PEMRSETTEXTCOLOR(@pEMFR) do
          if crColor = ColorToRGB(PColor(lpData)^) then
            crColor := ColorToRGB(clYellow);
    end;
 
    EMR_BITBLT, 
    EMR_STRETCHBLT,
    EMR_STRETCHDIBITS, 
    EMR_MASKBLT,
    EMR_PLGBLT: begin
      // TODO: change integrated image to gray scale...
    end
  end;
 
  if DC <> 0 then
    PlayEnhMetaFileRecord(DC, pHTable, pEMFR, nObj);
 
  Result:=1;
end;
 
function TForm1.ConvertMetaFileToYellow(MetaFile: TMetaFile, ExcludeColor: TColor): boolean;
var
   R: TRect;
begin
  R := Rect(0, 0, Metafile.Width, MetaFile.Height);
  Result := EnumEnhMetaFile(0, MetaFile.Handle,@EnumCallBack_SetYellowColor, @ExcludeColor, R);
end;

ça bogue vers la fonction EnumCallBack.
Et crColor, c'est bien un TColor?

Je n'ai toujours pas mis 'Résolu' car la méthode de Gilbert Geyer n'est pas encore parfaite même si elle marche presque partout!!!

**Gilbert Geyer** · 20/05/2013, 11h31

Bonjour,

ShaiLeTroll :

Sinon, ma proposition purement TMetaFile était théorique, aurais-tu le temps de la tester ?

Je ne l'avais pas testée pour plusieurs raisons :
1 ) je n'ai absolument rien compris sur son fonctionnement.
2 ) comme le nombre de formats-image est pléthorique je me contente chaque fois que possible de les convertir en BitMaps et donc toutes mes routines de manipulation des Bmp sont réutilisables quel que soit le format d'origine parmi ceux que je sais convertir.

Mais pour te faire plaisir et par curiosité je viens de la tester mais il y a plusieurs bugs dont la plupart je n'ai pas réussi à les rectifier :

1) Un bug rectifié :

Code :

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

1
2
3
4
5
6
7
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
    //col := getPixel(Image1.Picture.MetaFile, x, y); [Erreur] ... : Types incompatibles : 'HDC' et 'TMetafile'
    col := getPixel(Image1.Picture.MetaFile.handle, x, y);
    PaintBox1.Invalidate();
end;

2) Les bugs à rectifier :

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
function EnumCallBack_SetYellowColor(DC: HDC; var pHTable: THandleTable; var pEMFR: TEnhMetaRecord; nObj: integer; lpData: pointer): integer; stdcall;
begin
  case pEMFR.iType of
    EMR_CREATEPEN:
      begin
        with PEMRCreatePen(@pEMFR).lopn do
          if lopnColor = ColorToRGB(PColor(lpData)^) then
            lopnColor := ColorToRGB(clYellow);
      end;

    EMR_EXTCREATEPEN:
      begin
        with PEMRExtCreatePen(@pEMFR).elp do
         if elpColor = ColorToRGB(PColor(lpData)^) then
           elpColor := ColorToRGB(clYellow);
      end;

    EMR_EXTFLOODFILL:
      begin
       // with PEMRExtFloodFill(@pEMFR) do  // [Erreur] ... : Type Record, Object ou Class requis
       //  if crColor = ColorToRGB(PColor(lpData)^) then  [Erreur] ... : Identificateur non déclaré : 'crColor'
       //    crColor := ColorToRGB(clYellow);
      end;

    EMR_CREATEBRUSHINDIRECT:
      begin
       with PEMRCreateBrushIndirect(@pEMFR).lb do
         if lbColor = ColorToRGB(PColor(lpData)^) then
           lbColor := ColorToRGB(clYellow);
    end;

    EMR_SETTEXTCOLOR, EMR_SETBKCOLOR:
      begin
        //with PEMRSETTEXTCOLOR(@pEMFR) do [Erreur] ... : Type Record, Object ou Class requis
        //  if crColor = ColorToRGB(PColor(lpData)^) then [Erreur] ... : Identificateur non déclaré : 'crColor'
        //    crColor := ColorToRGB(clYellow);
    end;

    EMR_BITBLT,
    EMR_STRETCHBLT,
    EMR_STRETCHDIBITS,
    EMR_MASKBLT,
    EMR_PLGBLT: begin
      // TODO: change integrated image to gray scale...
    end
  end;

  if DC <> 0 then
    PlayEnhMetaFileRecord(DC, pHTable, pEMFR, nObj);

  Result:=1;
end;

A+.

EDIT : Tiens Basile a dégainé plus vite que moi.

**Gilbert Geyer** · 20/05/2013, 13h05

Re-salut,

Basile :

Bravo, ça marche!!!
Cependant, Vers le Maroc, l'Algérie et le Sahara Occidental, cela remplit 2 pays quand on va assez vite (et ça ne vient pas de ma carte, j'ai testé...).

J'ai essayé de déplacer ma souris aussi rapidement que je le pouvais et je n'ai pas vu que cela remplissait 2 pays ... mis à part le fait qu'à très grande vitesse la rémanence des yeux n'arrive plus à suivre et j'utilise un Processeur Intel i7-2700K à 3,50 GHz ... et donc ce n'est pas la méthode qui remplit 2 pays.

Essayes donc d'ajouter un Application.ProcessMessages dans :

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
procedure TfrmAfrique1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var i: integer;
begin
  col := getPixel(bmp.Canvas.Handle, x, y);
  for i := 0 to max do
  begin
    if (col = tab[i]) then
    begin
      fond(bmp);
      break;
    end else if col <> clblue then bmp.Assign(bmpmemoire);
  end;
  Application.ProcessMessages;
  Paintbox1.Invalidate;
end;

ça laisse au processeur le temps d'achever une chose avant que le MouseMove lui dise de commencer autre chose... histoire de voir si ça remplit toujours 2 pays.

A+.

**ShaiLeTroll** · 20/05/2013, 13h36

Envoyé par Basile le disciple

Et crColor, c'est bien un TColor?

Non d'où le ColorToRGB pour convertir un TColor en COLORREF
C'est des types des API Windows : Metafile Structures

D'ailleurs, la clause with change l'objet par défaut, en fait crColor est un membre de la structure utilisé dans le with

Exemple du with

Code :

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

1
2
3
4
 
with PEMRExtFloodFill(@pEMFR) do
 if crColor = ColorToRGB(PColor(lpData)^) then
   crColor := ColorToRGB(clYellow);

Interprétation :

Code :

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

1
2
if PEMRExtFloodFill(@pEMFR).crColor = ColorToRGB(PColor(lpData)^) then
   PEMRExtFloodFill(@pEMFR).crColor := ColorToRGB(clYellow);

Envoyé par Gilbert Geyer

Type Record, Object ou Class requis

Ah ! il manque PEMRExtFloodFill et PEMRSETTEXTCOLOR comme type ?

En XE3, cela existe dans Windows.pas

Code :

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

1
2
3
4
5
6
7
8
9
10
11
  PEMRExtFloodFill = ^TEMRExtFloodFill;
  {$EXTERNALSYM tagEMREXTFLOODFILL}
  tagEMREXTFLOODFILL = record
    emr: TEMR;
    ptlStart: TPoint;
    crColor: COLORREF;
    iMode: DWORD;
  end;
  TEMRExtFloodFill = tagEMREXTFLOODFILL;
  {$EXTERNALSYM EMREXTFLOODFILL}
  EMREXTFLOODFILL = tagEMREXTFLOODFILL;

Code :

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

1
2
3
4
5
6
7
8
9
10
 
PEMRSetTextColor = ^TEMRSetTextColor;
  {$EXTERNALSYM tagEMRSETTEXTCOLOR}
  tagEMRSETTEXTCOLOR = record
    emr: TEMR;
    crColor: COLORREF;
  end;
  TEMRSetTextColor = tagEMRSETTEXTCOLOR;
  {$EXTERNALSYM EMRSETTEXTCOLOR}
  EMRSETTEXTCOLOR = tagEMRSETTEXTCOLOR;

Envoyé par Gilbert Geyer

1 ) je n'ai absolument rien compris sur son fonctionnement.

En fait, c'est l'exploitation du format EMF qui décrit l'image comme un suite d'opération, ce code adapté du forum embarcadero exploite cette caractéristique en modifiant la description de l'image, disons son "scénario" et lorsque la VCL Delphi a besoin de dessiner l'image vectorielle, elle applique les opérations les unes après les autres, c'est comme si l'on stockait les DrawRect, DrawEllipse... au lieu du résultat