Помогите немного переделать проги
Вобщем проги сделаны,работают но их надо немного переделать.Помогите плизз.
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
|