Форум: "Начинающим";
Текущий архив: 2013.09.08;
Скачать: [xml.tar.bz2];

Вниз

Не получается копировать часть изображения   Найти похожие ветки 

← →
oam333 ©   (2012-12-24 14:13) [0]

Есть 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;

---

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

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

---

← →
oam333 ©   (2012-12-24 14:49) [2]

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

---

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

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

---

← →
oam333 ©   (2012-12-24 15:20) [4]

Эмм.. не там единицу вычитал (в программе правильно, это здесь описАлся)
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)
и т.д.
Но все равно не хочет. Кстати, в этом примере вообще все блоки сохраняет белым цветом. В программе (откуда выдрал этот кусок) первый блок сохраняется нормально (сюда не выложу, т.к. текста много и много запутанного).

---

← →
oam333 ©   (2012-12-24 15:23) [5]

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

---

← →
MBo ©   (2012-12-24 15:39) [6]

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

---

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

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

---

← →
KilkennyCat ©   (2012-12-24 19:07) [8]

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

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

---

← →
KilkennyCat ©   (2012-12-24 19:21) [9]

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:28) [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:30) [11]

> 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:37) [12]

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

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;

---

← →
Anatoly Podgoretsky ©   (2012-12-24 19:52) [13]

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

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

---

← →
oam333 ©   (2012-12-24 22:24) [14]

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

---

← →
Дмитрий С ©   (2012-12-25 02:30) [15]

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

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

---

← →
KilkennyCat ©   (2012-12-25 02:32) [16]

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

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

---

← →
Дмитрий С ©   (2012-12-25 02:36) [17]


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:48) [18]

> with TBitmap.Create do

а, ну да.


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


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

---

← →
KilkennyCat ©   (2012-12-25 03:15) [19]

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

---

Страницы: 1 вся ветка

Форум: "Начинающим";
Текущий архив: 2013.09.08;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.5 MB
Время: 0.003 c