home *** CD-ROM | disk | FTP | other *** search
/ PC Format Collection 48 / SENT14D.ISO / tech / delphi / disk15 / shape.pak / SHAPES.PAS
Encoding:
Pascal/Delphi Source File  |  1995-08-24  |  2.9 KB  |  134 lines
  1. unit Shapes;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs;
  8.  
  9. type
  10.   TSampleShapeType = (sstRectangle, sstSquare, sstRoundRect, sstRoundSquare,
  11.     sstEllipse, sstCircle);
  12.   TSampleShape = class(TGraphicControl)
  13.   private
  14.     { Private declarations }
  15.     FShape: TSampleShapeType;
  16.     FPen: TPen;
  17.     FBrush: TBrush;
  18.     procedure SetShape(Value: TSampleShapeType);
  19.     procedure SetBrush(Value: TBrush);
  20.     procedure SetPen(Value: TPen);
  21.   protected
  22.     { Protected declarations }
  23.     procedure Paint; override;
  24.   public
  25.     { Public declarations }
  26.     constructor Create(AOwner: TComponent); override;
  27.     destructor Destroy; override;
  28.   published
  29.     { Published declarations }
  30.     procedure StyleChanged(Sender: TObject);
  31.     property Brush: TBrush  read FBrush write SetBrush;
  32.     property DragCursor;
  33.     property DragMode;
  34.     property Height default 65;
  35.     property OnDragDrop;
  36.     property OnDragOver;
  37.     property OnEndDrag;
  38.     property OnMouseDown;
  39.     property OnMouseMove;
  40.     property OnMouseUp;
  41.     property Pen: TPen  read FPen write SetPen;
  42.     property Shape: TSampleShapeType  read FShape write SetShape;
  43.     property Width default 65;
  44.   end;
  45.  
  46. procedure Register;
  47.  
  48. implementation
  49.  
  50. procedure Register;
  51. begin
  52.   RegisterComponents('Samples', [TSampleShape]);
  53. end;
  54.  
  55. constructor TSampleShape.Create(AOwner: TComponent);
  56. begin
  57.   inherited Create(AOwner);
  58.   Width := 65;
  59.   Height := 65;
  60.   FPen := TPen.Create;
  61.   FPen.OnChange := StyleChanged;
  62.   FBrush := TBrush.Create;
  63.   FBrush.OnChange := StyleChanged;
  64. end;
  65.  
  66. destructor TSampleShape.Destroy;
  67. begin
  68.   FPen.Free;
  69.   FBrush.Free;
  70.   inherited Destroy;
  71. end;
  72.  
  73. procedure TSampleShape.Paint;
  74. var
  75.   X, Y, W, H, S: Integer;
  76. begin
  77.   with Canvas do
  78.   begin
  79.     Pen := FPen;
  80.     Brush := FBrush;
  81.     W := Width;
  82.     H := Height;
  83.     if W < H then S := W else S := H;
  84.     case FShape of
  85.       sstRectangle, sstRoundRect, sstEllipse:
  86.         begin
  87.           X := 0;
  88.           Y := 0;
  89.         end;
  90.       sstSquare, sstRoundSquare, sstCircle:
  91.         begin
  92.           X := (W - S) div 2;
  93.           Y := (H - S) div 2;
  94.           W := S;
  95.           H := S;
  96.         end;
  97.     end;
  98.     case FShape of
  99.       sstRectangle, sstSquare:
  100.         Rectangle(X, Y, X + W, Y + H);
  101.       sstRoundRect, sstRoundSquare:
  102.         RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);
  103.       sstCircle, sstEllipse:
  104.         Ellipse(X, Y, X + W, Y + H);
  105.     end;
  106.   end;
  107. end;
  108.  
  109. procedure TSampleShape.SetBrush(Value: TBrush);
  110. begin
  111.   FBrush.Assign(Value);
  112. end;
  113.  
  114. procedure TSampleShape.SetPen(Value: TPen);
  115. begin
  116.   FPen.Assign(Value);
  117. end;
  118.  
  119. procedure TSampleShape.SetShape(Value: TSampleShapeType);
  120. begin
  121.   if FShape <> Value then
  122.   begin
  123.     FShape := Value;
  124.     Invalidate;
  125.   end;
  126. end;
  127.  
  128. procedure TSampleShape.StyleChanged(Sender: TObject);
  129. begin
  130.   Invalidate;
  131. end;
  132.  
  133. end.
  134.