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