paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-18 23:09:29 +01:00
Code Issues Packages Projects Releases Wiki Activity

added diamonds to TShape

Browse Source 
git-svn-id: trunk@5191 -
This commit is contained in:
mattias 2004-02-10 10:13:09 +00:00
parent 3e893c428f
commit ed1cc49f8b
2 changed files with 31 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
lcl/extctrls.pp
View File

@ -311,7 +311,7 @@ type
{ TShape }
TShapeType = (stRectangle, stSquare, stRoundRect, stRoundSquare,
stEllipse, stCircle);
stEllipse, stCircle, stSquaredDiamond, stDiamond);
TShape = class(TGraphicControl)
private
@ -322,25 +322,22 @@ type
procedure SetPen(Value: TPen);
procedure SetShape(Value: TShapeType);
public
constructor Create(AOwner: TComponent); override;
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
published
procedure StyleChanged(Sender: TObject);
published
property Align;
property Anchors;
property Brush: TBrush read FBrush write SetBrush;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Constraints;
property ParentShowHint;
property Pen: TPen read FPen write SetPen;
property Shape: TShapeType read FShape write SetShape;
property ShowHint;
property Visible;
property OnChangeBounds;
// property OnDragDrop;
// property OnDragOver;
// property OnEndDock;
@ -348,8 +345,12 @@ type
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
// property OnStartDock;
// property OnStartDrag;
property Shape: TShapeType read FShape write SetShape;
property ShowHint;
property Visible;
end;
@ -924,6 +925,9 @@ end.
{
$Log$
Revision 1.96 2004/02/10 10:13:08 mattias
added diamonds to TShape
Revision 1.95 2004/02/04 22:17:08 mattias
removed workaround VirtualCreate

25
lcl/include/shape.inc
View File

@ -13,10 +13,10 @@
*****************************************************************************
}
constructor TShape.Create(AOwner: TComponent);
constructor TShape.Create(TheOwner: TComponent);
begin
inherited Create(AOwner);
SetBounds(0,0,65,65);
inherited Create(TheOwner);
SetInitialBounds(0,0,65,65);
ControlStyle := ControlStyle + [csReplicatable];
FPen := TPen.Create;
FPen.OnChange := @StyleChanged;
@ -26,8 +26,8 @@ end;
destructor TShape.Destroy;
begin
FPen.Free;
FBrush.Free;
FreeThenNil(FPen);
FreeThenNil(FBrush);
inherited Destroy;
end;
@ -35,6 +35,7 @@ procedure TShape.Paint;
var
PaintRect : TRect;
MinSize : Longint;
P: array[0..3] of TPoint;
begin
with Canvas do
begin
@ -45,7 +46,8 @@ begin
InflateRect(PaintRect, -(Pen.Width div 2), -(Pen.Width div 2));
With PaintRect do begin
MinSize := Min(Right - Left, Bottom - Top);
if FShape in [stSquare, stRoundSquare, stCircle] then begin
if FShape in [stSquare, stRoundSquare, stCircle, stSquaredDiamond] then
begin
Left := Left + ((Right - Left) - MinSize) div 2;
Top := Top + ((Bottom - Top) - MinSize) div 2;
Right := Left + MinSize;
@ -60,6 +62,14 @@ begin
RoundRect(PaintRect, MinSize div 4, MinSize div 4);
stCircle, stEllipse:
Ellipse(PaintRect);
stSquaredDiamond, stDiamond:
with PaintRect do begin
P[0].x:=Left; P[0].y:=Top + (Bottom - Top) div 2;
P[1].x:=Left+ (Right - Left) div 2; P[1].y:=Bottom;
P[2].x:=Right; P[2].y:= P[0].y;
P[3].x:=P[1].x; P[3].y:=Top;
Polygon(P);
end;
end;
end;
end;
@ -95,6 +105,9 @@ end;
{ =============================================================================
$Log$
Revision 1.3 2004/02/10 10:13:09 mattias
added diamonds to TShape
Revision 1.2 2002/08/18 04:57:01 mattias
fixed csDashDot