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

Вниз

Как обрезать белые края изображения   Найти похожие ветки 

← →
flincs   (2011-04-26 14:27) [0]

Добый день, подскажите как можно обрезать белые края изображения?

Картинка с белым фоном, на ней присутствует черное изображение, нужно обрезать все лишние белые края.

procedure CropImg(bmp:TBitmap);
var
 i,j,x,y,h: Integer;
 tBmp: TBitmap;
 b:Boolean;
begin
 tBmp:=TBitmap.Create;

 // Íàõîäèì x
 b := False;
 for i:=0 to bmp.Width-1 do
 begin
   for j:=0 to bmp.Height-1 do
     if Bmp.Canvas.Pixels[i,j]<>$FFFFFF then
     begin
       x := i;
       b:=True;
       Break;
     end;
   if b then Break;
 end;

 // &#205;&#224;&#245;&#238;&#228;&#232;&#236; y
 b:=False;
 for j:=0 to bmp.Height-1 do
 begin
   for i:=0 to bmp.Width-1 do
     if Bmp.Canvas.Pixels[i,j]<>$FFFFFF then
     begin
       y := j;
       b:=True;
       Break;
     end;
   if b then Break;
 end;

 tBmp.Width := bmp.Width-x;
 tBmp.Height := bmp.Height-y;
 BitBlt(tBmp.Canvas.Handle,0,0,tBmp.Width,tBmp.Height,bmp.Canvas.Handle,x,y,SRCCO PY);

 Form1.Image2.Picture.Bitmap:=tBmp;

 //ShowMessage(IntToStr(x)+" "+IntToStr(y));

 tBmp.Free;
end;

Поэксперементировал, нашел ху, вырезаю верхний белую полосу и левую, а нижнию и правую не могу понять, как будет лучше найти.

Подскажите как можно решить задачу? :)

---

← →
Ega23 ©   (2011-04-26 14:28) [1]

Объяви белый в качестве TransparentColor

---

← →
oldman ©   (2011-04-26 14:33) [2]

> нашел ху


Ищи точно также, только цикл запусти в обратную сторону.

---

← →
flincs   (2011-04-26 14:34) [3]

Ммм...

bmp.TransparentColor:=$FFFFFF;
 bmp.Transparent:=True;
 tBmp.Width := bmp.Width;
 tBmp.Height := bmp.Height;
 BitBlt(tBmp.Canvas.Handle,0,0,tBmp.Width,tBmp.Height,bmp.Canvas.Handle,0,0,SRCCO PY);
 Form1.Image2.Picture.Bitmap:=tBmp;

В итоге получается он не сужает оригинал изображения, даже не замечаю, что бы он его делал прозрачным. :(

---

← →
flincs   (2011-04-26 14:36) [4]

Удалено модератором

---

← →
oldman ©   (2011-04-26 14:39) [5]

for i:=bmp.Height-1 downto 0 do

---

← →
oldman ©   (2011-04-26 14:47) [6]

Кроме Width и Height есть еще Top и Left

---

← →
Andy BitOff ©   (2011-04-26 14:55) [7]

Удалено модератором

---

← →
flincs   (2011-04-26 14:56) [8]

> oldman ©   (26.04.11 14:39) [5]
> for i:=bmp.Height-1 downto 0 do


Спасибо! Вотвроде бы сделал, работает.

procedure CropImg(bmp:TBitmap);
var
 i,j,x,y,h,w: Integer;
 tBmp: TBitmap;
 b:Boolean;
begin
 tBmp:=TBitmap.Create;

 // находим x
 b := False;
 for i:=0 to bmp.Width-1 do
 begin
   for j:=0 to bmp.Height-1 do
     if Bmp.Canvas.Pixels[i,j]<>$FFFFFF then
     begin
       x := i;
       b:=True;
       Break;
     end;
   if b then Break;
 end;

 // находим y
 b:=False;
 for j:=0 to bmp.Height-1 do
 begin
   for i:=0 to bmp.Width-1 do
     if Bmp.Canvas.Pixels[i,j]<>$FFFFFF then
     begin
       y := j;
       b:=True;
       Break;
     end;
   if b then Break;
 end;

 // находим w
 b := False;
 for i:=bmp.Width-1 downto 0 do
 begin
   for j:=bmp.Height-1 downto 0 do
     if Bmp.Canvas.Pixels[i,j]<>$FFFFFF then
     begin
       w := i;
       b:=True;
       Break;
     end;
   if b then Break;
 end;

 // находим h
 b := False;
 for j:=bmp.Height-1 downto 0 do
 begin
   for i:=bmp.Width-1 downto 0 do
     if Bmp.Canvas.Pixels[i,j]<>$FFFFFF then
     begin
       h := j;
       b:=True;
       Break;
     end;
   if b then Break;
 end;

 //ShowMessage(IntToStr(x)+" "+IntToStr(y)+" "+IntToStr(w)+" "+IntToStr(h));

 tBmp.Width := (bmp.Width-x)-(bmp.Width-w-1);
 tBmp.Height := (bmp.Height-y)-(bmp.Height-h-1);

 BitBlt(tBmp.Canvas.Handle,0,0,tBmp.Width,tBmp.Height,bmp.Canvas.Handle,x,y,SRCCO PY);

 Form1.Image2.Picture.Bitmap:=tBmp;

 tBmp.Free;
end;

Конечно не супер маленький код, но работает :)

---

← →
oldman ©   (2011-04-26 17:11) [9]

зачем делать 4 цикла, если можно 2?

a=1;
b=10;
for i:=a to b do begin
 if m[i] then ...
 if m[b-i] then ...
end;

---

← →
flincs   (2011-04-27 00:15) [10]

> зачем делать 4 цикла, если можно 2?a=1;b=10;for i:=a to
> b do begin  if m[i] then ...  if m[b-i] then ...end;

Пробовал пробовал, ничего так и не получилось с двумя циклами :(

...с массивами еще не разобрался, m[i] как я догадываюсь это он и есть.

---

← →
KilkennyCat ©   (2011-04-27 01:52) [11]

> Пробовал пробовал, ничего так и не получилось с двумя циклами
> :(

не может не получится: просто проверка с двух краев сразу.

---

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

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

Наверх

Память: 0.48 MB
Время: 0.004 c