[PhoeniX]

Код:

procedure ParseBg(var bmp: TBitmap);
var
  x, y, i, j, sx, sy: integer;
  r1,g1,b1,r,g,b: Byte;
  screenb:TBitmap;
begin
  screenb := TBitmap.Create;
  screenb.Width := bmp.Width;
  screenb.Height := bmp.Height;
  sx:=(screen.Width-bmp.Width)div 2;
  sy:=(screen.Height-bmp.Height)div 2;
  BitBlt(screenb.Canvas.Handle, 0, 0, bmp.Width, bmp.Height, GetDC(0), sx, sy, SRCCOPY);
  for x:=0 to bmp.Width-1 do
    for y:=0 to bmp.Height-1 do begin
      i:=bmp.Canvas.Pixels[x,y];
      if i=$FFFFFF then continue;
      r:=GetRValue(i);
      g:=GetGValue(i);
      b:=GetBValue(i);
      if (r=g)and(g=b) then begin
        j:=screenb.Canvas.Pixels[x,y];
        r1:=GetRValue(j)*r shr 8;
        g1:=GetGValue(j)*g shr 8;
        b1:=GetBValue(j)*b shr 8;
        i:=RGB(r1,g1,b1);
        bmp.Canvas.Pixels[x,y]:=i;
      end;
    end;
  screenb.Free;
end;

procedure TfSplash.FormCreate(Sender: TObject);
var
  b: TBitmap;
begin
  b:=TBitmap.Create;
  b.Assign(Image1.Picture.Graphic);
  ParseBg(b);
  Image1.Picture.Assign(b);
  b.Free;
end;

Совместив два исходника + свои доработки, получил "прозрачные" тени. Работает хорошо, делает всё как надо... но медленно. Подскажите пути оптимизации.

[roamer]

При использовании Canvas.Pixels - трудно добиться скорости.
Будет интересно, если кто-то предложит какое-то решение (без использования др. инструментария).

[PhoeniX]

Я знаю, что это самый медленный способ, однако другой не нашёл...

[roamer]

В DRKB-3 есть статья, где для ускорения графики используется функция GetDIB. Я не пробовал, но судя по статье - эффективность существенно увеличивается.
-------------------------
DRKB Explorer
Об ускорении работы с графикой
01.01.2007
-------------------------

[PhoeniX]

Есть повод скачать... спс, посмотрим.

[roamer]

Здесь :
http://programmersforum.ru/showthread.php?t=35588
http://programmersforum.ru/showthread.php?t=338&page=51

тоже есть статьи - об ускорении графики в Delphi (с использованием ассемблерских вставок).

[PhoeniX]

Хм... статейку нашёл, но ничего толком "вмонтировать" не удалось.
Зато, нашёл код с использованием ScanLine. После преобразования:

Код:

procedure ParseBg(bmp: TBitmap);
type
  pRGBArray = ^TRGBArray;
  TRGBArray = array[0..0] of TRGBTriple;
var
  x, y, sx, sy: integer;
  r,g,b: Byte;
  screenb:TBitmap;
  line1,line2: pRGBArray;
begin
  screenb := TBitmap.Create;
  screenb.Width := bmp.Width;
  screenb.Height := bmp.Height;
  sx:=(screen.Width-bmp.Width)div 2;
  sy:=(screen.Height-bmp.Height)div 2;
  BitBlt(screenb.Canvas.Handle, 0, 0, bmp.Width, bmp.Height, GetDC(0), sx, sy, SRCCOPY);
  for y:=0 to bmp.Height-1 do begin
    line1 := bmp.ScanLine[y];
    line2 := screenb.ScanLine[y];
    for x:=0 to bmp.Width-1 do begin
      with line1^[x] do begin
        r:=rgbtRed;
        g:=rgbtGreen;
        b:=rgbtBlue;
      end;
      if (r=g)and(g=b)and(r<255) then begin
        with line2^[x] do begin
          r:=r*rgbtRed shr 8;
          g:=g*rgbtGreen shr 8;
          b:=b*rgbtBlue shr 8;
        end;
        with line1^[x] do begin
          rgbtRed:=r;
          rgbtGreen:=g;
          rgbtBlue:=b;
        end;
      end;
    end;
  end;
  screenb.Free;
end;

по изображению после обработки идут вертикальные полосы...

[PhoeniX]

Код:

procedure ParseBg(var bmp: TBitmap);
var
  x, y, i, sx, sy, w, h: integer;
  r, g, b: Byte;
  screenb:TBitmap;
begin
  w:=bmp.Width;
  h:=bmp.Height;
  screenb := TBitmap.Create;
  screenb.Width := w;
  screenb.Height := h;
  sx:=(screen.Width-w)div 2;
  sy:=(screen.Height-h)div 2;
  BitBlt(screenb.Canvas.Handle, 0, 0, w, h, GetDC(0), sx, sy, SRCCOPY);
  for y:=0 to h-1 do
    for x:=0 to w-1 do begin
      i:=bmp.Canvas.Pixels[x,y];
      r:=i and $FF;
      g:=i shr 8 and $FF;
      b:=i shr 16 and $FF;
      if (r=g)and(g=b) then begin
        i:=screenb.Canvas.Pixels[x,y];
        r:=(i and $FF)*r shr 8;
        g:=(i shr 8 and $FF)*g shr 8;
        b:=(i shr 16 and $FF)*b shr 8;
        bmp.Canvas.Pixels[x,y]:=(r or (g shl 8) or (b shl 16));
      end;
    end;
  screenb.Free;
