Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

Не получается копировать часть изображения [D7, XP, 2003]


oam333 ©   (2012-12-24 14:13:00) 

Есть TBitmap. В нем сидит скриншот экрана. Нужно в цикле сохранить этот скриншот, разрезанный на прямоугольники (блоки), в несколько файлов (сколько блоков, столько и файлов). Первый блок сохраняется нормально. Все остальные содержат белый цвет. И ничего больше. Размер картинок создается нормальный, но содержат только белый цвет, будто холст банально залили белым цветом. Что за хрень?

procedure TForm1.Button1Click(Sender: TObject);
var gr: TBitmap;
    ScreenCopy: TCanvas;
    gr, gr_part: TBitmap;
    i: smallint;
    rcDest, rcSource, aRect: TRect;
    block_width, block_height: smallint;
begin
      rcSource := Rect(0, 0, Screen.Width, Screen.Height); //исходный размер изображения
      rcDest := Rect(0, 0, Screen.Width, Screen.Height); //конечный размер изображения
      block_width:=64; //ширина блока
      block_height:=64; //высота блока

      //создаем канву и присоединяем ее к контексту Рабочего стола
      ScreenCopy := TCanvas.Create;
      ScreenCopy.Handle := GetDC(0);
      gr:= TBitmap.Create;
      gr.Height := screen_height;
      gr.Width := screen_width;
      gr.Canvas.CopyRect(rcDest, ScreenCopy, rcSource);
      for i:=1 to 6 do
        begin
           SetRect(aRect, block_width*(i-1), block_height*(i-1), block_width*i, block_height*i);
           gr_part:= TBitmap.Create;
           gr_part.Width  := block_width;
           gr_part.Height := block_height;
           gr_part.Canvas.CopyRect(aRect, gr.Canvas, aRect);
           gr_part.SaveToFile('img_'+inttostr(i)+'.bmp');
           gr_part.Free;
        end;
end;

KilkennyCat   (2012-12-25 03:15:00) [1]

не, все-таки нужно.

KilkennyCat   (2012-12-25 02:48:00) [2]


> with TBitmap.Create do

а, ну да.


> а GetDC(0) релизить


мне кажется, в данном случае не нужно. а вот проверять имело бы смысл.

Дмитрий С   (2012-12-25 02:36:00) [3]


procedure Raspilovka(preFile : String; bWidth : integer; bHeight : Integer);
var
i : smallint;
begin
with TBitmap.Create do
try
 Width := bWidth;
 Height := bHeight;
 for i := 0 to 5 do
   begin
     BitBlt(Canvas.Handle, 0, 0, bWidth, bHeight, GetDC(0), bWidth * i, bHeight * i, SRCCOPY);
     SaveToFile(preFile + inttostr(i + 1) + '.bmp');
   end;
finally
 Free;
end;
end;

Кстати, а GetDC(0) релизить разве не нужно?

KilkennyCat   (2012-12-25 02:32:00) [4]


> Дмитрий С ©   (25.12.12 02:30) [15]

и как тогда выполнить SaveToFile определенного куска рабочего стола?

Дмитрий С   (2012-12-25 02:30:00) [5]


> KilkennyCat ©   (24.12.12 19:37) [12]

С твоими именами параметров, можно и без переменной gr_part обойтись.

oam333   (2012-12-24 22:24:00) [6]

KilkennyCat
Большое сенкс! Хорошее исполнение!

Anatoly Podgoretsky   (2012-12-24 19:52:00) [7]


> диагональю будет, однако :)

Штрихом, очень маленьким при том.

KilkennyCat   (2012-12-24 19:37:00) [8]

ну и чтоб еще красивше:

procedure TForm1.btn1Click(Sender: TObject);
begin
  Raspilovka('Img_' ,64, 64);
end;

procedure Raspilovka(preFile : String; bWidth : integer; bHeight : Integer);
var
gr_part: TBitmap;
i : smallint;
begin
gr_part := TBitmap.Create;
try
  gr_part.Width := bWidth;
  gr_part.Height := bHeight;
  for i := 0 to 5 do
    begin
      BitBlt(gr_part.Canvas.Handle, 0, 0, bWidth, bHeight, GetDC(0), bWidth * i, bHeight * i, SRCCOPY);
      gr_part.SaveToFile(preFile + inttostr(i + 1) + '.bmp');
    end;
finally
  gr_part.Free;
end;
end;

KilkennyCat   (2012-12-24 19:30:00) [9]


> BitBlt(gr_part.Canvas.Handle, 0, 0, block_width, block_height,
>  GetDC(0), block_width * i, block_height * i, SRCCOPY);

диагональю будет, однако :)

KilkennyCat   (2012-12-24 19:28:00) [10]

так лучше:
procedure TForm1.btn1Click(Sender: TObject);
var
 gr_part: TBitmap;
 i, block_width, block_height: smallint;
