WebSVN – spacemission – Blame – /VCL_DELPHIX_D6/DxPathEdit.pas

Rev	Author	Line No.	Line
4	daniel-mar	1	unit DXPathEdit;
		2	//(c)2007 Jaro Benes
		3	//All Rights Reserved
		4
		5	{
		6	Complex application for users of unDelphiX as component editor:
		7
		8	Supported:
		9	a) create path for default shape.
		10	b) allow do change like move or rotate path layout.
		11	c) create new trace by free-hand.
		12
		13	}
		14	interface
		15
		16	{$INCLUDE DelphiXcfg.inc}
		17
		18	uses
		19	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
		20	Dialogs, StdCtrls, ExtCtrls, Menus, Buttons, Math, ComCtrls,
		21	DXClass, DXDraws, DIB;
		22
		23	type
		24	{ TEdit }
		25	TEdit = class(StdCtrls.TEdit) {injected class}
		26	private
		27	function GetAsInteger: Integer;
		28	procedure SetAsInteger(const Value: Integer);
		29	published
		30	public
		31	property AsInteger: Integer read GetAsInteger write SetAsInteger;
		32	end;
		33	{ TShape }
		34	TShape = class(ExtCtrls.TShape)
		35	procedure CMMouseEnter(var Msg: TMessage); message CM_MouseEnter;
		36	procedure CMMouseLeave(var Msg: TMessage); message CM_MouseLeave;
		37	end;
		38	{ TDelphiXTracesEditForm }
		39	TDPoint = record
		40	X, Y: Double;
		41	StayOn: Double;
		42	end;
		43	TDPointArr = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TDPoint;
		44	{$IFNDEF VER4UP}
		45	PDPointArr = ^TDPointArr;
		46	{$ENDIF}
		47	TDelphiXPathsEditForm = class(TForm)
		48	ScrollBox1: TScrollBox;
		49	Pane: TPanel;
		50	Shape1: TShape;
		51	Panel2: TPanel;
		52	Panel1: TPanel;
		53	Label1: TLabel;
		54	LAmount: TLabel;
		55	cbListOfTraces: TComboBox;
		56	eAmount: TEdit;
		57	btnNewTrace: TButton;
		58	PopupMenu1: TPopupMenu;
		59	Activate1: TMenuItem;
		60	Label2: TLabel;
		61	eShowOn: TEdit;
		62	Panel12: TPanel;
		63	btnSetTimming: TSpeedButton;
		64	btnLine: TSpeedButton;
		65	btnCircle: TSpeedButton;
		66	btnSelectionArea: TSpeedButton;
		67	btnSelectAll: TSpeedButton;
		68	btnGrid: TSpeedButton;
		69	brnSelectAsOne: TSpeedButton;
		70	btnBringToFront: TSpeedButton;
		71	btnMoveDown: TSpeedButton;
		72	btnSendToBack: TSpeedButton;
		73	btnMoveUp: TSpeedButton;
		74	btnMoveLeft: TSpeedButton;
		75	btnMoveRight: TSpeedButton;
		76	Panel3: TPanel;
		77	OKButton: TButton;
		78	CancelButton: TButton;
		79	btnCurve: TSpeedButton;
		80	btnProperties: TSpeedButton;
		81	btnRect: TSpeedButton;
		82	Image1: TImage;
		83	btnRefresh: TBitBtn;
		84	Label3: TLabel;
		85	StatusBar1: TStatusBar;
		86	Button1: TBitBtn;
		87	eDist: TEdit;
		88	LDist: TLabel;
		89	btnRotateLeft: TSpeedButton;
		90	btnRotateRight: TSpeedButton;
		91	procedure btnRotateLeftClick(Sender: TObject);
		92	procedure btnRotateRightClick(Sender: TObject);
		93	procedure btnMoveRightClick(Sender: TObject);
		94	procedure btnMoveLeftClick(Sender: TObject);
		95	procedure btnMoveDownClick(Sender: TObject);
		96	procedure btnMoveUpClick(Sender: TObject);
		97	procedure Button1Click(Sender: TObject);
		98	procedure btnLineClick(Sender: TObject);
		99	procedure btnGridClick(Sender: TObject);
		100	procedure btnSelectionAreaClick(Sender: TObject);
		101	procedure btnRefreshClick(Sender: TObject);
		102	procedure PaneResize(Sender: TObject);
		103	procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
		104	Shift: TShiftState; X, Y: Integer);
		105	procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
		106	Y: Integer);
		107	procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
		108	Shift: TShiftState; X, Y: Integer);
		109	procedure OKButtonClick(Sender: TObject);
		110	procedure cbListOfTracesChange(Sender: TObject);
		111	procedure rgShapeClick(Sender: TObject);
		112	procedure btnNewTraceClick(Sender: TObject);
		113	procedure ShapeMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
		114	procedure ShapeMouseUp(Sender: TObject; Button: TMouseButton;
		115	Shift: TShiftState; X, Y: Integer);
		116	procedure ShapeMouseDown(Sender: TObject; Button: TMouseButton;
		117	Shift: TShiftState; X, Y: Integer);
		118	procedure FormDestroy(Sender: TObject);
		119	procedure FormCreate(Sender: TObject);
		120	procedure btnSendToBackClick(Sender: TObject);
		121	procedure btnBringToFrontClick(Sender: TObject);
		122	procedure btnSetTimmingClick(Sender: TObject);
		123	private
		124	{ Private declarations }
		125	FCapture, FClicked: Boolean;
		126	MouseDownSpot: TPoint;
		127	LastShape: TShape;
		128	FTracesList: TTraces;
		129	tmpRect: TRect;
		130	{$IFNDEF VER4UP}
		131	tmpPointArrSize: Integer;
		132	{$ENDIF}
		133	tmpPointArr: {$IFNDEF VER4UP}PDPointArr{$ELSE}TDPointArr{$ENDIF};
		134	X0, Y0, LX, LY: Integer;
		135	IsDownNow: Boolean;
		136	procedure btnCreateNewTrace(Sender: TObject);
		137	procedure DoMakePoints;
		138	procedure CreatePathFromActiveTrace(index: Integer);
		139	function GetSizesOfTrace(out x, y, oWidth, oHeight: Integer): Boolean;
		140	procedure RotatePathForAngle(Angle: Integer);
		141
		142	public
		143	{ Public declarations }
		144	property PrivateTraces: TTraces read FTracesList write FTracesList;
		145	procedure ShowTracesOnPane_;
		146	procedure RewriteTracesFromPane;
		147	procedure ShowTracesOnPane;
		148	procedure RefreshShowTracesOnPaneOnly;
		149	end;
		150
		151	var
		152	DelphiXPathsEditForm: TDelphiXPathsEditForm;
		153
		154	implementation
		155
		156	{$R *.dfm}
		157
		158	{ TEdit }
		159
		160	procedure TEdit.SetAsInteger(const Value: Integer);
		161	begin
		162	Self.Text := IntToStr(Value)
		163	end;
		164
		165	function TEdit.GetAsInteger: Integer;
		166	begin
		167	try
		168	Result := StrToInt(Self.Text);
		169	except
		170	Result := 0;
		171	end;
		172	end;
		173
		174	{ TShape }
		175
		176	procedure TShape.CMMouseLeave(var Msg: TMessage);
		177	begin
		178	Shape := stRectangle;
		179	end;
		180
		181	procedure TShape.CMMouseEnter(var Msg: TMessage);
		182	begin
		183	Shape := stCircle;
		184	end;
		185
		186	{ TDelphiXTracesEditForm }
		187
		188	procedure TDelphiXPathsEditForm.FormCreate(Sender: TObject);
		189	begin
		190	FTracesList := TTraces.Create(Self);
		191	{$IFNDEF VER4UP}
		192	tmpPointArrSize := 0;
		193	tmpPointArr := nil;
		194	{$ENDIF}
		195	Image1.Picture.Bitmap.Width := Pane.Width;
		196	Image1.Picture.Bitmap.Height := Pane.Height;
		197	btnGrid.Click;
		198	end;
		199
		200	procedure TDelphiXPathsEditForm.FormDestroy(Sender: TObject);
		201	begin
		202	{$IFNDEF VER4UP}
		203	if tmpPointArrSize > 0 then
		204	System.ReallocMem(tmpPointArr, 0);
		205	{$ENDIF}
		206	FTracesList.Free;
		207	FTracesList := nil;
		208	end;
		209
		210	procedure SetActiveColor(Active: Boolean; S: TShape);
		211	begin
		212	if Active then S.Pen.Color := clRed
		213	else S.Pen.Color := $008080FF;
		214	if Active then
		215	if Active then S.Brush.Color := clYellow
		216	else S.Brush.Color := $0095FFFF
		217	else
		218	if Active then S.Brush.Color := clGray
		219	else S.Brush.Color := $00C4C4C4;
		220	end;
		221
		222	procedure TDelphiXPathsEditForm.ShowTracesOnPane_;
		223	var
		224	I, J: Integer;
		225	S: TShape;
		226	B: Boolean;
		227	begin
		228	Screen.Cursor := crHourGlass;
		229	{uvolni predchozi}
		230	for I := ComponentCount - 1 downto 0 do
		231	if Components[I] is TShape then with Components[I] as TShape do begin
		232	if Parent = Pane then
		233	Free;
		234	end;
		235	{projdi seznam}
		236	for I := 0 to FTracesList.Count - 1 do begin
		237	{slozky-udelej pomocne pole}
		238	CreatePathFromActiveTrace(I);
		239	B := cbListOfTraces.ItemIndex = I; {aktivni radek}
		240	{vlastni stopy}
		241	{$IFNDEF VER4UP}
		242	for J := 0 to tmpPointArrSize - 1 do
		243	{$ELSE}
		244	for J := Low(tmpPointArr) to High(tmpPointArr) do
		245	{$ENDIF}
		246	begin
		247	S := TShape.Create(Self);
		248	//----------
		249	S.Parent := Pane;
		250	S.Width := 16;
		251	S.Height := 16;
		252	SetActiveColor(B, S);
		253	//----------
		254	S.Left := Round(tmpPointArr[J].X) - 8; {na stred}
		255	S.Top := Round(tmpPointArr[J].Y) - 8; {na stred}
		256	S.ShowHint := True;
		257	S.Hint := FTracesList.Items[I].Name;
		258	if Trim(S.Hint) = '' then S.Hint := Format('(unnamed[%d])', [I]);
		259	S.ShowHint := True;
		260	//Upravovat ale lze pouze jen tu cestu, ktera je aktivni v combobox
		261	if cbListOfTraces.ItemIndex = I then begin
		262	S.OnMouseDown := ShapeMouseDown;
		263	S.OnMouseMove := ShapeMouseMove;
		264	S.OnMouseUp := ShapeMouseUp;
		265	end;
		266	S.Tag := Integer(J);
		267
		268	end;
		269	end;
		270	btnGrid.Click;
		271	Screen.Cursor := crDefault;
		272	end;
		273
		274	procedure TDelphiXPathsEditForm.ShowTracesOnPane;
		275	var
		276	I, J, index: Integer;
		277	S: TShape;
		278	P: TPath;
		279	begin
		280	Screen.Cursor := crHourGlass;
		281	{uvolni predchozi}
		282	for I := ComponentCount - 1 downto 0 do
		283	if Components[I] is TShape then with Components[I] as TShape do begin
		284	if Parent = Pane then
		285	Free;
		286	end;
		287	{projdi seznam}
		288	for I := 0 to FTracesList.Count - 1 do begin
		289	{slozky-udelej pomocne pole}
		290	index := i;
		291	if index = -1 then Exit;
		292	{vlastni stopy}
		293	with FTracesList.Items[index].Blit do
		294	if GetPathCount > 0 then begin
		295	for J := 0 to GetPathCount - 1 do
		296	begin
		297	S := TShape.Create(Self);
		298	//----------
		299	S.Parent := Pane;
		300	S.Width := 16;
		301	S.Height := 16;
		302	SetActiveColor(cbListOfTraces.ItemIndex = I, S);
		303	//----------
		304	S.Left := Round(Path[J].X) - 8; {na stred}
		305	S.Top := Round(Path[J].Y) - 8; {na stred}
		306	S.ShowHint := True;
		307	S.Hint := FTracesList.Items[I].Name;
		308	if Trim(S.Hint) = '' then S.Hint := Format('(unnamed[%d])', [I]);
		309	S.ShowHint := True;
		310	//Upravovat ale lze pouze jen tu cestu, ktera je aktivni v combobox
		311	if cbListOfTraces.ItemIndex = I then begin
		312	S.OnMouseDown := ShapeMouseDown;
		313	S.OnMouseMove := ShapeMouseMove;
		314	S.OnMouseUp := ShapeMouseUp;
		315	end;
		316	S.Tag := Integer(J);
		317	P := Path[J];
		318	P.Tag := Integer(S);
		319	Path[J] := P;
		320	end;
		321	end;
		322	end;
		323	btnGrid.Click;
		324	Screen.Cursor := crDefault;
		325	end;
		326
		327	procedure TDelphiXPathsEditForm.RefreshShowTracesOnPaneOnly;
		328	var
		329	I, J, index: Integer;
		330	S: TShape;
		331	// P: TPath;
		332	begin
		333	Screen.Cursor := crHourGlass;
		334	{projdi seznam}
		335	for I := 0 to FTracesList.Count - 1 do begin
		336	{slozky-udelej pomocne pole}
		337	index := i;
		338	if index = -1 then Exit;
		339	{vlastni stopy}
		340	with FTracesList.Items[index].Blit do
		341	if GetPathCount > 0 then begin
		342	for J := 0 to GetPathCount - 1 do
		343	begin
		344	S := TShape(Path[J].Tag);
		345	if Assigned(S) then begin
		346	S.Left := Round(Path[J].X) - 8;
		347	S.Top := Round(Path[J].Y) - 8;
		348	SetActiveColor(cbListOfTraces.ItemIndex = I, S);
		349	//----------
		350	//Upravovat ale lze pouze jen tu cestu, ktera je aktivni v combobox
		351	if cbListOfTraces.ItemIndex = I then begin
		352	S.OnMouseDown := ShapeMouseDown;
		353	S.OnMouseMove := ShapeMouseMove;
		354	S.OnMouseUp := ShapeMouseUp;
		355	end
		356	else
		357	begin
		358	S.OnMouseDown := nil;
		359	S.OnMouseMove := nil;
		360	S.OnMouseUp := nil;
		361	end;
		362	end;
		363	end;
		364	end;
		365	end;
		366	btnGrid.Click;
		367	Screen.Cursor := crDefault;
		368	end;
		369
		370	procedure TDelphiXPathsEditForm.ShapeMouseMove(Sender: TObject;
		371	Shift: TShiftState; X, Y: Integer);
		372	var
		373	M: TPoint;
		374	begin
		375	if FCapture and (ssLeft in Shift) then begin
		376	TShape(Sender).Left := TShape(Sender).Left - (MouseDownSpot.x - x);
		377	TShape(Sender).Top := TShape(Sender).Top - (MouseDownSpot.y - y);
		378	end;
		379	//pro zmenu velikosti
		380	if FClicked and (ssRight in Shift) and Assigned(LastShape) then begin
		381	M := Pane.ScreenToClient({$IFNDEF VER4UP}Point(X, Y){$ELSE}Mouse.CursorPos{$ENDIF});
		382	LastShape.Width := M.X - LastShape.Left;
		383	LastShape.Height := M.Y - LastShape.Top;
		384	end;
		385	end;
		386
		387	procedure TDelphiXPathsEditForm.ShapeMouseUp(Sender: TObject; Button: TMouseButton;
		388	Shift: TShiftState; X, Y: Integer);
		389	begin
		390	if FCapture then
		391	begin
		392	ReleaseCapture;
		393	FCapture := False;
		394	TShape(Sender).Left := TShape(Sender).Left - (MouseDownSpot.x - x);
		395	TShape(Sender).Top := TShape(Sender).Top - (MouseDownSpot.y - y);
		396	end;
		397	LastShape := nil;
		398	FClicked := False;
		399	RewriteTracesFromPane;
		400	ShowTracesOnPane;
		401	Cursor := crDefault;
		402	end;
		403
		404	procedure TDelphiXPathsEditForm.ShapeMouseDown(Sender: TObject; Button: TMouseButton;
		405	Shift: TShiftState; X, Y: Integer);
		406	var
		407	P: TPoint;
		408	begin
		409	FCapture := ssLeft in Shift;
		410	MouseDownSpot.X := X;
		411	MouseDownSpot.Y := Y;
		412	FClicked := ssRight in Shift;
		413	if FClicked and (Sender is TShape) then begin
		414	P := TShape(Sender).ClientToScreen(Point(X, Y));
		415	PopupMenu1.Popup(P.X, P.Y);
		416	Exit;
		417	end;
		418	ShapeMouseMove(Sender, Shift, X, Y);
		419	if (Sender is TShape) then
		420	LastShape := TShape(Sender);
		421	Cursor := {$IFNDEF VER4UP}crSIZE{$ELSE}crSizeAll{$ENDIF};
		422	end;
		423
		424	procedure TDelphiXPathsEditForm.RewriteTracesFromPane;
		425	var
		426	I: Integer;
		427	S: TShape;
		428	//TT: TTracePoint;
		429	T: TPath;
		430	begin
		431	for I := ComponentCount - 1 downto 0 do
		432	if Components[I] is TShape then begin
		433	S := Components[I] as TShape;
		434	if S.Parent = Pane then
		435	if S.Hint = cbListOfTraces.Text then //active item only
		436	begin
		437	T := PrivateTraces.Items[cbListOfTraces.ItemIndex].Blit.Path[S.Tag];
		438	T.X := S.Left + 8;
		439	T.Y := S.Top + 8;
		440	{tady lze prepsat jine atributy treba Rychlost...}
		441	PrivateTraces.Items[cbListOfTraces.ItemIndex].Blit.Path[S.Tag] := T;
		442	end;
		443	end;
		444	end;
		445
		446	procedure TDelphiXPathsEditForm.btnBringToFrontClick(Sender: TObject);
		447	var
		448	T: TTrace;
		449	begin
		450	if cbListOfTraces.ItemIndex <> -1 then begin
		451	T := FTracesList.Add;
		452	T.Assign(FTracesList.Items[cbListOfTraces.ItemIndex]);
		453	{$IFDEF VER5UP}
		454	FTracesList.Delete(cbListOfTraces.ItemIndex);
		455	{$ELSE}
		456	FTracesList.Items[cbListOfTraces.ItemIndex].Free;
		457	{$ENDIF}
		458	cbListOfTraces.Items.Move(cbListOfTraces.ItemIndex, cbListOfTraces.Items.Count - 1);
		459	cbListOfTraces.ItemIndex := cbListOfTraces.Items.Count - 1;
		460	ShowTracesOnPane
		461	end;
		462	end;
		463
		464	procedure TDelphiXPathsEditForm.btnCreateNewTrace(Sender: TObject);
		465	var
		466	S: string;
		467	T: TTrace;
		468	begin
		469	if InputQuery('Name of new Trace:', 'Trace name', S) then begin
		470	if Trim(S) = '' then begin
		471	ShowMessage('Name for new trace mustn''t be empty.');
		472	Exit;
		473	end;
		474	if cbListOfTraces.Items.IndexOf(S) <> -1 then begin
		475	ShowMessage('Name for new trace has to be unique.');
		476	Exit;
		477	end;
		478	T := FTracesList.Add;
		479	T.Name := S;
		480	cbListOfTraces.Items.AddObject(S, Pointer(PrivateTraces.Count - 1));
		481	cbListOfTraces.ItemIndex := cbListOfTraces.Items.IndexOf(S);
		482	cbListOfTracesChange(cbListOfTraces);
		483	end;
		484	end;
		485
		486	procedure TDelphiXPathsEditForm.btnNewTraceClick(Sender: TObject);
		487	begin
		488	btnCreateNewTrace(Sender);
		489	end;
		490
		491	procedure TDelphiXPathsEditForm.rgShapeClick(Sender: TObject);
		492	begin
		493	btnNewTrace.Enabled := btnLine.Down or btnCircle.Down or btnCurve.Down;
		494	end;
		495
		496	procedure TDelphiXPathsEditForm.cbListOfTracesChange(Sender: TObject);
		497	begin
		498	RewriteTracesFromPane;
		499	RefreshShowTracesOnPaneOnly
		500	end;
		501
		502	procedure TDelphiXPathsEditForm.OKButtonClick(Sender: TObject);
		503	begin
		504	RewriteTracesFromPane;
		505	Tag := 1;
		506	end;
		507
		508	procedure TDelphiXPathsEditForm.Image1MouseDown(Sender: TObject;
		509	Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
		510	{zapnou se funkce pro sber}
		511	begin
		512	if ssleft in Shift then begin
		513	X0 := X; LX := X;
		514	Y0 := Y; LY := Y;
		515	Image1.Picture.Bitmap.Canvas.Pen.Mode := pmNotXor;
		516	Image1.Picture.Bitmap.Canvas.Pen.Color := clRed;
		517	Image1.Picture.Bitmap.Canvas.Brush.Style := bsClear;
		518	IsDownNow := True;
		519	if btnCurve.Down then begin
		520	{$IFNDEF VER4UP}
		521	tmpPointArrSize := 1;
		522	System.ReallocMem(tmpPointArr, tmpPointArrSize * SizeOf(TDPoint));
		523	tmpPointArr[tmpPointArrSize - 1].X := X;
		524	tmpPointArr[tmpPointArrSize - 1].Y := Y;
		525	{$ELSE}
		526	SetLength(tmpPointArr, 1);
		527	tmpPointArr[High(tmpPointArr)].X := X;
		528	tmpPointArr[High(tmpPointArr)].Y := Y;
		529	{$ENDIF}
		530	end;
		531	end;
		532	end;
		533
		534	procedure TDelphiXPathsEditForm.Image1MouseMove(Sender: TObject;
		535	Shift: TShiftState; X, Y: Integer);
		536	{zabira ze plocha}
		537	begin
		538	if IsDownNow then with Image1.Picture.Bitmap.Canvas do begin
		539	if btnSelectionArea.Down then begin
		540	Rectangle(X0, Y0, LX, LY);
		541	Rectangle(X0, Y0, X, Y);
		542	end;
		543	if btnLine.Down then begin
		544	MoveTo(x0, y0);
		545	LineTo(lx, ly);
		546	MoveTo(x0, y0);
		547	LineTo(x, y);
		548	end;
		549	if btnCircle.Down or btnRect.Down then begin
		550	Rectangle(X0, Y0, LX, LY);
		551	Rectangle(X0, Y0, X, Y);
		552	end;
		553	if btnCurve.Down then begin
		554	if (X <> LX) or (Y <> LY) then begin
		555	{$IFNDEF VER4UP}
		556	Inc(tmpPointArrSize);
		557	System.ReallocMem(tmpPointArr, tmpPointArrSize * SizeOf(TDPoint));
		558	tmpPointArr[tmpPointArrSize - 1].X := X;
		559	tmpPointArr[tmpPointArrSize - 1].Y := Y;
		560	{$ELSE}
		561	SetLength(tmpPointArr, Length(tmpPointArr) + 1);
		562	tmpPointArr[High(tmpPointArr)].X := X;
		563	tmpPointArr[High(tmpPointArr)].Y := Y;
		564	{$ENDIF}
		565
		566	MoveTo(LX, LY);
		567	LineTo(x, y);
		568	end;
		569	end;
		570	LX := X;
		571	LY := Y;
		572	end;
		573	StatusBar1.Panels[1].Text := Format('(x,y)=(%d,%d)', [X, Y]);
		574	end;
		575
		576	{$IFNDEF VER4UP}
		577	function Min(i1, i2: integer): integer;
		578	begin
		579	if i1 < i2 then Result := i1 else Result := i2;
		580	end;
		581
		582	function Max(i1, i2: integer): integer;
		583	begin
		584	if i1 > i2 then Result := i1 else Result := i2;
		585	end;
		586	{$ENDIF}
		587
		588	procedure TDelphiXPathsEditForm.Image1MouseUp(Sender: TObject;
		589	Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
		590	{koncovy bod}
		591	var
		592	i, v, a, b, c: Integer;
		593	beta, sinbeta, cosbeta, angle, step, ii, vx, vy, alpha, sinalpha, cosalpha, p, vv, a1, b1: Double;
		594	begin
		595	if IsDownNow then with Image1.Picture.Bitmap.Canvas do begin
		596	if btnCurve.Down then begin
		597	DoMakePoints;
		598	Label3.Caption := '';
		599	Image1.OnMouseDown := nil;
		600	Image1.OnMouseMove := nil;
		601	Image1.OnMouseUp := nil;
		602	btnCurve.Down := False;
		603	end;
		604	if btnSelectionArea.Down then begin
		605	if ssShift in Shift then begin
		606	Rectangle(X0, Y0, LX, LY); //smazat
		607	Pen.Mode := pmCopy; //napevno
		608	v := Max(Abs(X0 - x), Abs(X0 - y));
		609	Rectangle(X0, y0, X0 + v, Y0 + v); //vykreslit
		610	end
		611	else begin
		612	Pen.Mode := pmCopy; //napevno
		613	Rectangle(x0, y0, x, y);
		614	end;
		615	tmpRect := Rect(x0, y0, x, y);
		616	Label3.Caption := Format('R:((%d,%d),(%d,%d))', [x0, y0, x, y]);
		617	Image1.OnMouseDown := nil;
		618	Image1.OnMouseMove := nil;
		619	Image1.OnMouseUp := nil;
		620	btnSelectionArea.Down := False;
		621	end;
		622	if btnLine.Down then begin
		623	MoveTo(x0, y0);
		624	LineTo(x, y);
		625	{$IFNDEF VER4UP}
		626	tmpPointArrSize := 2;
		627	System.ReallocMem(tmpPointArr, tmpPointArrSize * SizeOf(TDPoint));
		628	{$ELSE}
		629	SetLength(tmpPointArr, 2);
		630	{$ENDIF}
		631	C := 0;
		632	tmpPointArr[C].X := X0;
		633	tmpPointArr[C].Y := Y0;
		634	Inc(C);
		635	tmpPointArr[C].X := X;
		636	tmpPointArr[C].Y := Y;
		637	DoMakePoints;
		638	Label3.Caption := '';
		639	Image1.OnMouseDown := nil;
		640	Image1.OnMouseMove := nil;
		641	Image1.OnMouseUp := nil;
		642	btnLine.Down := False;
		643	end;
		644	if btnCircle.Down then begin
		645	Rectangle(X0, Y0, LX, LY); //smazat
		646	{$IFNDEF VER4UP}
		647	tmpPointArrSize := eAmount.AsInteger;
		648	System.ReallocMem(tmpPointArr, tmpPointArrSize * SizeOf(TDPoint));
		649	{$ELSE}
		650	SetLength(tmpPointArr, eAmount.AsInteger);
		651	{$ENDIF}
		652	{neni pootocena}
		653	angle := 0;
		654	beta := -angle / 180 * PI;
		655
		656	sinbeta := Sin(beta);
		657	cosbeta := Cos(beta);
		658	step := 360 / eAmount.AsInteger;
		659	ii := 0; v := {$IFNDEF VER4UP}0{$ELSE}Low(tmpPointArr){$ENDIF};
		660	a := Abs(LX - X0) div 2; //mayor
		661	b := Abs(LY - Y0) div 2; //minor
		662	vx := X0 + a; //center x
		663	vy := Y0 + b; //center y
		664	while ii < 360 do begin
		665	alpha := ii / 180 * PI;
		666	sinalpha := Sin(alpha);
		667	cosalpha := Cos(alpha);
		668	tmpPointArr[v].X := vx + (a * cosalpha * cosbeta - b * sinalpha * sinbeta);
		669	tmpPointArr[v].Y := vy + (a * cosalpha * sinbeta + b * sinalpha * cosbeta);
		670	inc(v);
		671	ii := ii + step;
		672	end;
		673	DoMakePoints;
		674	Label3.Caption := '';
		675	Image1.OnMouseDown := nil;
		676	Image1.OnMouseMove := nil;
		677	Image1.OnMouseUp := nil;
		678	btnCircle.Down := False;
		679	end;
		680	if btnRect.Down then begin
		681	Rectangle(X0, Y0, LX, LY); //smazat
		682	{$IFNDEF VER4UP}
		683	tmpPointArrSize := eAmount.AsInteger;
		684	System.ReallocMem(tmpPointArr, tmpPointArrSize * SizeOf(TDPoint));
		685	{$ELSE}
		686	SetLength(tmpPointArr, eAmount.AsInteger);
		687	{$ENDIF}
		688	a1 := LX - X0;
		689	b1 := LY - Y0;
		690	//c := 2 * (LX - X0) + 2 * (LY - Y0); //delka
		691	ii := (2 * a1 + 2 * b1) / eAmount.AsInteger; //delka useku
		692	//first point is here
		693	vv := 0;
		694	tmpPointArr[0].X := X0; p := X0;
		695	tmpPointArr[0].Y := Y0;
		696	{rozhodit body po obdelniku}
		697	for I := 1 to eAmount.AsInteger - 1 do begin
		698	p := p + ii;
		699	vv := vv + ii;
		700	if vv < a1 then begin
		701	tmpPointArr[I].X := p;
		702	tmpPointArr[I].Y := Y0;
		703	end
		704	else
		705	if vv < (a1 + b1) then begin
		706	tmpPointArr[I].X := LX;
		707	tmpPointArr[I].Y := Y0 + (vv - a1);
		708	end
		709	else
		710	if vv < (2 * a1 + b1) then begin
		711	tmpPointArr[I].X := LX - (vv - (a1 + b1));
		712	tmpPointArr[I].Y := LY;
		713	end
		714	else
		715	if vv < (2 * a1 + 2 * b1) then begin
		716	tmpPointArr[I].X := X0;
		717	tmpPointArr[I].Y := LY - (vv - (2 * a1 + b1));
		718	end;
		719	end;
		720	DoMakePoints;
		721	Label3.Caption := '';
		722	Image1.OnMouseDown := nil;
		723	Image1.OnMouseMove := nil;
		724	Image1.OnMouseUp := nil;
		725	btnRect.Down := False;
		726	end;
		727	end;
		728	IsDownNow := False;
		729	end;
		730
		731	procedure TDelphiXPathsEditForm.PaneResize(Sender: TObject);
		732	begin
		733	Image1.Picture.Bitmap.Width := Pane.Width;
		734	Image1.Picture.Bitmap.Height := Pane.Height;
		735	end;
		736
		737	procedure TDelphiXPathsEditForm.DoMakePoints;
		738	function distance2d(x1, z1, x2, z2: single): single;
		739	var
		740	diffx, diffz: single;
		741	begin
		742	diffX := x1 - x2;
		743	diffZ := z1 - z2;
		744	result := system.Sqrt(diffX * diffX + diffZ * diffZ);
		745	end;
		746	var
		747	T: TTrace;
		748	Q: TPath;
		749	I, D, C: Integer;
		750	DX, DY, TX, TY: Single;
		751	begin
		752	if btnLine.Down then begin
		753	C := 0;
		754	if {$IFNDEF VER4UP}tmpPointArrSize{$ELSE}Length(tmpPointArr){$ENDIF} = 2 then begin
		755	D := Round(distance2d(tmpPointArr[C].X, tmpPointArr[C].Y, tmpPointArr[C + 1].X, tmpPointArr[C + 1].Y));
		756	if cbListOfTraces.ItemIndex <> -1 then begin
		757	{ziskej aktivni stopu}
		758	T := PrivateTraces.Items[cbListOfTraces.ItemIndex];
		759	T.Blit.SetPathLen(0); //smaz
		760	{vytvoreni slozek}
		761	{korekce, je-li bodu vic nez delka cary}
		762	if eAmount.AsInteger > D then
		763	eAmount.AsInteger := D;
		764	{nastaveni velikosti cesty}
		765	T.Blit.SetPathLen(eAmount.AsInteger);
		766	{rozhozeni bodu na caru}
		767	DX := (tmpPointArr[C + 1].X - tmpPointArr[C].X) / eAmount.AsInteger;
		768	DY := (tmpPointArr[C + 1].Y - tmpPointArr[C].Y) / eAmount.AsInteger;
		769	TX := tmpPointArr[C].X;
		770	TY := tmpPointArr[C].Y;
		771	for I := 1 to eAmount.AsInteger do begin
		772	FillChar(Q, SizeOf(Q), 0);
		773	Q.X := Round(TX + (I - 1) * DX);
		774	Q.Y := Round(TY + (I - 1) * DY);
		775	Q.StayOn := eShowOn.AsInteger;
		776	T.Blit.Path[I - 1] := Q;
		777	end;
		778	T.Active := True;
		779	ShowTracesOnPane;
		780	end;
		781	end;
		782	end;
		783	if btnCircle.Down or btnRect.Down or btnCurve.Down then begin
		784	if cbListOfTraces.ItemIndex <> -1 then begin
		785	{ziskej aktivni stopu}
		786	T := PrivateTraces.Items[cbListOfTraces.ItemIndex];
		787	T.Blit.SetPathLen(0); //smaz
		788	{vytvoreni slozek}
		789	{$IFNDEF VER4UP}
		790	T.Blit.SetPathLen(tmpPointArrSize);
		791	for I := 0 to tmpPointArrSize - 1 do
		792	{$ELSE}
		793	T.Blit.SetPathLen(Length(tmpPointArr));
		794	for I := Low(tmpPointArr) to High(tmpPointArr) do
		795	{$ENDIF}
		796	begin
		797	FillChar(Q, SizeOf(Q), 0);
		798	Q.X := Round(tmpPointArr[I].X);
		799	Q.Y := Round(tmpPointArr[I].Y);
		800	Q.StayOn := eShowOn.AsInteger;
		801	T.Blit.Path[I] := Q;
		802	end;
		803	T.Active := True;
		804	ShowTracesOnPane;
		805	end;
		806	end;
		807	end;
		808
		809	procedure TDelphiXPathsEditForm.btnRefreshClick(Sender: TObject);
		810	begin
		811	DoMakePoints;
		812	end;
		813
		814	procedure TDelphiXPathsEditForm.btnSelectionAreaClick(Sender: TObject);
		815	begin
		816	Image1.OnMouseDown := Image1MouseDown;
		817	Image1.OnMouseMove := Image1MouseMove;
		818	Image1.OnMouseUp := Image1MouseUp;
		819	end;
		820
		821	procedure TDelphiXPathsEditForm.btnSendToBackClick(Sender: TObject);
		822	var
		823	T: TTrace;
		824	I: Integer;
		825	begin
		826	if cbListOfTraces.ItemIndex <> -1 then begin
		827	T := FTracesList.Items[cbListOfTraces.ItemIndex]; //saved
		828	//from selected to first
		829	for I := cbListOfTraces.ItemIndex-1 downto 0 do begin
		830	FTracesList.Items[I] := FTracesList.Items[I + 1];
		831	end;
		832	FTracesList.Items[0] := T;
		833	cbListOfTraces.Items.Move(cbListOfTraces.ItemIndex, 0);
		834	cbListOfTraces.ItemIndex := 0; {it is first now}
		835	ShowTracesOnPane
		836	end;
		837	end;
		838
		839	procedure TDelphiXPathsEditForm.btnSetTimmingClick(Sender: TObject);
		840	var
		841	T: TTrace;
		842	I: Integer;
		843	P: TPath;
		844	begin
		845	if MessageDlg(Format('Do you want change show time to %d ms for each point ?', [eShowOn.AsInteger]), mtConfirmation, [mbYes, mbNo], 0) = mrYes then
		846	begin
		847	{move selected path to down}
		848	if cbListOfTraces.ItemIndex <> -1 then begin
		849	{ziskej aktivni stopu}
		850	T := PrivateTraces.Items[cbListOfTraces.ItemIndex];
		851	for I := 0 to T.Blit.GetPathCount - 1 do
		852	begin
		853	P := T.Blit.Path[I];
		854	P.StayOn := eShowOn.AsInteger;
		855	T.Blit.Path[I] := P;
		856	end;
		857	end;
		858	ShowTracesOnPane;
		859	end;
		860	end;
		861
		862	procedure TDelphiXPathsEditForm.btnGridClick(Sender: TObject);
		863	const
		864	ccGrid = 32;
		865	ccShift = 16;
		866	var I: Integer;
		867	{$IFNDEF VER4UP}
		868	// pp: Pointer;
		869	{$ELSE}
		870	pp: array of TPoint;
		871	{$ENDIF}
		872	begin
		873	if btnGrid.Down then
		874	with Image1.Picture.Bitmap.Canvas do begin
		875	Brush.Color := clBlack;
		876	FillRect(Bounds(0, 0, Image1.Picture.Bitmap.Width, Image1.Picture.Bitmap.Width));
		877	Pen.Color := clDkGray;
		878	Pen.Style := psDot;
		879	Pen.Mode := pmCopy;
		880	Pen.Width := 1;
		881	for I := 0 to Image1.Picture.Bitmap.Width div ccGrid do begin
		882	MoveTo(I * ccGrid + ccShift, 0);
		883	LineTo(I * ccGrid + ccShift, Image1.Picture.Bitmap.Height);
		884	end;
		885	for I := 0 to Image1.Picture.Bitmap.Width div ccGrid do begin
		886	MoveTo(0, I * ccGrid + ccShift);
		887	LineTo(Image1.Picture.Bitmap.Width, I * ccGrid + ccShift);
		888	end;
		889	Pen.Color := clLtGray;
		890	Pen.Style := psSolid;
		891	Pen.Width := 1;
		892	for I := 0 to Image1.Picture.Bitmap.Width div 32 do begin
		893	MoveTo(I * 32, 0);
		894	LineTo(I * 32, Image1.Picture.Bitmap.Height);
		895	end;
		896	for I := 0 to Image1.Picture.Bitmap.Width div 32 do begin
		897	MoveTo(0, I * 32);
		898	LineTo(Image1.Picture.Bitmap.Width, I * 32);
		899	end;
		900	end
		901	else
		902	with Image1.Picture.Bitmap.Canvas do begin
		903	Brush.Color := clBlack;
		904	FillRect(Bounds(0, 0, Image1.Picture.Bitmap.Width, Image1.Picture.Bitmap.Width));
		905	end;
		906	if (tmpRect.Right > 0) and (tmpRect.Bottom > 0) then
		907	with Image1.Picture.Bitmap.Canvas do begin
		908	Pen.Color := clGreen;
		909	Pen.Width := 1;
		910	Pen.Mode := pmCopy;
		911	Brush.Style := bsClear;
		912	{$IFDEF VER5UP}
		913	Rectangle(tmpRect);
		914	{$ELSE}
		915	Rectangle(tmpRect.Left, tmpRect.Top, tmpRect.Right, tmpRect.Bottom);
		916	{$ENDIF}
		917	end;
		918	with Image1.Picture.Bitmap.Canvas do begin
		919	CreatePathFromActiveTrace(cbListOfTraces.ItemIndex);
		920	{$IFNDEF VER4UP}
		921	if tmpPointArrSize <= 0 then Exit;
		922	MoveTo(Round(tmpPointArr[0].X), Round(tmpPointArr[0].Y));
		923	for I := 1 to tmpPointArrSize - 1 do
		924	LineTo(Round(tmpPointArr[I].X), Round(tmpPointArr[I].Y));
		925	{$ELSE}
		926	if Length(tmpPointArr) = 0 then Exit;
		927	SetLength(pp, Length(tmpPointArr));
		928	for I := Low(tmpPointArr) to High(tmpPointArr) do
		929	pp[I] := Point(Round(tmpPointArr[I].X), Round(tmpPointArr[I].Y));
		930	Pen.Color := clWhite;
		931	Pen.Width := 1;
		932	Pen.Mode := pmCopy;
		933	Brush.Style := bsClear;
		934	Polyline(pp);
		935	{$ENDIF}
		936	end;
		937	end;
		938
		939	procedure TDelphiXPathsEditForm.btnLineClick(Sender: TObject);
		940	begin
		941	Image1.OnMouseDown := Image1MouseDown;
		942	Image1.OnMouseMove := Image1MouseMove;
		943	Image1.OnMouseUp := Image1MouseUp;
		944	end;
		945
		946	procedure TDelphiXPathsEditForm.Button1Click(Sender: TObject);
		947	begin
		948	tmpRect := Rect(0, 0, 0, 0);
		949	Label3.Caption := 'R:<none>';
		950	end;
		951
		952	procedure TDelphiXPathsEditForm.CreatePathFromActiveTrace(index: Integer);
		953	var
		954	J: Integer;
		955	begin
		956	{$IFNDEF VER4UP}
		957	tmpPointArrSize := 0;
		958	System.ReallocMem(tmpPointArr, tmpPointArrSize * SizeOf(TDPoint));
		959	{$ELSE}
		960	SetLength(tmpPointArr, 0);
		961	{$ENDIF}
		962	if index = -1 then Exit;
		963	{vlastni stopy}
		964	with FTracesList.Items[index].Blit do
		965	if GetPathCount > 0 then begin
		966	{$IFNDEF VER4UP}
		967	tmpPointArrSize := GetPathCount;
		968	System.ReallocMem(tmpPointArr, tmpPointArrSize * SizeOf(TDPoint));
		969	{$ELSE}
		970	SetLength(tmpPointArr, GetPathCount);
		971	{$ENDIF}
		972	for J := 0 to GetPathCount - 1 do
		973	begin
		974	tmpPointArr[J].X := Path[J].X;
		975	tmpPointArr[J].Y := Path[J].Y;
		976	tmpPointArr[J].StayOn := Path[J].StayOn;
		977	end;
		978	end;
		979	end;
		980
		981	procedure TDelphiXPathsEditForm.btnMoveUpClick(Sender: TObject);
		982	var
		983	T: TTrace;
		984	I: Integer;
		985	P: TPath;
		986	begin
		987	{move selected path to up}
		988	if cbListOfTraces.ItemIndex <> -1 then begin
		989	{ziskej aktivni stopu}
		990	T := PrivateTraces.Items[cbListOfTraces.ItemIndex];
		991	for I := 0 to T.Blit.GetPathCount - 1 do
		992	begin
		993	P := T.Blit.Path[I];
		994	P.Y := P.Y - eDist.AsInteger;
		995	T.Blit.Path[I] := P;
		996	end;
		997	end;
		998	ShowTracesOnPane;
		999	end;
		1000
		1001	procedure TDelphiXPathsEditForm.btnMoveDownClick(Sender: TObject);
		1002	var
		1003	T: TTrace;
		1004	I: Integer;
		1005	P: TPath;
		1006	begin
		1007	{move selected path to down}
		1008	if cbListOfTraces.ItemIndex <> -1 then begin
		1009	{ziskej aktivni stopu}
		1010	T := PrivateTraces.Items[cbListOfTraces.ItemIndex];
		1011	for I := 0 to T.Blit.GetPathCount - 1 do
		1012	begin
		1013	P := T.Blit.Path[I];
		1014	P.Y := P.Y + eDist.AsInteger;
		1015	T.Blit.Path[I] := P;
		1016	end;
		1017	end;
		1018	ShowTracesOnPane;
		1019	end;
		1020
		1021	procedure TDelphiXPathsEditForm.btnMoveLeftClick(Sender: TObject);
		1022	var
		1023	T: TTrace;
		1024	I: Integer;
		1025	P: TPath;
		1026	begin
		1027	{move selected path to left}
		1028	if cbListOfTraces.ItemIndex <> -1 then begin
		1029	{ziskej aktivni stopu}
		1030	T := PrivateTraces.Items[cbListOfTraces.ItemIndex];
		1031	for I := 0 to T.Blit.GetPathCount - 1 do
		1032	begin
		1033	P := T.Blit.Path[I];
		1034	P.X := P.X - eDist.AsInteger;
		1035	T.Blit.Path[I] := P;
		1036	end;
		1037	end;
		1038	ShowTracesOnPane;
		1039	end;
		1040
		1041	procedure TDelphiXPathsEditForm.btnMoveRightClick(Sender: TObject);
		1042	var
		1043	T: TTrace;
		1044	I: Integer;
		1045	P: TPath;
		1046	begin
		1047	{move selected path to right}
		1048	if cbListOfTraces.ItemIndex <> -1 then begin
		1049	{ziskej aktivni stopu}
		1050	T := PrivateTraces.Items[cbListOfTraces.ItemIndex];
		1051	for I := 0 to T.Blit.GetPathCount - 1 do
		1052	begin
		1053	P := T.Blit.Path[I];
		1054	P.X := P.X + eDist.AsInteger;
		1055	T.Blit.Path[I] := P;
		1056	end;
		1057	end;
		1058	ShowTracesOnPane;
		1059	end;
		1060
		1061	procedure Rotate(iRotAng: Single; x, y: Double; var Nx, Ny: Double);
		1062	procedure SinCosS(const Theta: Single; var Sin, Cos: Single); register;
		1063	// EAX contains address of Sin
		1064	// EDX contains address of Cos
		1065	// Theta is passed over the stack
		1066	asm
		1067	FLD Theta
		1068	FSINCOS
		1069	FSTP DWORD PTR [EDX] // cosine
		1070	FSTP DWORD PTR [EAX] // sine
		1071	end;
		1072	const PI256 = 2 * PI / 256;
		1073	var
		1074	SinVal, CosVal, RotAng: Single;
		1075	begin
		1076	RotAng := iRotAng * PI256;
		1077	SinCosS(RotAng, SinVal, CosVal);
		1078	Nx := x * CosVal - y * SinVal;
		1079	Ny := y * CosVal + x * SinVal;
		1080	end;
		1081
		1082	procedure RotateO(RotAng: Double; x, y, ox, oy: Double; var Nx, Ny: Double);
		1083	begin
		1084	Rotate(RotAng, x - ox, y - oy, Nx, Ny);
		1085	Nx := Nx + ox;
		1086	Ny := Ny + oy;
		1087	end;
		1088
		1089	function TDelphiXPathsEditForm.GetSizesOfTrace(out x, y, oWidth, oHeight: Integer): Boolean;
		1090	var
		1091	T: TTrace;
		1092	I: Integer;
		1093	P: TPath;
		1094	maxX, minX, maxY, minY: Single;
		1095	begin
		1096	Result := False;
		1097	oWidth := 0;
		1098	oHeight := 0;
		1099	maxX := 0;
		1100	minX := MaxInt;
		1101	maxY := 0;
		1102	minY := MaxInt;
		1103	if cbListOfTraces.ItemIndex <> -1 then begin
		1104	{ziskej aktivni stopu}
		1105	T := PrivateTraces.Items[cbListOfTraces.ItemIndex];
		1106	for I := 0 to T.Blit.GetPathCount - 1 do
		1107	begin
		1108	P := T.Blit.Path[I];
		1109	if P.X > maxX then maxX := P.X;
		1110	if P.Y > maxY then maxY := P.Y;
		1111	if P.X < minX then minX := P.X;
		1112	if P.Y < minY then minY := P.Y;
		1113	end;
		1114	x := Round(minX);
		1115	y := Round(minY);
		1116	oWidth := Abs(Round(maxX) - Round(minX));
		1117	oHeight := Abs(Round(maxY) - Round(minY));
		1118	Result := True;
		1119	end;
		1120	end;
		1121
		1122	procedure TDelphiXPathsEditForm.RotatePathForAngle(Angle: Integer);
		1123	var
		1124	T: TTrace;
		1125	I, x, y, width, height: Integer;
		1126	P: TPath;
		1127	nX, nY, dX, dY: Double;
		1128	begin
		1129	if GetSizesOfTrace(x, y, Width, Height) then
		1130	begin
		1131	dX := (x + width / 2);
		1132	dY := (y + height / 2);
		1133	T := PrivateTraces.Items[cbListOfTraces.ItemIndex];
		1134	for I := 0 to T.Blit.GetPathCount - 1 do
		1135	begin
		1136	P := T.Blit.Path[I];
		1137	RotateO(Angle, P.X, P.Y, dX, dY, nX, nY);
		1138	P.X := nX;
		1139	P.Y := nY;
		1140	T.Blit.Path[I] := P;
		1141	end;
		1142	end;
		1143	end;
		1144
		1145	procedure TDelphiXPathsEditForm.btnRotateLeftClick(Sender: TObject);
		1146	begin
		1147	RotatePathForAngle(-1 * eDist.AsInteger);
		1148	RefreshShowTracesOnPaneOnly
		1149	end;
		1150
		1151	procedure TDelphiXPathsEditForm.btnRotateRightClick(Sender: TObject);
		1152	begin
		1153	RotatePathForAngle(eDist.AsInteger);
		1154	RefreshShowTracesOnPaneOnly
		1155	end;
		1156
		1157	end.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DxPathEdit.pas – Rev 4