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

Вниз

Размеры изображения   Найти похожие ветки 

← →
lewka ©   (2010-02-06 11:42) [0]

Привет!!! Подскажите, пожалуйста, в такой задачке: Есть картинка неизвестных размеров, загруженная в TImage. Картинка монохромная (только черные и белые точки на ней). Подскажите как убрать белые поля вокруг картинки, чтобы была только одна картинка без белых полей? Спасибо

---

← →
lewka ©   (2010-02-06 11:59) [1]

Вот мой код:
Image1.Picture.LoadFromFile("123.bmp");
Left := 0;
Top := 0;
Right := Width-1;
Bottom := Height;
//левая точка
for X := Left to Right do
for Y := Top to Bottom do
 if  Image1.Picture.Bitmap.Canvas.Pixels[x,y] = clBlack then begin
   Left := X;
   Exit;
 end;
 //правая точка
for X := Left to Right do begin
 Count := 0;
 for Y := Top to Bottom do
   if Image1.Picture.Bitmap.Canvas.Pixels[x,y] = clBlack then Inc(Count);
 if Count = 0 then begin
   Right := X-1;
   Exit;
 end;
end;
// верхняя точка
for Y := Top to Bottom do
for X := Left to Right do
 if Image1.Picture.Bitmap.Canvas.Pixels[x,y] = clBlack then begin
   Top := Y;
   Exit;
 end;
// нижняя точка
for Y := Top to Bottom do begin
 Count := 0;
 for X := Left to Right do
   if Image1.Picture.Bitmap.Canvas.Pixels[x,y] = clBlack then Inc(Count);
 if Count = 0 then begin
   Bottom := Y-1;
   Exit;
 end;
end;
Image1.Picture.Bitmap.Width:=abs(Right-Left);
Image1.Picture.Bitmap.Height:=abs(Bottom-Top);
Image1.Picture.Bitmap.SaveToFile("123.bmp");
но ни чего не происходит

---

← →
И Павел   (2010-02-06 13:11) [2]

Может быть я чего-то недопонял, но у меня и монохромный рисунок при Transparent=true делается прозрачным.

---

← →
И Павел   (2010-02-06 13:21) [3]

Теперь, кажется, понял :) Попробуйте BrushCopy.

Как вариант - ScanLine+рисование еще одного изображения. Но это медленно.

---

← →
icWasya ©   (2010-02-08 13:20) [4]

Во первых EXIT - это выход из процедуры, а не из цикла.
Поскольку нет возможности выхода одновременно из двух циклов,
то нужно или использовать GOTO, или оформлять циклы в процедуры, например так

procedure ResizeBMP(FileName:String);
var
 BMP,BMP2:TBitmap;
 Ok:Boolean;
 Left,Right,Top,Bottom :Integer;
 Source,Dest:TRect;
 procedure FindLeft;  //левая точка
 var X,Y:Integer;
 begin
 for X := Left to Right do
   for Y := Top to Bottom do
     if BMP.Canvas.Pixels[x,y] = clBlack then begin
       Left := X;
       Ok:=True;
       Exit;
     end;
 end;
 procedure FindRight;  //правая точка
 var X,Y:Integer;
 begin
 for X := Right downto Left do
   for Y := Top to Bottom do
     if BMP.Canvas.Pixels[x,y] = clBlack then begin
       Right := X;
       Ok:=True;
       Exit;
     end;
 end;
 procedure FindTop; // верхняя точка
 var X,Y:Integer;
 begin
 for Y := Top to Bottom do
   for X := Left to Right do
     if BMP.Canvas.Pixels[x,y] = clBlack then begin
       Top := Y;
       Ok:=True;
       Exit;
     end;
 end;
 procedure FindBottom; // нижняя точка
 var X,Y:Integer;
 begin
 for Y := Bottom downto Top do
   for X := Left to Right do
     if BMP.Canvas.Pixels[x,y] = clBlack then begin
       Bottom := Y;
       Ok:=True;
       Exit;
     end;
 end;
begin
 BMP:=TBitmap.Create;
 try
   Ok:=False;
   BMP.LoadFromFile(FileName);
   Left := 0;
   Top := 0;
   Right := BMP.Width-1;
   Bottom := BMP.Height-1;
   FindLeft;
   FindRight;
   FindTop;
   FindBottom;
   if not Ok then begin
     ShowMessage("в файле "" + filename +"" нет чёрных точек");
     Exit;
   end;
   // теперь надо скопировать найденную область в новую Bitmap
   Source.Left:=Left;
   Source.Top:=Top;
   Source.Right:=Right;
   Source.Bottom:=Bottom;
   Dest.Left:=0;
   Dest.Top:=0;
   Dest.Right:=Right-Left;
   Dest.Bottom:=Bottom-Top;

   // сформируем новую битмапу
   BMP2:=TBitmap.Create;
   try
     BMP2.Palette:=BMP.Palette;
     BMP2.Width:=Right-Left+1;
     BMP2.Height:=Bottom-Top+1;

     BMP2.Canvas.CopyRect(Dest,BMP.Canvas,Source);

     BMP2.SaveToFile(FileName);
   finally
     BMP2.Free
   end;
 finally
   BMP.Free;
 end;
end;


---

← →
icWasya ©   (2010-02-08 13:25) [5]

В догонку
нужно еще одно присваивание

     BMP2.PixelFormat:=BMP.PixelFormat;

---

← →
anonims   (2010-02-08 14:09) [6]

Поскольку нет возможности выхода одновременно из двух циклов,

но есть возможность указать что циклы пора заканчивать
stop:=true;// один раз

if stop then break; //нужное число раз (=кол-во циклов) в нужных местах

---

← →
KilkennyCat ©   (2010-02-08 17:32) [7]

имеем массив А размерностью AX, AY
найти область Rect

rect := TRect(AX,AY,0,0);
for i := 0 to AX do
 for y := 0 to AY do
   if A(x,y) = 1 then begin
     if x > rect.right then rect.right := x;
     if x < rect.left then rect.left := x;
     if y > rect.bottom then rect.bottom := y;
     if y < rect.top then rect.top := y;
   end;

Собственно, все. Возможно, что-то упустил, но общий алгоритм должен быть ясен, как и то, как присобачить рект к битмапу.

---

← →
KilkennyCat ©   (2010-02-08 17:34) [8]

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

---

← →
KilkennyCat ©   (2010-02-08 17:37) [9]

for i := 0 читать как for x := 0

---

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

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

Наверх

Память: 0.47 MB
Время: 0.056 c