Текущий архив: 2005.01.02;
Скачать: CL | DM;

Вниз

Надо вырезать квадрат с буквой !!!   Найти похожие ветки 

← →
pika ©   (2004-12-19 01:21) [0]

Представляю вам часть кода

{========================================================}
procedure updwn;
var i,j:integer;
   look:byte;
begin
//**********************************************************
//**********************************************************

             //nahozhu verhnuu beluu chast
up:=0;look:=0;i:=0;
 while (look=0)and(i<=form1.pbbw.Picture.Bitmap.Height) do
  begin
  j:=0;
   while (look=0)and(j<=form1.pbbw.Picture.Bitmap.Width) do
    begin
      if form1.pbbw.Picture.Bitmap.Canvas.Pixels[j,i]=0 then look:=1 else
      j:=j+1;
    end;
    if look=0 then i:=i+1;
  end;
 up:=i;
 showmessage(inttostr(up));
//**********************************************************
//**********************************************************
             //nahozhu nizhnuu beluu chast
 look:=0;i:=up+1;
 while (look=0)and(i<=form1.pbbw.Picture.Bitmap.Height) do
  begin
   for j:=0 to form1.pbbw.Picture.Bitmap.Width do
    if form1.pbbw.Picture.Bitmap.Canvas.Pixels[j,i]=65536*256-1 then look:=1
         else  look:=0;
    if look=0 then inc(i);
  end;
 dwn:=i;
//**********************************************************
{for i:=up to dwn do
  begin
   for j:=lft to rght do
       if form1.pbbw.Picture.Bitmap.Canvas.Pixels[j,i]=0 then write(fgh,"1")else
       if form1.pbbw.Picture.Bitmap.Canvas.Pixels[j,i]=65536*256-1 then write(fgh,"0");
      writeln(fgh);
  end;}
//**********************************************************
end;
{========================================================}
procedure lftrght;
var i,j:integer;
   look:byte;
begin
//**********************************************************
//**********************************************************
             //nahozhu levuu beluu chast
lft:=0;look:=0;i:=0;
for j:=up to dwn do
 while (look=0)and(i<=form1.pbbw.Picture.Bitmap.Width) do
  begin
    if form1.pbbw.Picture.Bitmap.Canvas.Pixels[j,i]=0 then look:=1;
    if look=0 then inc(i);
  end;
lft:=i;
//**********************************************************
             //nahozhu pravuu beluu chast
rght:=lft+1;look:=0;i:=lft+1;
for j:=up to up do
 for i:=0 to form1.pbbw.Picture.Bitmap.Width do
  begin
    if form1.pbbw.Picture.Bitmap.Canvas.Pixels[i,j]=65536*256-1 then
                begin
                 look:=1;
                 rght:=i;
                end
         else look:=0;
  end;
//**********************************************************
//zapisivau v fail  1 esli pixel cherniy inache zapisivau 0
for i:=up to dwn do
begin
 for j:=lft to rght do
  if form1.pbbw.Picture.Bitmap.Canvas.Pixels[j,i]=0 then
     write(fgh,"1") else
     write(fgh,"0");
end;
//**********************************************************
//**********************************************************
end;

мне нужно получить квадрат с буквой, которую я вырезаю из битмапа, но для этого мне нужно 4 параметра up down(dwn)
left(lft) и  right(rght)
но что-то не получается , мучаюсь вроде бы все правильно но что-то не получается , верхнюю и  левую граници находит вроде бы нормально но нижнюю и правую неправильно ! Помогите люди добрые:)

---

← →
KilkennyCat ©   (2004-12-19 02:20) [1]

Все гораздо проще, если делать таким алгоритмом...

var
 Bukva : TRect;
 x, y : integer;
begin;
 
 Bukva.Left   := 0;
 Bukva.Right  := 0;
 Bukva.Top    := 0;
 Bukva.Bottom := 0;  
 
 y := 0;
 repeat
   x := 0;
   repeat
     if Pixels[x, y] = BukvaColor then begin
       if Bukva.Left < x then if Bukva.Right = 0 then bukva.Left := x else if Bukva.Right < x then Bukva.right := x;
       if Bukva.Top < y then if Bukva.bottom = 0 then bukva.Top := y else if Bukva.Bottom < y then Bukva.right := y;
     end;  
   until x < Canvas.Width - 1;
 until y < Canvas.Height - 1;
end;

Возможно, ошибься где-нить, набирал прямо тут, но алгоритм должен быть ясен :)

---

← →
Fedia ©   (2004-12-19 03:01) [2]

KilkennyCat ©   (19.12.04 02:20) [1]
>Возможно, ошибься где-нить, набирал прямо тут, но алгоритм должен быть ясен :)
Два на первый взгляд бесконечных цикла (на самом деле заканчивающихся на первом шаге), а так мелочь :)

var
Bukva : TRect;
x, y : integer;
begin;

Bukva.Left   := 2000;
Bukva.Right  := -1;
Bukva.Top    := 2000;
Bukva.Bottom := -1;  

y := 0;
repeat
  x := 0;
  repeat
    if Pixels[x, y] = BukvaColor then
    begin
      if Bukva.Left > x then
      Bukva.Left:=x;
      if Bukva.Right < x then
      Bukva.Right:=x;
      if Bukva.Top > y then
      Bukva.Top:=y;
      if Bukva.Bottom < y then
      Bukva.Bottom:=y;
    end;
    inc(x);
  until x = Canvas.Width - 1;
  inc(y);
until y = Canvas.Height - 1;
end;


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

---

← →
KilkennyCat ©   (2004-12-19 04:17) [3]

а я всегда парился с условиями завершения цикла :) никак не могу запомнить, то ли он выполняется пока условие истинно, то ли пока не станет истинным...

---

← →
Fedia ©   (2004-12-19 04:36) [4]

Я с этим тоже мучился, а потом как-то, по дороге с работы домой просто выучил наизусть :) Почему-то, во время написания кода такие вещи трудно запоминаются (это я знаю и по себе, и по мнению коллег).

---

← →
GrayFace ©   (2004-12-19 10:18) [5]

Странно. У меня никогда таких проблем не было.

---

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

Текущий архив: 2005.01.02;
Скачать: CL | DM;

Наверх

Память: 0.49 MB
Время: 0.047 c