begin
 block_width := 64; //ширина блока
 block_height := 64; //высота блока
 gr_part := TBitmap.Create;
 try
   gr_part.Width := block_width;
   gr_part.Height := block_height;
   for i := 0 to 5 do
     begin
       BitBlt(gr_part.Canvas.Handle, 0, 0, block_width, block_height, GetDC(0), block_width * i, block_height * i, SRCCOPY);
       gr_part.SaveToFile('img_' + inttostr(i + 1) + '.bmp');
     end;
 finally
   gr_part.Free;
 end;
end;

KilkennyCat   (2012-12-24 19:21:00) [11]

procedure TForm1.btn1Click(Sender: TObject);
var
 gr, gr_part: TBitmap;
 i, block_width, block_height: smallint;
begin
 block_width := 64; //ширина блока
 block_height := 64; //высота блока

 gr := TBitmap.Create;
 try
   gr.Height := screen.height;
   gr.Width := screen.width;
   gr.Canvas.Handle := GetDC(0);
   gr_part := TBitmap.Create;
   gr_part.Width := block_width;
   gr_part.Height := block_height;
   try
     for i := 0 to 5 do
       begin
          gr_part.Canvas.CopyRect(Rect(0, 0, block_width, block_height), gr.Canvas, Rect(block_width * i, block_height * i, block_width * (i + 1), block_height * (i + 1)));
          gr_part.SaveToFile('img_'+inttostr(i)+'.bmp');
       end;
   finally
     gr_part.Free;
   end;
 finally
   gr.Free;
 end;
end;

KilkennyCat   (2012-12-24 19:07:00) [12]

var gr: TBitmap;
   ScreenCopy: TCanvas;
   gr, gr_part: TBitmap;

че-то лишнее тут

Капитан Очевидность   (2012-12-24 16:22:00) [13]


> Но все равно не хочет
Не та это субстанция, чтоб хотеть. Перечитывай [1] до просветления.

MBo   (2012-12-24 15:39:00) [14]

надо разобраться, что означают параметры TCanvas.CopyRect

oam333   (2012-12-24 15:23:00) [15]

нет, все же строка должна быть
SetRect(aRect, block_width*(i-1), 0, block_width*i-1, block_height-1);
Но и так не работает. Все блоки сохраняются белыми.

oam333   (2012-12-24 15:20:00) [16]

Эмм.. не там единицу вычитал (в программе правильно, это здесь описАлся)
SetRect(aRect, block_width*(i-1), block_height*i, block_width*(i-1), block_height*i);
А по-хорошему лучше так:
SetRect(aRect, block_width*(i-1), 0, block_width*(i-1)-1, block_height-1);

Т.е. конечный вариант:
procedure TForm1.Button1Click(Sender: TObject);
var gr: TBitmap;
   ScreenCopy: TCanvas;
   gr, gr_part: TBitmap;
   i: smallint;
   rcDest, rcSource, aRect: TRect;
   block_width, block_height: smallint;
begin
     rcSource := Rect(0, 0, Screen.Width, Screen.Height); //исходный размер изображения
     rcDest := Rect(0, 0, Screen.Width, Screen.Height); //конечный размер изображения
     block_width:=64; //ширина блока
     block_height:=64; //высота блока

     //создаем канву и присоединяем ее к контексту Рабочего стола
     ScreenCopy := TCanvas.Create;
     ScreenCopy.Handle := GetDC(0);
     gr:= TBitmap.Create;
     gr.Height := screen_height;
     gr.Width := screen_width;
     gr.Canvas.CopyRect(rcDest, ScreenCopy, rcSource);
     for i:=1 to 6 do
       begin
          SetRect(aRect, block_width*(i-1), 0, block_width*(i-1)-1, block_height-1);
          gr_part:= TBitmap.Create;
          gr_part.Width  := block_width;
          gr_part.Height := block_height;
          gr_part.Canvas.CopyRect(aRect, gr.Canvas, aRect);
          gr_part.SaveToFile('img_'+inttostr(i)+'.bmp');
          gr_part.Free;
       end;
end;

1 проход: (0, 0, 63, 63)
2 проход: (64, 0, 127, 63)
3 проход: (128, 0, 191, 63)
4 проход: (192, 0, 255, 63)
и т.д.
Но все равно не хочет. Кстати, в этом примере вообще все блоки сохраняет белым цветом. В программе (откуда выдрал этот кусок) первый блок сохраняется нормально (сюда не выложу, т.к. текста много и много запутанного).

Капитан Очевидность   (2012-12-24 15:04:00) [17]

(0, 0, 64, 64) — квадрат!

oam333   (2012-12-24 14:49:00) [18]

Капитан Очевидность
А разве (0, 0, 64, 64) не квадрат?

Капитан Очевидность   (2012-12-24 14:16:00) [19]


> gr_part.Canvas.CopyRect(aRect, gr.Canvas, aRect);
Первый параметр должен всегда быть квадратом (0, 0, 63, 63)

Наверх

Титульная страница Поиск, карта сайта Написать письмо