home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kolekce / d6 / FRCLX.ZIP / SOURCE / FR_RRect.pas < prev    next >
Pascal/Delphi Source File  |  2001-07-06  |  24KB  |  832 lines
  1. {*****************************************************}
  2. {                                                     }
  3. {              FastReport CLX v2.4                    }
  4. {          RoundRect plus Add-in object               }
  5. {       (C) Guilbaud Olivier for FR 2.4               }
  6. {    Some corrections by Alexander Tzyganenko         }
  7. {     For question mail to : golivier@free.fr         }
  8. {*****************************************************}
  9. {Histo :                                              }
  10. { 29/04/99 : CrΘation                                 }
  11. { 30/04/99 : Corrections minueurs                     }
  12. {            Changer le TButton en TImage             }
  13. {            pour le choix de la couleur              }
  14. {            de l'ombre.                              }
  15. {            InitialisΘ avec mots entiers             }
  16. {            par defaut                               }
  17. { 22/06/99 : AjoutΘ la possibilitΘ de dΘgradΘ         }
  18. {            mais dans ce cas, c'est un rectangle     }
  19. { 10/11/99 : Update for the FR 2.31 version           }
  20. {*****************************************************}
  21.  
  22. unit FR_RRect;
  23.  
  24. interface
  25.  
  26. {$I FR.inc}
  27.  
  28. uses
  29.   SysUtils, Types, Classes, QGraphics, QControls, QForms, QDialogs,
  30.   FR_Class, QStdCtrls, QExtCtrls, QImgList;
  31.  
  32. type
  33.   {There are six different gradient styles available.}
  34.   TfrGradientStyle = (gsHorizontal, gsVertical, gsElliptic, gsRectangle,
  35.                       gsVertCenter, gsHorizCenter);
  36.  
  37.   TfrRoundRectObject = class(TComponent)  // fake component
  38.   end;
  39.  
  40.   TfrRoundRect = packed record
  41.     SdColor: TColor;    // Color of Shadow
  42.     wShadow: Integer;   // Width of shadow
  43.     Cadre  : Boolean;   // Frame On/Off - not used /TZ/
  44.     sCurve : Boolean;   // RoundRect On/Off
  45.     wCurve : Integer;   // Curve size
  46.   end;
  47.  
  48.   TfrRoundRectView = class(TfrMemoView)
  49.   private
  50.     Oldgapx, Oldgapy: Integer;
  51.   protected
  52.     procedure SetPropValue(Index: String; Value: Variant); override;
  53.     function GetPropValue(Index: String): Variant; override;
  54.   public
  55.     Cadre: TfrRoundRect;
  56.     constructor Create; override;
  57.     procedure LoadFromStream(Stream: TStream); override;
  58.     procedure SaveToStream(Stream: TStream); override;
  59.     procedure CalcGaps; override;
  60.     procedure RestoreCoord; override;
  61.     procedure ShowFrame; override;
  62.     procedure ShowBackGround; override;
  63.     procedure DefineProperties; override;
  64.     procedure ShowEditor; override;
  65.   end;
  66.  
  67.   TfrRoundRectForm = class(TForm)
  68.     M1: TMemo;
  69.     Button5: TButton;
  70.     Button6: TButton;
  71.     lblSample: TLabel;
  72.     colorDlg: TColorDialog;
  73.     bOk: TButton;
  74.     bCancel: TButton;
  75.     Image1: TImage;
  76.     imgSample: TImage;
  77.     cbGradian: TCheckBox;
  78.     panCurve: TPanel;
  79.     cmShadow: TCheckBox;
  80.     sCurve: TEdit;
  81.     lblSWidth: TLabel;
  82.     ShWidth: TEdit;
  83.     lblSColor: TLabel;
  84.     bcolor: TImage;
  85.     panGrad: TPanel;
  86.     Label1: TLabel;
  87.     bcolor3: TImage;
  88.     Label2: TLabel;
  89.     bColor2: TImage;
  90.     cbStyle: TComboBox;
  91.     Label3: TLabel;
  92.     procedure Button5Click(Sender: TObject);
  93.     procedure Button6Click(Sender: TObject);
  94.     procedure bColorClick(Sender: TObject);
  95.     procedure ShWidthChange(Sender: TObject);
  96.     procedure FormCreate(Sender: TObject);
  97.     procedure cbCadreClick(Sender: TObject);
  98.     procedure cmShadowClick(Sender: TObject);
  99.     procedure M1KeyDown(Sender: TObject; var Key: Word;
  100.       Shift: TShiftState);
  101.     procedure FormKeyDown(Sender: TObject; var Key: Word;
  102.       Shift: TShiftState);
  103.     procedure cbGradianClick(Sender: TObject);
  104.     procedure FormShow(Sender: TObject);
  105.   private
  106.     FView: TfrRoundRectView;
  107.     ShadowColor: TColor;
  108.     NormalColor: TColor;
  109.     procedure ChgColorButton(S: TObject; C: TColor);
  110.     procedure UpdateSample;
  111.     procedure Localize;
  112.   public
  113.   end;
  114.  
  115.  
  116. implementation
  117.  
  118. uses FR_Const, Fr_Utils, Variants, Qt;
  119.  
  120. {$R *.xfm}
  121. {$R *.res}
  122.  
  123. function RGB(r, g, b: Byte): TColor;
  124. begin
  125.   Result := (r or (g shl 8) or (b shl 16));
  126. end;
  127.  
  128.  
  129. procedure PaintGrad(Cv: TCanvas; X, Y, X1, Y1: Integer;
  130.   FBeginClr, FEndClr: TColor; FGradientStyle: TfrGradientStyle);
  131. var
  132.   FromR, FromG, FromB: Integer; //These are the separate color values for RGB
  133.   DiffR, DiffG, DiffB: Integer; // of color values.
  134.   rct: TRect;                   //Rectangle used to draw frame around button
  135.   bm: TBitMap;
  136.  
  137. {To speed things up and reduce flicker, I use a Bitmap to draw the button in
  138.  its entirety, ten BitBlt it to the canvas of the control.}
  139. procedure DoHorizontal(fr, fg, fb, dr, dg, db: Integer);
  140. var
  141.   ColorRect: TRect;
  142.   I: Integer;
  143.   R, G, B: Byte;
  144. begin
  145.   ColorRect.Top := 0;                        //Set rectangle top
  146.   ColorRect.Bottom := bm.Height;
  147.   for I := 0 to 255 do
  148.   begin         //Make lines (rectangles) of color
  149.     ColorRect.Left := MulDiv (I, bm.Width, 256);    //Find left for this color
  150.     ColorRect.Right := MulDiv (I + 1, bm.Width, 256);   //Find Right
  151.     R := fr + MulDiv(I, dr, 255);            //Find the RGB values
  152.     G := fg + MulDiv(I, dg, 255);
  153.     B := fb + MulDiv(I, db, 255);
  154.     bm.Canvas.Brush.Color := RGB(R, G, B);   //Plug colors into brush
  155.     bm.Canvas.FillRect(ColorRect);           //Draw on Bitmap
  156.   end;
  157. end;
  158.  
  159. procedure DoVertical(fr, fg, fb, dr, dg, db: Integer);
  160. var
  161.   ColorRect: TRect;
  162.   I: Integer;
  163.   R, G, B: Byte;
  164. begin
  165.   ColorRect.Left := 0;                //Set rectangle left&right
  166.   ColorRect.Right := bm.Width;
  167.   for I := 0 to 255 do
  168.   begin                               //Make lines (rectangles) of color
  169.     ColorRect.Top := MulDiv (I, bm.Height, 256);    //Find top for this color
  170.     ColorRect.Bottom := MulDiv (I + 1, bm.Height, 256);   //Find Bottom
  171.     R := fr + MulDiv(I, dr, 255);    //Find the RGB values
  172.     G := fg + MulDiv(I, dg, 255);
  173.     B := fb + MulDiv(I, db, 255);
  174.     bm.Canvas.Brush.Color := RGB(R, G, B);   //Plug colors into brush
  175.     bm.Canvas.FillRect(ColorRect);           //Draw on Bitmap
  176.   end;
  177. end;
  178.  
  179. procedure DoElliptic(fr, fg, fb, dr, dg, db: Integer);
  180. var
  181.   I: Integer;
  182.   R, G, B: Byte;
  183.   Pw, Ph: Double;
  184.   x1, y1, x2, y2: Double;
  185. {The elliptic is a bit different, since I had to use real numbers. I cut down
  186.  on the number (to 155 instead of 255) of iterations in an attempt to speed
  187.  things up, to no avail.  I think it just takes longer for windows to draw an
  188.  ellipse as opposed to a rectangle.}
  189. begin
  190.   bm.Canvas.Pen.Style := psClear;
  191.   bm.Canvas.Pen.Mode := pmCopy;
  192.   x1 := 0 - (bm.Width / 4);
  193.   x2 := bm.Width + (bm.Width / 4);
  194.   y1 := 0 - (bm.Height / 4);
  195.   y2 := bm.Height + (bm.Height / 4);
  196.   Pw := ((bm.Width / 4) + (bm.Width / 2)) / 155;
  197.   Ph := ((bm.Height / 4) + (bm.Height / 2)) / 155;
  198.   for I := 0 to 155 do
  199.   begin                              //Make ellipses of color
  200.     x1 := x1 + Pw;
  201.     x2 := X2 - Pw;
  202.     y1 := y1 + Ph;
  203.     y2 := y2 - Ph;
  204.     R := fr + MulDiv(I, dr, 155);    //Find the RGB values
  205.     G := fg + MulDiv(I, dg, 155);
  206.     B := fb + MulDiv(I, db, 155);
  207.     bm.Canvas.Brush.Color := R or (G shl 8) or (b shl 16);   //Plug colors into brush
  208.     bm.Canvas.Ellipse(Trunc(x1), Trunc(y1), Trunc(x2), Trunc(y2));
  209.   end;
  210.   bm.Canvas.Pen.Style := psSolid;
  211. end;
  212.  
  213. procedure DoRectangle(fr, fg, fb, dr, dg, db: Integer);
  214. var
  215.   I: Integer;
  216.   R, G, B: Byte;
  217.   Pw, Ph: Real;
  218.   x1, y1, x2, y2: Double;
  219. begin
  220.   bm.Canvas.Pen.Style := psClear;
  221.   bm.Canvas.Pen.Mode := pmCopy;
  222.   x1 := 0;
  223.   x2 := bm.Width;
  224.   y1 := 0;
  225.   y2 := bm.Height;
  226.   Pw := (bm.Width / 2) / 255;
  227.   Ph := (bm.Height / 2) / 255;
  228.   for I := 0 to 255 do
  229.   begin                              //Make rectangles of color
  230.     x1 := x1 + Pw;
  231.     x2 := X2 - Pw;
  232.     y1 := y1 + Ph;
  233.     y2 := y2 - Ph;
  234.     R := fr + MulDiv(I, dr, 255);    //Find the RGB values
  235.     G := fg + MulDiv(I, dg, 255);
  236.     B := fb + MulDiv(I, db, 255);
  237.     bm.Canvas.Brush.Color := RGB(R, G, B);   //Plug colors into brush
  238.     bm.Canvas.FillRect(Rect(Trunc(x1), Trunc(y1), Trunc(x2), Trunc(y2)));
  239.   end;
  240.   bm.Canvas.Pen.Style := psSolid;
  241. end;
  242.  
  243. procedure DoVertCenter(fr, fg, fb, dr, dg, db: Integer);
  244. var
  245.   ColorRect: TRect;
  246.   I: Integer;
  247.   R, G, B: Byte;
  248.   Haf: Integer;
  249. begin
  250.   Haf := bm.Height Div 2;
  251.   ColorRect.Left := 0;
  252.   ColorRect.Right := bm.Width;
  253.   for I := 0 to Haf do
  254.   begin
  255.     ColorRect.Top := MulDiv(I, Haf, Haf);
  256.     ColorRect.Bottom := MulDiv(I + 1, Haf, Haf);
  257.     R := fr + MulDiv(I, dr, Haf);
  258.     G := fg + MulDiv(I, dg, Haf);
  259.     B := fb + MulDiv(I, db, Haf);
  260.     bm.Canvas.Brush.Color := RGB(R, G, B);
  261.     bm.Canvas.FillRect(ColorRect);
  262.     ColorRect.Top := bm.Height - (MulDiv (I, Haf, Haf));
  263.     ColorRect.Bottom := bm.Height - (MulDiv (I + 1, Haf, Haf));
  264.     bm.Canvas.FillRect(ColorRect);
  265.   end;
  266. end;
  267.  
  268. procedure DoHorizCenter(fr, fg, fb, dr, dg, db: Integer);
  269. var
  270.   ColorRect: TRect;
  271.   I: Integer;
  272.   R, G, B: Byte;
  273.   Haf: Integer;
  274. begin
  275.   Haf := bm.Width Div 2;
  276.   ColorRect.Top := 0;
  277.   ColorRect.Bottom := bm.Height;
  278.   for I := 0 to Haf do
  279.   begin
  280.     ColorRect.Left := MulDiv(I, Haf, Haf);
  281.     ColorRect.Right := MulDiv(I + 1, Haf, Haf);
  282.     R := fr + MulDiv(I, dr, Haf);
  283.     G := fg + MulDiv(I, dg, Haf);
  284.     B := fb + MulDiv(I, db, Haf);
  285.     bm.Canvas.Brush.Color := RGB(R, G, B);
  286.     bm.Canvas.FillRect(ColorRect);
  287.     ColorRect.Left := bm.Width - (MulDiv (I, Haf, Haf));
  288.     ColorRect.Right := bm.Width - (MulDiv (I + 1, Haf, Haf));
  289.     bm.Canvas.FillRect(ColorRect);
  290.   end;
  291. end;
  292.  
  293. begin
  294.   if Cv = nil then Exit;
  295.   try
  296.     bm := TBitMap.Create;
  297.     bm.Width := X1 - X;          //Set BMP dimensions to match control's
  298.     bm.Height :=Y1 - Y;
  299.     rct := Rect(0, 0, bm.Width, bm.Height);  //Set rectangle size for later use
  300.     FromR := FBeginClr and $000000ff;  //Strip out separate RGB values
  301.     FromG := (FBeginClr shr 8) and $000000ff;
  302.     FromB := (FBeginClr shr 16) and $000000ff;
  303.     DiffR := (FEndClr and $000000ff) - FromR;   //Find the difference
  304.     DiffG := ((FEndClr shr 8) and $000000ff) - FromG;
  305.     DiffB := ((FEndClr shr 16) and $000000ff) - FromB;
  306.     //Depending on gradient style selected, go draw it on the Bitmap canvas.
  307.     if FGradientStyle = gsHorizontal then
  308.       DoHorizontal(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  309.     if FGradientStyle = gsVertical then
  310.       DoVertical(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  311.     if FGradientStyle = gsElliptic then
  312.       DoElliptic(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  313.     if FGradientStyle = gsRectangle then
  314.       DoRectangle(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  315.     if FGradientStyle = gsVertCenter then
  316.       DoVertCenter(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  317.     if FGradientStyle = gsHorizCenter then
  318.       DoHorizCenter(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  319.     //By setting the Brush style to Clear, it will draw without overlaying bkgrnd
  320.     bm.Canvas.Brush.Style := bsClear;  //Gradient is done, time for Hilite-Shadow
  321.     {Finally, the button is all painted on the bitmap canvas. Now we just need
  322.      to copy it to the canvas of our control.  BitBlt is one method; there are
  323.      several others.}
  324.     Cv.Draw(X, Y, bm);
  325.   finally
  326.     bm.Free;
  327.   end;
  328. end;
  329.  
  330. (********************************************************)
  331. constructor TfrRoundRectView.Create;
  332. begin
  333.   inherited Create;
  334.  
  335.   //Initialization
  336.   FrameTyp := $FF;
  337.   BaseName := 'RoundRect';
  338.  
  339.   //Default values
  340.   Cadre.SdColor := clGray;
  341.   Cadre.wShadow := 6;
  342.   Cadre.Cadre := True;
  343.   Cadre.sCurve := True;
  344.   Cadre.wCurve := 10;
  345.  
  346.   frConsts['gsVertical'] := gsVertical;
  347.   frConsts['gsHorizontal'] := gsHorizontal;
  348.   frConsts['gsElliptic'] := gsElliptic;
  349.   frConsts['gsRectangle'] := gsRectangle;
  350.   frConsts['gsHorizCenter'] := gsHorizCenter;
  351.   frConsts['gsVertCenter'] := gsVertCenter;
  352. end;
  353.  
  354. procedure TfrRoundRectView.DefineProperties;
  355. begin
  356.   inherited DefineProperties;
  357.   AddProperty('ShadowColor', [frdtColor], nil);
  358.   AddProperty('ShadowWidth', [frdtInteger], nil);
  359.   AddProperty('RoundRect', [frdtBoolean], nil);
  360.   AddProperty('RoundSize', [frdtInteger], nil);
  361.   AddProperty('Gradient', [frdtBoolean], nil);
  362.   AddEnumProperty('Style',
  363.     'gsVertical;gsHorizontal;gsElliptic;gsRectangle;gsHorizCenter;gsVertCenter',
  364.     [gsVertical,gsHorizontal,gsElliptic,gsRectangle,gsHorizCenter,gsVertCenter]);
  365.   AddProperty('BeginColor', [frdtColor], nil);
  366.   AddProperty('EndColor', [frdtColor], nil);
  367. end;
  368.  
  369. procedure TfrRoundRectView.SetPropValue(Index: String; Value: Variant);
  370. begin
  371.   inherited SetPropValue(Index, Value);
  372.   Index := AnsiUpperCase(Index);
  373.   with Cadre do
  374.   if Index = 'SHADOWCOLOR' then
  375.     SdColor := Value
  376.   else if Index = 'SHADOWWIDTH' then
  377.     wShadow := Value
  378.   else if Index = 'ROUNDRECT' then
  379.     sCurve := Value
  380.   else if Index = 'ROUNDSIZE' then
  381.     wCurve := Value
  382.   else if Index = 'GRADIENT' then
  383.     if Boolean(Value) then
  384.     begin
  385.       wShadow := -99;
  386.       wCurve := 0;
  387.     end
  388.     else
  389.       wShadow := 10
  390.   else if Index = 'STYLE' then
  391.     wCurve := Value
  392.   else if Index = 'BEGINCOLOR' then
  393.     SdColor := Value
  394.   else if Index = 'ENDCOLOR' then
  395.     FillColor := Value
  396. end;
  397.  
  398. function TfrRoundRectView.GetPropValue(Index: String): Variant;
  399. begin
  400.   Index := AnsiUpperCase(Index);
  401.   Result := inherited GetPropValue(Index);
  402.   if Result <> Null then Exit;
  403.   with Cadre do
  404.   if Index = 'SHADOWCOLOR' then
  405.     Result := SdColor
  406.   else if Index = 'SHADOWWIDTH' then
  407.     Result := wShadow
  408.   else if Index = 'ROUNDRECT' then
  409.     Result := sCurve
  410.   else if Index = 'ROUNDSIZE' then
  411.     Result := wCurve
  412.   else if Index = 'GRADIENT' then
  413.     Result := wShadow = -99
  414.   else if Index = 'STYLE' then
  415.     if wShadow = -99 then
  416.       Result := wCurve else
  417.       Result := 0
  418.   else if Index = 'BEGINCOLOR' then
  419.     Result := SdColor
  420.   else if Index = 'ENDCOLOR' then
  421.     Result := FillColor
  422. end;
  423.  
  424. procedure TfrRoundRectView.LoadFromStream(Stream: TStream);
  425. begin
  426.   inherited LoadFromStream(Stream);
  427.   Stream.Read(Cadre, SizeOf(Cadre));
  428. end;
  429.  
  430. procedure TfrRoundRectView.SaveToStream(Stream: TStream);
  431. begin
  432.   inherited SaveToStream(Stream);
  433.   Stream.Write(Cadre, SizeOf(Cadre));
  434. end;
  435.  
  436. procedure TfrRoundRectView.CalcGaps;
  437. begin
  438.   Oldgapx := gapx;
  439.   Oldgapy := gapy;
  440.   inherited CalcGaps;
  441.  
  442.   if Cadre.wShadow <> -99 then
  443.   begin
  444.     DRect.Right := DRect.Right - Cadre.wShadow;
  445.     DRect.Bottom := DRect.Bottom - Cadre.wShadow;
  446.   end;
  447.   gapx := gapx + (Cadre.wCurve div 4);
  448.   gapy := gapy + (Cadre.wCurve div 4);
  449. end;
  450.  
  451. procedure TfrRoundRectView.RestoreCoord;
  452. begin
  453.   inherited RestoreCoord;
  454.   gapx := Oldgapx;
  455.   gapy := Oldgapy;
  456. end;
  457.  
  458. procedure TfrRoundRectView.ShowBackGround;
  459. var
  460.   OldDRect: TRect;
  461.   OldFill: TColor;
  462. begin
  463.   // prevent screen garbage in designer
  464.   if (DocMode <> dmDesigning) or (Cadre.wShadow = -99) then Exit;
  465.   OldDRect := DRect;
  466.   OldFill := FillColor;
  467.   DRect := Rect(x, y, x + dx + 1, y + dy + 1);
  468.   FillColor := clWhite;
  469.   inherited;
  470.   DRect := OldDRect;
  471.   FillColor := OldFill;
  472. end;
  473.  
  474. procedure TfrRoundRectView.ShowFrame;
  475. var
  476.   FSW, FCU: Integer;
  477.  
  478.   procedure Line(x, y, dx, dy: Integer);
  479.   begin
  480.     Canvas.MoveTo(x, y);
  481.     Canvas.LineTo(x + dx, y + dy);
  482.   end;
  483.  
  484.   procedure FrameLine(i: Integer);
  485.   begin
  486.     Canvas.Pen.Width := Round(FrameWidth);
  487.     case i of
  488.       0: Line(x + dx, y, 0, dy);
  489.       1: Line(x, y, 0, dy);
  490.       2: Line(x, y + dy, dx, 0);
  491.       3: Line(x, y, dx, 0);
  492.     end;
  493.   end;
  494.  
  495. begin
  496.   if DisableDrawing then Exit;
  497.   with Canvas do
  498.   begin
  499.     if Cadre.wShadow = -99 then
  500.     begin
  501.       if Cadre.wCurve < 0 then
  502.         Cadre.wCurve := 0;
  503.       PaintGrad(Canvas, X, Y, X + DX, Y + DY, FillColor, Cadre.SdColor,
  504.         TfrGradientStyle(Cadre.wCurve));
  505.       Pen.Width := Round(FrameWidth);
  506.       Pen.Color := FrameColor;
  507.  
  508.       if (FrameTyp and $1) <> 0 then FrameLine(0);
  509.       if (FrameTyp and $4) <> 0 then FrameLine(1);
  510.       if (FrameTyp and $2) <> 0 then FrameLine(2);
  511.       if (FrameTyp and $8) <> 0 then FrameLine(3);
  512.  
  513.       Exit;
  514.     end;
  515.  
  516.     // Trace l'ombre
  517.     Pen.Style := psSolid;
  518.     Brush.Style := bsSolid;
  519.     Pen.Color := Cadre.SdColor;
  520.     Pen.Width := Round(FrameWidth);
  521.     Brush.Color := Cadre.SdColor;
  522.  
  523.     FSW := Round(Cadre.wShadow * ScaleY);
  524.     FCU := Round(Cadre.wCurve * ScaleY);
  525.  
  526.     if Cadre.sCurve then
  527.       RoundRect(x + FSW, y + FSW, x + dx + 1, y + dy + 1, FCu, Fcu) else
  528.       Rectangle(x + FSW, y + FSW, x + dx + 1, y + dy + 1);
  529.  
  530.     // Trace la zone de texte
  531.     Pen.Width := Round(FrameWidth);
  532.     Cadre.Cadre := ((FrameTyp and $F) = $F); // Si zone de cadre dΘsactivΘe
  533.  
  534.     if not Cadre.Cadre then
  535.       Pen.Color := FillColor else
  536.       Pen.Color := FrameColor; // Trace le cadre
  537.  
  538.     Brush.Color := FillColor;
  539.     if Cadre.sCurve then
  540.       RoundRect(x, y, x + dx + 1 - FSW, y + dy + 1 - FSW, FCu, Fcu) else
  541.       Rectangle(x, y, x + dx + 1 - FSW, y + dy + 1 - FSW);
  542.   end;
  543. end;
  544.  
  545. procedure TfrRoundRectView.ShowEditor;
  546. begin
  547.   with TfrRoundRectForm.Create(nil) do
  548.   begin
  549.     FView := Self;
  550.     M1.Lines.Assign(Memo);
  551.     shWidth.Text := IntToStr(Cadre.wShadow);
  552.     if Cadre.wShadow <> -99 then
  553.     begin // RoundRect
  554.       cbGradian.Checked := False;
  555.       ShadowColor := Cadre.sdColor;
  556.       NormalColor := FillColor;
  557.       cmShadow.Checked := Cadre.sCurve;
  558.       sCurve.Text := IntToStr(Cadre.wCurve);
  559.     end
  560.     else
  561.     begin //Gradian
  562.       cbGradian.Checked := True;
  563.       ShadowColor := Cadre.sdColor;
  564.       NormalColor := FillColor;
  565.       if Cadre.wCurve > cbStyle.Items.Count - 1 then
  566.         Cadre.wCurve := 0;
  567.       cbStyle.ItemIndex := Cadre.wCurve;
  568.     end;
  569.  
  570.     if ShowModal = mrOk then
  571.     begin
  572.       frDesigner.BeforeChange;
  573.       Memo.Assign(M1.Lines);
  574.       Cadre.sdColor := ShadowColor;
  575.       FillColor := NormalColor;
  576.       Cadre.sCurve := cmShadow.Checked;
  577.       try
  578.         Cadre.wShadow := StrToInt(shWidth.Text);
  579.       except
  580.         Cadre.wShadow := 6;
  581.       end;
  582.  
  583.       try
  584.         Cadre.wCurve := StrToInt(sCurve.Text);
  585.         if Cadre.wShadow = -99 then
  586.           Cadre.wCurve := cbStyle.ItemIndex;
  587.       except
  588.         Cadre.wCurve := 10;
  589.       end;
  590.     end;
  591.     Free;
  592.   end;
  593. end;
  594.  
  595.  
  596. (****************************************************)
  597. procedure TfrRoundRectForm.Localize;
  598. var
  599.   i: Integer;
  600.   s: String;
  601. begin
  602.   Caption := (S53670);
  603.   LblSample.Caption := (S53671);
  604.   Button5.Caption   := (S53672);
  605.   Button6.Caption   := (S53673);
  606.   cbGradian.Caption := (S53674);
  607.   lblSWidth.Caption := (S53675);
  608.   LblSColor.Caption := (S53676);
  609.   cmShadow.Caption  := (S53677);
  610.   Label1.Caption    := (S53679);
  611.   Label2.Caption    := (S53680);
  612.   Label3.Caption    := (S53681);
  613.   bColor.Hint       := (S53683);
  614.   bColor2.Hint      := bColor.Hint;
  615.   bColor3.Hint      := bColor3.Hint;
  616.   BOk.Caption       := (SOk);
  617.   bCancel.Caption   := (SCancel);
  618.  
  619.   cbStyle.Items.CommaText := (S53682);
  620.   for i := 0 to cbStyle.Items.Count - 1 do
  621.   begin
  622.     s := cbStyle.Items.Strings[i];
  623.     if Pos('_', s) <> 0 then
  624.     begin
  625.       s[Pos('_', s)] := ' ';
  626.       cbStyle.Items.Strings[i] := s;
  627.     end;
  628.   end;
  629. end;
  630.  
  631. procedure TfrRoundRectForm.FormCreate(Sender: TObject);
  632. begin
  633.   Localize;
  634.   panGrad.Left := panCurve.Left;
  635.   panGrad.Top := panCurve.Top;
  636.   panGrad.Visible := False;
  637. end;
  638.  
  639. procedure TfrRoundRectForm.Button5Click(Sender: TObject);
  640. var
  641.   s: String;
  642. begin
  643.   s := frDesigner.InsertExpression;
  644.   if s <> '' then
  645.     M1.SelText := s;
  646.   M1.SetFocus;
  647. end;
  648.  
  649. procedure TfrRoundRectForm.Button6Click(Sender: TObject);
  650. var
  651.   s: String;
  652. begin
  653.   s := frDesigner.InsertExpression;
  654.   if s <> '' then
  655.     M1.SelText := s;
  656.   M1.SetFocus;
  657. end;
  658.  
  659. procedure TfrRoundRectForm.ChgColorButton(S: TObject; C: TColor);
  660. var
  661.   BM: TBitmap;
  662.   Bc: TImage;
  663. begin
  664.   BM := TBitmap.Create;
  665.   Bc := S as TImage;
  666.   BM.Height := bC.Height;
  667.   BM.Width := bC.Width;
  668.  
  669.   with BM.Canvas do
  670.   begin
  671.     Pen.Color := clBlack;
  672.     Brush.Color := C;
  673.     Rectangle(0, 0, bC.Width, bC.Height);
  674.   end;
  675.   if Bc.Tag = 0 then
  676.     ShadowColor := C else
  677.     NormalColor := C;
  678.  
  679.   bC.Picture.Assign(BM);
  680.   BM.Free;
  681. end;
  682.  
  683. procedure TfrRoundRectForm.UpdateSample;
  684. var
  685.   CC: TCanvas;
  686.   FsW: Integer;
  687.   FCu: Integer;
  688.   BM: TBitmap;
  689. begin
  690.   try
  691.     FsW := StrToInt(ShWidth.Text);
  692.   except
  693.     FsW := 10;
  694.   end;
  695.  
  696.   try
  697.     FCu := StrToInt(SCurve.Text);
  698.   except
  699.     FCu := 10;
  700.   end;
  701.  
  702.   BM := TBitmap.Create;
  703.   BM.Height := imgSample.Height;
  704.   BM.Width := imgSample.Width;
  705.  
  706.   CC := BM.Canvas;
  707.  
  708.   if cbGradian.Checked then
  709.   begin
  710.     FsW := cbStyle.ItemIndex;
  711.     if FsW < 0 then FsW:=0;
  712.     PaintGrad(CC, 0, 0, bm.Width, bm.Height, NormalColor, ShadowColor,
  713.       TfrGradientStyle(FsW));
  714.   end
  715.   else
  716.   begin
  717.     // RΘinitialise le panel
  718.     CC.Pen.Color := clBtnFace;
  719.     CC.Brush.Color := clBtnFace;
  720.     CC.Rectangle(0, 0, imgSample.Width, imgSample.Height);
  721.  
  722.     // Trace l'ombre
  723.     CC.Pen.Color := ShadowColor;
  724.     CC.Brush.Color := ShadowColor;
  725.  
  726.     if cmShadow.Checked then
  727.       CC.RoundRect(0 + FSW, 0 + FSW, imgSample.Width, imgSample.Height,
  728.         FCu, FCu)
  729.     else
  730.       CC.Rectangle(0 + FSW, 0 + FSW, imgSample.Width, imgSample.Height);
  731.  
  732.     // Trace la zone de texte
  733.     if FView.FrameTyp = 0 then
  734.       CC.Pen.Color := NormalColor else
  735.       CC.Pen.Color := FView.FrameColor; // Trace le cadre
  736.  
  737.     CC.Brush.Color := NormalColor;
  738.     if cmShadow.Checked then
  739.       CC.RoundRect(0, 0, imgSample.Width - FSW, imgSample.Height - FSW,
  740.         FCu, FCu)
  741.     else
  742.       CC.Rectangle(0, 0, imgSample.Width - FSW, imgSample.Height - FSW);
  743.   end;
  744.  
  745.   imgSample.Picture.Assign(BM);
  746.   BM.Free;
  747. end;
  748.  
  749. procedure TfrRoundRectForm.bColorClick(Sender: TObject);
  750. begin
  751.   ColorDlg.Color := ShadowColor;
  752.   if ColorDlg.Execute then
  753.   begin
  754.     ChgColorButton(Sender, ColorDlg.Color);
  755.     UpdateSample;
  756.   end;
  757. end;
  758.  
  759. procedure TfrRoundRectForm.ShWidthChange(Sender: TObject);
  760. begin
  761.   if Sender is TEdit then
  762.     if TEdit(Sender).Text = '' then Exit;
  763.   UpdateSample;
  764. end;
  765.  
  766. procedure TfrRoundRectForm.cbCadreClick(Sender: TObject);
  767. begin
  768.   UpdateSample;
  769. end;
  770.  
  771. procedure TfrRoundRectForm.cmShadowClick(Sender: TObject);
  772. begin
  773.   UpdateSample;
  774. end;
  775.  
  776. procedure TfrRoundRectForm.cbGradianClick(Sender: TObject);
  777. begin
  778.   panGrad.Visible := cbGradian.Checked;
  779.   panCurve.Visible := not panGrad.Visible;
  780.   if panGrad.Visible then
  781.   begin
  782.     shWidth.Text := '-99';
  783.     sCurve.Text := '0';
  784.     cbStyle.ItemIndex := 0;
  785.   end
  786.   else
  787.   begin
  788.     shWidth.Text := '10';
  789.     sCurve.Text := '10';
  790.   end;
  791. end;
  792.  
  793. procedure TfrRoundRectForm.M1KeyDown(Sender: TObject; var Key: Word;
  794.   Shift: TShiftState);
  795. begin
  796.   if (Key = key_Insert) and (Shift = []) then Button5Click(Self);
  797.   if Key = key_Escape then ModalResult := mrCancel;
  798. end;
  799.  
  800. procedure TfrRoundRectForm.FormKeyDown(Sender: TObject; var Key: Word;
  801.   Shift: TShiftState);
  802. begin
  803.   if (Key = key_Return) and (ssCtrl in Shift) then
  804.   begin
  805.     ModalResult := mrOk;
  806.     Key := 0;
  807.   end;
  808. end;
  809.  
  810. procedure TfrRoundRectForm.FormShow(Sender: TObject);
  811. begin
  812.   M1.SetFocus;
  813.   UpdateSample;
  814.   ChgColorButton(bColor, ShadowColor);
  815.   ChgColorButton(bColor2, NormalColor);
  816.   ChgColorButton(bColor3, ShadowColor);
  817. end;
  818.  
  819.  
  820. var
  821.   Bmp: TBitmap;
  822.  
  823. initialization
  824.   Bmp := TBitmap.Create;
  825.   Bmp.LoadFromResourceName(hInstance, 'FR_ROUNDRECTVIEW');
  826.   frRegisterObject(TfrRoundRectView, Bmp, (SInsRoundRect));
  827.  
  828. finalization
  829.   Bmp.Free;
  830.  
  831. end.
  832.