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

← →
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]

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

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

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

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) релизить разве не нужно?

> with TBitmap.Create do

а, ну да.

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

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

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

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