end;

Странно, но этот метод работает даже быстрее сканлайна...

[urahara]

Сообщение от DJ PhoeniX

Странно, но этот метод работает даже быстрее сканлайна...

чтобы ScanLine быстро работал, надо прописывать:

Код:

  bmp.PixelFormat := pf24bit;
  screenb.PixelFormat := pf24bit;

[urahara]

собрал из вашего:

Код:

procedure ParseBg(bmp: TBitmap);
type
  pRGBArray = ^TRGBArray;
  TRGBArray = array[0..0] of TRGBTriple;
var
  x, y, sx, sy, w, h: integer;
  screenb:TBitmap;
  line1, line2: pRGBArray;
begin
  w := bmp.Width;
  h := bmp.Height;
  screenb := TBitmap.Create;
  screenb.Width := w;
  screenb.Height := h;
  bmp.PixelFormat := pf24bit;
  screenb.PixelFormat := pf24bit;
  sx:=(Screen.Width - w) div 2;
  sy:=(Screen.Height - h) div 2;
  BitBlt(screenb.Canvas.Handle, 0, 0, w, h, GetDC(0), sx, sy, SRCCOPY);
  for y:=0 to h - 1 do
  begin
    line1 := bmp.ScanLine[y];
    line2 := screenb.ScanLine[y];
    for x:=0 to w - 1 do
    begin
      with line1[x] do
        if (rgbtRed = rgbtGreen) and (rgbtGreen = rgbtBlue) then
        begin
          rgbtRed := line2[x].rgbtRed * rgbtRed shr 8;
          rgbtGreen := line2[x].rgbtGreen * rgbtGreen shr 8;
          rgbtBlue := line2[x].rgbtBlue * rgbtBlue shr 8;
        end;
    end;
  end;
  screenb.Free;
end;

[PhoeniX]

Огромная спасиба, работает как надо, и в несколько раз быстрее
Тему можно close

[romingood]

Уважаемый DJ PhoeniX!

Хотел спросить. Я тут ковырялся с программой по поиску пикселей определенного цвета, прога-то получилась, но очень медленно ищет, и знающие люди посоветовали именно этот пост. Я его изучил, но так и не догнал, какую же именно функцию выполняет кусок кода, который, как Вы сказали "работает как надо, и в несколько раз быстрее" ? Если функция хотя бы отдаленно напоминает поиск пикселя определенного цвета или группы пикселей, или даже изображения на другом изображении - скажите, плз, какие входные параметры я могу передать этой функции, и как получпить результат.

Может, если тут совсем другая тема, подскажете, где искать примеры поиска пикселя определенного цвета, только чтобы скан картинки 800*600 проходил максимум за секунду. А то у меня картинка сканится 15 минут...

Заранее премного благодарен.

[PhoeniX]

В этой строчке снимается в битмап скриншот, со смещением (sx,sy), и размерами w*h:

Код:

BitBlt(screenb.Canvas.Handle, 0, 0, w, h, GetDC(0), sx, sy, SRCCOPY);

Так ищем пиксель:

Код:

  for y:=0 to h - 1 do
    begin
      line := screenb.ScanLine[y];
      for x:=0 to w - 1 do
        begin
          with line[x] do
            if RGB(rgbtRed,rgbtGreen,rgbtBlue)=color then
            begin
              ..... // Пиксель Н-ного цвета найден - делаем, что надо...
            end;
        end;
      end;

Дальше - думай, как компоновать...

[urahara]

в место:

Код:

          with line[x] do
            if RGB(rgbtRed,rgbtGreen,rgbtBlue)=color then

лучше написать так:

Код:

          if integer(line[x]) = color then

[romingood]

Спасибо!
Сейчас же приступаю к тестированию этого кода.

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

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

И раз уж такое дело - скажите, а как вообще можно прикрутить сюда не точный поиск конкретного значения цвета, а еще и "примерно тот цвет"?
с настройкой, насколько можно отклоняться от эталонного цвета и захватывать больше пикселей (это аналог фотошопного Fuzziness-а у функции Sеlect Color).

Реальная задача очень проста = найти на экране всё жёлтое (255,255,0).
но т.к. это jpeg, там чисто желтого цвета будет немного, в основном околожелтые цвета, например 250,250,17 , или 225,225,2 ?

А знаете, пока писал вопрос, уже сам допёр примерно... Раз цифры разнятся незначительно, можно просто регулировать их разброс да и все. но тока чем больше разброс, тем тормознее будет прога, ведь теперь придется проверять не на один цвет, а, скажем, на сто оттенков.

И еще раз всем спасибо!