[grisha575]

Вобщем проги сделаны,работают но их надо немного переделать.Помогите плизз.
1.По нажатии левой кнопки мыши нарисовать прямоугольник,соотношение сторон которого 3:5.Точка указателя - точка пересечения диагоналей.По отпускании кнопки - преобразовать прямоугольник в квадрат.
Проблема в том что по отпускании кнопки он преобразовывается в эллипс.

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    Image1: TImage;
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  d,a:integer;
implementation

{$R *.dfm}

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
if edit1.Text='' then exit;
d:=round(strtoint(edit1.Text)/2);
if shift=[ssleft] then begin
a:=round(d/7.3);
with image1.Canvas do begin
rectangle(x-round(a*3.5),y-a,x+round(a*3.5),y+a);
end;
end;
end;
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
if edit1.Text='' then exit;
d:=round(strtoint(edit1.Text)/2);
a:=round(d/7.3);
with image1.Canvas do begin
//pen.Color:=clwhite;
//rectangle(x-round(a*3.5),y-a,x+round(a*3.5),y+a);
FillRect(Rect(x-round(a*3.5),y-a,x+round(a*3.5),y+a));
ellipse(x-round(a*3.5),y-a,x+round(a*3.5),y+a);

end;
end;
end.

2.Прога гафического ввода и редактирования ломанной многоугольник на paintbox.Конец и начало многоугольника совпадают.
Надо сделать чтобы при нажатии правой кнопки мыши с каким-нить модификатором,выделялсясамый дальний,к заданной точке,отрезок ломанной.

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Math;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  f,f1,f2:boolean;
  xx,yy:array of integer;
  i,j,k,n:integer;
  rasst1,rasst2:real;
implementation

{$R *.dfm}
procedure figure(xxx,yyy:array of integer);
var i,l:integer;
begin
with form1.Canvas do begin
l:=length(xxx)-2;
pen.Color:=clwhite;
rectangle(0,0,form1.Width,form1.Height);
moveto(xxx[0],yyy[0]);
pen.Color:=clblack;
for i:=0 to l do lineto(xxx[i],yyy[i]);
if f=true then lineto(xxx[0],yyy[0]);
pen.Width:=1;
end;
end;

//нажатие/////////////////////////////////////////////////////////////////////////
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
with form1.Canvas do begin
   if (shift=[ssleft])and(f=false) then begin  //рисование
   i:=i+1;
      if (10>abs(x-xx[0]))and(10>abs(y-yy[0])) then begin
      f:=true;
      end
      else begin
      xx[i]:=x;
      yy[i]:=y;
      setlength(xx,length(xx)+1);
      setlength(yy,length(yy)+1);
      end;
   figure(xx,yy);
   end;      //конец рисования
   if (shift=[ssleft])and(f=true) then begin  //перетаскивание фигуры
      for j:=0 to i-1 do begin



      end;
   end;    //конец перетаскивания фигуры
   if (shift=[ssright,ssctrl])and(f=true) then begin //перетаскивание точки
      for j:=0 to length(xx) do begin
         if (10>abs(x-xx[j]))and(10>abs(y-yy[j])) then begin
         f1:=true;
         exit;
         end;
      end;
   end;  //конец перетаскивания точки
   if (shift=[ssright,ssshift])and(f=true) then begin //удаление точки
      for j:=0 to length(xx) do begin
         if (10>abs(x-xx[j]))and(10>abs(y-yy[j])) then begin
            for k:=j to length(xx)-2 do begin
            xx[k]:=xx[k+1];
            yy[k]:=yy[k+1];
            end;
         setlength(xx,length(xx)-1);
         setlength(yy,length(yy)-1);
         figure(xx,yy);
         exit;
         end;
      end;
   end; //конец удаления точки
   if (shift=[ssright,ssalt])and(f=true) then begin //добавление точки
   n:=length(xx);
      for j:=0 to n-1 do begin
      rasst1:=sqr(power(x-xx[j],2)+power(y-yy[j],2))+sqr(power(x-xx[j+1],2)+power(y-yy[j+1],2));
      rasst2:=sqr(power(xx[j+1]-xx[j],2)+(power(yy[j+1]-yy[j],2)));
         if rasst1-rasst2<0 then begin
         edit1.text:='yes';
         setlength(xx,length(xx)+1);
         setlength(yy,length(yy)+1);
            for k:=n downto j+1 do begin
            xx[k]:=xx[k-1];
            yy[k]:=yy[k-1];
            end;
         xx[j]:=x;
         yy[j]:=y;
         figure(xx,yy);
         exit;
         end;
      end;
   end;  //конец добавления точки
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
i:=-1;
setlength(xx,1);
setlength(yy,1);
end;
//отпускание/////////////////////////////////////////////////////////////////
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
with form1.canvas do begin
   if (Button=mbright)and(shift=[ssctrl])and(f1=true) then begin //перетаскивание точки
   f1:=false;
   figure(xx,yy);
   end;  //конец перетаскивания точки
end;
end;
//перемещение/////////////////////////////////////////////////////////////////////////
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
with form1.Canvas do begin
   if (shift=[ssright,ssctrl])and(f1=true) then begin //перетаскивание точки
   xx[j]:=x;
   yy[j]:=y;
   pen.Width:=2;
   figure(xx,yy);
   end;  //конец перетаскивания точки
end;
end;
end.

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

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Button2: TButton;
    Button3: TButton;
    Edit1: TEdit;
    Label1: TLabel;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
s,sub,sl:string;
i,n,t,k,a:integer;
f:text;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
ss: string;
c:integer;
begin
if opendialog1.execute then begin
memo1.Text:='';
assignfile(f,opendialog1.filename);
reset(f);
while not eof(f) do begin
  readln(f,ss);
  Memo1.Lines.Add(ss);
end;
closefile(f);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
memo1.Text:='';
opendialog1.filter:='textfiles(*.txt)|*.TXT';
savedialog1.filter:='textfiles(*.txt)|*.TXT';
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if timer1.enabled=false then timer1.Enabled:=true;
sub:=edit1.text;
s:=memo1.Text;
n:=length(s);
t:=1;
k:=0;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
if SaveDialog1.Execute then begin
  AssignFile(f,SaveDialog1.FileName);
  rewrite(f);
  write(f,memo1.text);
  CloseFile(f);
end;

end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
for i:=t to n do begin
   if ((s[i]=' ') or (ord(s[i])=13)) then k:=i;
   if (s[i+1]=' ') or (ord(s[i+1])=13) then begin
   sl:=copy(s,k+1,i-k);
   a:=pos(sub,sl);
      if a>0 then begin
      memo1.SelLength:=0;
      memo1.SelStart:=k;
      memo1.SelLength:=i-k;
      memo1.SetFocus;
      t:=i+1;
      break;
      end;
   end;
end;
end;

end.

Еще плюс к этому залил сами проги чтобы Вы имели представление как все это выглядет.(архив весит 557 кб)
http://www.anyfiles.net/download/ce83d7738177/Progi.rar