[Asinkrit]

Сообщение от alexnov

Доброго времени суток!
Задача состоит в следующем: из загруженной картинки (для начала BMP) необходимо получить количество пикселов каждого цвета, которые содержит картинка. Задача простая, но как решить не знаю, с графикой дела не имел! Поможите плиз! ))

Очень понравилась задача, решил попробовать свои силы)

Идея проста, но сложно реализована для повышения производительности.

желательно на время работы функции блокировать вызывающий ее обработчик.

Код:

function TForm1.HowManyColors(const Bitmap: TBitmap; const Memo:TMemo): Integer;
type //это лучше определять в начале модуля

  TRGB = record
    B, G, R: Byte;
  end;

  ARGB = array[0..1] of TRGB; 
  PARGB = ^ARGB;

const
  CArrayLengthInc = 10000;


type //а это в функции
  TColorCnt = record
    FColor:TColor;       //Одна ячейка массива содержит цвет
    FCount:Integer;      //и его кол-во
  end;

var
  x, y, i, l, tmp:integer;
  p: PARGB;

  Colors: Array of TColorCnt;  //Массив всех найденых цветов

begin
  //Подготовимся)
  l:=CArrayLengthInc;
  SetLength(Colors,l); //для начала создадим массив на 10000 элементов
  //Функция SetLength будет тормозить весь процесс, лучше 
  //ее вызывать поменьше)
  with Colors[0] do
    begin
    FColor:=0; //один цвет (черный) определим заранее
    FCount:=0;
    end;
  Result:=1; //Result - кол-во найденных элементов)
  with Bitmap do
    for y := 0 to Height - 1 do //перебираем строки массива(линии картинки)
      begin
      p := ScanLine[y];
      for x := 0 to Width - 1 do//перебираем элементы массива (пиксели)
         begin
         with p[x] do  tmp:=(r*g*b);  //берем цвет пикселя
         for i:=0 to Result - 1 do  //перебираем цвета
             if Colors[i].FColor = tmp then // если у нас есть такой цвет
               begin
               Inc(Colors[i].FCount);  //то увеличиваем у него счетчик
               Break;    //и покидаем цикл перебора цветов
               end;
         if Length(Colors)=Result then //иначе проверяем не достигнут ли 
           begin                              //конец массива
           Inc(l,CArrayLengthInc);  //если да, то увеличиваем его еще
           SetLength(Colors, l);     //на 10000 элементов
           end;
         with Colors[Result] do //и сохраняем новый цвет
           begin
           FColor:=tmp;
           FCount:=1;
           end;
         Inc(Result);
         //результаты можно вставить вывод результата статуса
         // выполнения данной функции, к примеру если ты хочешь
         //показывать состояние выполнения)
         Application.ProcessMessages; //Это что бы приложение не висло
         end;
      end;
  
  //Вот вывести все элементы - безумие, так как цветов может быть 
  //очень большое кол-во и займет это чуть меньше времени, чем 
  //первая чать функции, я бы отказался от этой затеи)
  
  with Memo.Lines do
    begin                                   
    BeginUpdate;
    Clear;
    if (Result-Ord(Colors[0].FCount=0))>0 then
      for i:=0+Ord(Colors[0].FCount=0) to Result-1 do
        with Colors[i] do
          Add('Код цвета: '+IntToStr(FColor)+' - '+IntToStr(FCount)+' раз');
    EndUpdate;
    end;
  //пора покинуть функцию, но вдруг у картинки не было черного цвета, 
  if Colors[0].FCount = 0 then Dec(Result); // не будем врать)
  SetLength(Colors,0);  //и освободим массив
end;


procedure TForm1.MMHowManyColorsClick(Sender: TObject);
begin
  ShowMessage('Изображение содержит '+Inttostr(
    HowManyColors(Image1.Picture.Bitmap,Memo1))+' цветов');
end;

При больших и многокрасочных изображениях, процесс выполнения будет длительным (в этом случае, как минимум стоит удалить вывод всех элементов, блок with Memo Lines do begin .. end)!

Удачи)