Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 2002.02.14;
Скачать: [xml.tar.bz2];

Вниз

Нужен TShape нестандарной формы, как это сделать?   Найти похожие ветки 

 
kingdom   (2002-01-30 14:40) [0]

Например, нужен прямоугольник повернутый на некоторый угол и главное должна быть обработка событий мыши только на самой фигуре, таких как OnClick, OnMove короче как у TShape"а...
Подскажите пожалуйста как это сделать!!!


 
reonid   (2002-01-31 12:54) [1]

Приблизительно так:

unit MyShapes;

interface

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

type
TMyShape = class(TShape)
private
FAngle: Integer;
procedure SetAngle(const Value: Integer);
protected
procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
public
procedure Paint; override;
function Contain(X, Y: Integer): Boolean;
published
property Angle: Integer read FAngle write SetAngle;
end;

procedure Register;

implementation

uses
Math;

{ TMyShape }

procedure TMyShape.CMHitTest(var Message: TCMHitTest);
begin
with Message do Result := Integer( Contain(XPos, YPos) );
end;

function TMyShape.Contain(X, Y: Integer): Boolean;
var DX, DY: Integer;
tg, WW, HH, xx, yy, CenterX, CenterY, AngleRad: Double;
begin
if FAngle = 0 then Result := True
else with Canvas do
begin
AngleRad := FAngle/57.2957795130;
if FAngle < 0 then AngleRad := Pi/2 + AngleRad;
tg := Tan(AngleRad);
DY := Round( (Height - tg*Width)/(1 - tg*tg) );
DX := Round(DY*tg);

HH := DX/Sin(AngleRad);
WW := (Height - DY)/Sin(AngleRad);
CenterX := Width/2;
CenterY := Height/2;
xx := (X-CenterX)*Cos(-AngleRad) + (Y-CenterY)*Sin(-AngleRad);
yy := (Y-CenterY)*Cos(-AngleRad) - (X-CenterX)*Sin(-AngleRad);

if (DX > Width)or(DY > Height)or(DX <= 0)or(DY <= 0)then
begin
Result := (X >= 0)and(Y >= 0)and(X <= Width)and(Y <= Height);
Exit;
end;

if (Abs(xx) < WW/2)and(Abs(yy) < HH/2) then
Result := True
else
Result := False;
end;
end;


procedure TMyShape.Paint;
var DX, DY: Integer;
AngleRad, tg: Double;
begin
if FAngle = 0 then inherited Paint
else with Canvas do
begin
AngleRad := FAngle/57.2957795130;
if FAngle < 0 then AngleRad := Pi/2 + AngleRad;
tg := Tan(AngleRad);
DY := Round( (Height - tg*Width)/(1 - tg*tg) );
DX := Round(DY*tg);

Pen := Self.Pen;
Brush := Self.Brush;

if (DX > Width)or(DY > Height)or(DX <= 0)or(DY <= 0)then
begin
TextRect(ClientRect, 0, 0, "Wrong angle");
// note: 45 degree is allowed only for case Width = Height
Exit;
end;

Polygon([Point(DX, Height), Point(0, Height - DY),
Point(Width - DX, 0), Point(Width, DY)]);
end;
end;



procedure Register;
begin
RegisterComponents("Test", [TMyShape]);
end;

procedure TMyShape.SetAngle(const Value: Integer);
begin
if FAngle <> Value then
if Abs(Value) < 90 then
begin
FAngle := Value;
Invalidate;
end;
end;

end.



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

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

Наверх





Память: 0.46 MB
Время: 0.004 c
1-42792
Hokum
2002-01-31 16:43
2002.02.14
Имитация InterBase


3-42671
WWI
2002-01-21 17:20
2002.02.14
Есть проблема с переносом - пересылкой хранимых процедур


3-42693
ТеньЛуны
2002-01-22 10:57
2002.02.14
dbExpress - поможите люди добрые!


1-42764
VCL
2002-01-26 20:10
2002.02.14
Connect с WORD!!


4-42897
vivus
2001-12-18 10:47
2002.02.14
виндовая мессага.





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский