Замена одного цвета в Image на другой

[KREGI]

Как сделать замену всех цветов на черный учитывая диапазон оттенков до серого?

procedure Highlight(aSource, ATarget: TBitmap);
var
 i, j: Integer;
 s, t: pRGBTriple;
begin
 aSource.PixelFormat := pf24bit;
 ATarget.PixelFormat := pf24bit;
 ATarget.Width := aSource.Width;
 ATarget.Height := aSource.Height;
for i := 0 to aSource.Height - 1 do
 begin
  s := ASource.Scanline[i];
  t := ATarget.Scanline[i];
  for j := 0 to aSource.Width - 1 do
 begin
  if (not (t^.rgbtBlue = ColorToRGB(clBlack))) and
   not (t^.rgbtRed = ColorToRGB(clBlack)) and
   not (t^.rgbtBlue = ColorToRGB(clBlack)) then
  begin
   t^.rgbtBlue := ColorToRGB(clWhite);
   t^.rgbtGreen := ColorToRGB(clWhite);
   t^.rgbtRed := ColorToRGB(clWhite);
  end;
 inc(s);
 inc(t);
 end;
end;
end;

procedure TForm1.N2Click(Sender: TObject);
begin
if OpenPictureDialog1.Execute then
 begin
  Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
 end;
end;

procedure TForm1.N3Click(Sender: TObject);
begin
if SavePictureDialog1.Execute then
 begin
  Image1.Picture.SaveToFile(SavePictureDialog1.FileName);
 end;
end;

procedure TForm1.N5Click(Sender: TObject); 
var b: TBitmap; 
begin
 b := TBitmap.Create;
 try
  b.Assign(Image1.Picture.Bitmap);
  Highlight(b, b);
  Image1.Picture.Bitmap := b;
  Image1.Refresh;
 finally
  b.Free;
 end;
end;

end.

[Пепел Феникса]

я сделал примерно так...правда без СканЛайна(переделай если надо)

procedure ReplaceColor(BitMap:TBitMap;FromColor,ToColor:TColor);//заменяем один цвет, основная процедура
var i,j:integer;
begin
 for i:=0 to BitMap.Height do
  for j:=0 to BitMap.Width do if BitMap.Canvas.Pixels[j,i]=FromColor then BitMap.Canvas.Pixels[j,i]:=ToColor;
end;

procedure ReplaceSomeColors(BitMap:TBitMap;FromColor1,FromColor2,ToColor:TColor);
type tRGBQUAD = packed record//финт ушами:)
      case integer of
      1:(rgbtBlue: Byte;
         rgbtGreen: Byte;
         rgbtRed: Byte;
         rgbReserved: Byte);
      2:(RGBColor:integer);
     end;
var i,j,k:integer;
    B:byte;
    t1,t2:TRGBQuad;
begin
 t1.RGBColor:=ColorToRGB(FromColor1);
 t2.RGBColor:=ColorToRGB(FromColor2); //далее меняем составляющие цвета(чтобы в первом цвете были меньшие(цикл идет снизу вверх)
 if t1.rgbtBlue>t2.rgbtBlue then begin B:=t1.rgbtBlue;t1.rgbtBlue:=t2.rgbtBlue;t2.rgbtBlue:=B; end;
 if t1.rgbtGreen>t2.rgbtGreen then begin B:=t1.rgbtGreen;t1.rgbtGreen:=t2.rgbtGreen;t2.rgbtGreen:=B; end;
 if t1.rgbtRed>t2.rgbtRed then begin B:=t1.rgbtRed;t1.rgbtRed:=t2.rgbtRed;t2.rgbtRed:=B; end;
 for i:=t1.rgbtBlue to t2.rgbtBlue do
  for j:=t1.rgbtGreen to t2.rgbtGreen do
   for k:=t1.rgbtRed to t2.rgbtRed do ReplaceColor(BitMap,RGB(k,j,i),ToColor);/сама замена
end;


procedure TForm1.Button1Click(Sender: TObject);//применение
var C:TColor;
begin
 if ColorDialog1.Execute then begin
                               C:=ColorDialog1.Color;
                               if ColorDialog1.Execute then ReplaceSomeColors(Image1.Picture.Bitmap,C,ColorDialog1.Color,clRed)
                                                       else ReplaceColor(Image1.Picture.Bitmap,C,clRed);
                              end;
end;

[KREGI]

Пепел Феникса как сделать отображение этого процесса в прогрес баре? (не пойму, зацикливается .что ли)

[Пепел Феникса]

оно долго думает

[KREGI]

Пепел Феникса а можно все таки как верно сделать отображение процесса?) (у меня не получается его сделать)

[Пепел Феникса]

procedure ReplaceSomeColors(BitMap:TBitMap;FromColor1,FromColor2,ToColor:TColor);
type tRGBQUAD = packed record//финт ушами:)
      case integer of
      1:(rgbtBlue: Byte;
         rgbtGreen: Byte;
         rgbtRed: Byte;
         rgbReserved: Byte);
      2:(RGBColor:integer);
     end;
var i,j,k:integer;
    B:byte;
    t1,t2:TRGBQuad;
begin
 t1.RGBColor:=ColorToRGB(FromColor1);
 t2.RGBColor:=ColorToRGB(FromColor2); //далее меняем составляющие цвета(чтобы в первом цвете были меньшие(цикл идет снизу вверх)
 if t1.rgbtBlue>t2.rgbtBlue then begin B:=t1.rgbtBlue;t1.rgbtBlue:=t2.rgbtBlue;t2.rgbtBlue:=B; end;
 if t1.rgbtGreen>t2.rgbtGreen then begin B:=t1.rgbtGreen;t1.rgbtGreen:=t2.rgbtGreen;t2.rgbtGreen:=B; end;
 if t1.rgbtRed>t2.rgbtRed then begin B:=t1.rgbtRed;t1.rgbtRed:=t2.rgbtRed;t2.rgbtRed:=B; end;
 for i:=t1.rgbtBlue to t2.rgbtBlue do
  for j:=t1.rgbtGreen to t2.rgbtGreen do
   for k:=t1.rgbtRed to t2.rgbtRed do begin
                                        PositionBar1.Position:=PositionBar1.Position+1;
ReplaceColor(BitMap,RGB(k,j,i),ToColor);/сама замена
         end;
end;

ну поидее чтото типа такого
только нужно максимум определять(попробуй сам)

[KREGI]

Пепел Феникса я ждал долго, походу не выполняется - зацикливается...

[Пепел Феникса]

зацикливания не должно быть...а проверял на легких диапазонах...работает
сейчас попробую пересмотреть

[Lime]

Максимум как я понимаю равен кол-ву пикселей.

procedure ReplaceColor(BitMap:TBitMap;FromColor,ToColor:TColor);//заменяем один цвет, основная процедура
var i,j,i2:integer;
begin
i2:=0;
progressbar1.max := BitMap.Height * BitMap.Width;
progressbar1.position :=0;
 for i:=0 to BitMap.Height do
  for j:=0 to BitMap.Width do 
begin
 if BitMap.Canvas.Pixels[j,i]=FromColor then BitMap.Canvas.Pixels[j,i]:=ToColor;
 i2:=i2+1;
 progressbar1:=i2;
end;
end;

[KREGI]

Задача такая, есть карта (сканированная, качество плохое) надо убрать все цвета оставив только черный (но за счет того что качество плохое, границы то светлей то темней, вот и думаю как и оттенки учесть)