home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kolekce / d6 / FRCLX.ZIP / SOURCE / FR_Shape.pas < prev    next >
Pascal/Delphi Source File  |  2001-07-06  |  5KB  |  191 lines
  1.  
  2. {******************************************}
  3. {                                          }
  4. {           FastReport CLX v2.4            }
  5. {           Shape Add-In Object            }
  6. {                                          }
  7. { Copyright (c) 1998-2001 by Tzyganenko A. }
  8. {                                          }
  9. {******************************************}
  10.  
  11. unit FR_Shape;
  12.  
  13. interface
  14.  
  15. {$I FR.inc}
  16.  
  17. uses
  18.   SysUtils, Types, Classes, QGraphics, FR_Class, QStdCtrls,
  19.   QControls, QForms, QExtCtrls, QMenus;
  20.  
  21.  
  22. const
  23.   skRectangle = 0;
  24.   skRoundRectangle = 1;
  25.   skEllipse = 2;
  26.   skTriangle = 3;
  27.   skDiagonal1 = 4;
  28.   skDiagonal2 = 5;
  29.  
  30. type
  31.   TfrShapeObject = class(TComponent)  // fake component
  32.   end;
  33.  
  34.   TfrShapeView = class(TfrView)
  35.   private
  36.     procedure DrawShape;
  37.   protected
  38.     procedure SetPropValue(Index: String; Value: Variant); override;
  39.     function GetPropValue(Index: String): Variant; override;
  40.   public
  41.     ShapeType: Byte;
  42.     constructor Create; override;
  43.     procedure Draw(Canvas: TCanvas); override;
  44.     procedure LoadFromStream(Stream: TStream); override;
  45.     procedure SaveToStream(Stream: TStream); override;
  46.     procedure DefinePopupMenu(Popup: TPopupMenu); override;
  47.     procedure DefineProperties; override;
  48.   end;
  49.  
  50.  
  51. implementation
  52.  
  53. uses FR_Utils, FR_Const, Variants;
  54.  
  55. {$R *.res}
  56.  
  57.  
  58. constructor TfrShapeView.Create;
  59. begin
  60.   inherited Create;
  61.   ShapeType := skRectangle;
  62.   BaseName := 'Shape';
  63.  
  64.   frConsts['skRectangle'] := skRectangle;
  65.   frConsts['skRoundRectangle'] := skRoundRectangle;
  66.   frConsts['skEllipse'] := skEllipse;
  67.   frConsts['skTriangle'] := skTriangle;
  68.   frConsts['skDiagonal1'] := skDiagonal1;
  69.   frConsts['skDiagonal2'] := skDiagonal2;
  70. end;
  71.  
  72. procedure TfrShapeView.DefineProperties;
  73. begin
  74.   inherited DefineProperties;
  75.   AddEnumProperty('Shape',
  76.     'skRectangle;skRoundRectangle;skEllipse;skTriangle;skDiagonal1;skDiagonal2',
  77.     [skRectangle,skRoundRectangle,skEllipse,skTriangle,skDiagonal1,skDiagonal2]);
  78. end;
  79.  
  80. procedure TfrShapeView.SetPropValue(Index: String; Value: Variant);
  81. begin
  82.   inherited SetPropValue(Index, Value);
  83.   Index := AnsiUpperCase(Index);
  84.   if Index = 'SHAPE' then
  85.     ShapeType := Value;
  86. end;
  87.  
  88. function TfrShapeView.GetPropValue(Index: String): Variant;
  89. begin
  90.   Index := AnsiUpperCase(Index);
  91.   Result := inherited GetPropValue(Index);
  92.   if Result <> Null then Exit;
  93.   if Index = 'SHAPE' then
  94.     Result := ShapeType
  95. end;
  96.  
  97. procedure TfrShapeView.DrawShape;
  98. var
  99.   x1, y1, min: Integer;
  100. begin
  101.   x1 := Round((SaveX + SaveDX) * ScaleX + OffsX);
  102.   y1 := Round((SaveY + SaveDY) * ScaleY + OffsY);
  103.   min := dx;
  104.   if dy < dx then
  105.     min := dy;
  106.   with Canvas do
  107.   begin
  108.     Pen.Width := Round(FrameWidth);
  109.     Pen.Color := FrameColor;
  110.     Pen.Style := psSolid;
  111. //    Brush.Style := bsClear;
  112.     if FillColor <> clNone then
  113.       Brush.Color := FillColor;
  114.     case ShapeType of
  115.       skRectangle:
  116.         Rectangle(x, y, x1 + 1, y1 + 1);
  117.       skRoundRectangle:
  118.         RoundRect(x, y, x1 + 1, y1 + 1, min div 4, min div 4);
  119.       skEllipse:
  120.         Ellipse(x, y, x1 + 1, y1 + 1);
  121.       skTriangle:
  122.         begin
  123.           MoveTo(x1, y1);
  124.           LineTo(x, y1);
  125.           LineTo(x + (x1 - x) div 2, y);
  126.           LineTo(x1, y1);
  127. //          FloodFill(x + (x1 - x) div 2, y + (y1 - y) div 2, clNone, fsSurface);
  128.         end;
  129.       skDiagonal1:
  130.         begin
  131.           MoveTo(x, y1);
  132.           LineTo(x1, y);
  133.         end;
  134.       skDiagonal2:
  135.         begin
  136.           MoveTo(x, y);
  137.           LineTo(x1, y1);
  138.         end;
  139.     end;
  140.     Brush.Style := bsSolid;
  141.   end;
  142. end;
  143.  
  144. procedure TfrShapeView.Draw(Canvas: TCanvas);
  145. var
  146.   FillC: Integer;
  147. begin
  148.   BeginDraw(Canvas);
  149.   Memo1.Assign(Memo);
  150.   CalcGaps;
  151.   FillC := FillColor;
  152.   FillColor := clNone;
  153.   ShowBackground;
  154.   ShowFrame;
  155.   FillColor := FillC;
  156.   DrawShape;
  157.   RestoreCoord;
  158. end;
  159.  
  160. procedure TfrShapeView.LoadFromStream(Stream: TStream);
  161. begin
  162.   inherited LoadFromStream(Stream);
  163.   Stream.Read(ShapeType, 1);
  164. end;
  165.  
  166. procedure TfrShapeView.SaveToStream(Stream: TStream);
  167. begin
  168.   inherited SaveToStream(Stream);
  169.   Stream.Write(ShapeType, 1);
  170. end;
  171.  
  172. procedure TfrShapeView.DefinePopupMenu(Popup: TPopupMenu);
  173. begin
  174.   // no specific items in popup menu
  175. end;
  176.  
  177.  
  178. var
  179.   Bmp: TBitmap;
  180.  
  181. initialization
  182.   Bmp := TBitmap.Create;
  183.   Bmp.LoadFromResourceName(hInstance, 'FR_SHAPE');
  184.   frRegisterObject(TfrShapeView, Bmp, (SInsShape));
  185.  
  186. finalization
  187.   Bmp.Free;
  188.  
  189. end.
  190.  
  191.