1 {*****************************************************}
2 { }
3 { FastReport v2.3 }
4 { RoundRect plus Add-in object }
5 { (C) Guilbaud Olivier for FR 2.3x }
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 LR_RRect;
23
24 interface
25
26 {$I lr_vers.inc}
27 {$if (FPC_FULLVERSION>=20701)}
28 {$Packset 1}
29 {$endif}
30
31 uses
32 Classes, SysUtils, LResources, GraphMath,
33 Graphics, Controls, Forms, Dialogs,Buttons,
34 StdCtrls, Menus,ClipBrd,
35
36 LCLType,LR_Class, ExtCtrls,LCLIntf,LCLProc;
37
38 type
39 {These are the six different gradient styles available.}
40 TGradientStyle = (gsHorizontal, gsVertical, gsElliptic, gsRectangle,
41 gsVertCenter, gsHorizCenter);
42
43 { TfrRoundRectObject }
44
45 TfrRoundRectObject = class(TComponent)
46 public
47 Constructor Create(aOwner : TComponent); override;
48 end;
49
50 TCorner = (ctTopLeft,ctBottomLeft,ctBottomRight,ctTopRight);
51 TCornerSet = set of TCorner;
52
53 // Pour enregistrer les param�tres
54 TfrRoundRect = packed record
55 SGradian : Boolean; //ShowGradian
56 GradStyle : TGradientStyle;
57
58 SdColor : TColor; // Color of Shadow
59 wShadow : Integer; // Width of shadow
60 sCurve : Boolean; // RoundRect On/Off
61 wCurve : Integer; // Curve size
62 Corners : TCornerSet; // Set of squared corners
63 end;
64
65 { TfrRoundRectView }
66
67 TfrRoundRectView = class(TfrMemoView)
68 private
69 fCadre: TfrRoundRect;
70
GetGradStylenull71 function GetGradStyle: TGradientStyle;
GetRoundRectnull72 function GetRoundRect: boolean;
GetRoundRectCurvenull73 function GetRoundRectCurve: Integer;
GetShadowColornull74 function GetShadowColor: TColor;
GetShadowWidthnull75 function GetShadowWidth: Integer;
GetShowGradnull76 function GetShowGrad: Boolean;
77 procedure SetCorners(AValue: TCornerSet);
78 procedure SetGradStyle(const AValue: TGradientStyle);
79 procedure SetRoundRect(const AValue: boolean);
80 procedure SetRoundRectCurve(const AValue: Integer);
81 procedure SetShadowColor(const AValue: TColor);
82 procedure SetShadowWidth(const AValue: Integer);
83 procedure SetShowGrad(const AValue: Boolean);
GetCornersnull84 function GetCorners: TCornerSet;
85 public
86 constructor Create(AOwnerPage:TfrPage); override;
87 procedure Assign(Source: TPersistent); override;
88 procedure LoadFromStream(Stream: TStream); override;
89 procedure SaveToStream(Stream: TStream); override;
90 procedure LoadFromXML(XML: TLrXMLConfig; const Path: String); override;
91 procedure SaveToXML(XML: TLrXMLConfig; const Path: String); override;
92
93 procedure ShowFrame; override;
94 procedure ShowBackGround; override;
95 published
96 property ShowGradian : Boolean read GetShowGrad write SetShowGrad;
97 property GradianStyle: TGradientStyle read GetGradStyle write SetGradStyle;
98 property ShadowColor : TColor read GetShadowColor write SetShadowColor;
99 property ShadowWidth : Integer read GetShadowWidth write SetShadowWidth;
100 property RoundRect : boolean read GetRoundRect write SetRoundRect;
101 property RoundRectCurve : Integer read GetRoundRectCurve write SetRoundRectCurve;
102 property SquaredCorners: TCornerSet read GetCorners write SetCorners;
103 end;
104
105 // Editeur de propri�t�s
106
107 { TfrRoundRectForm }
108
109 TfrRoundRectForm = class(TfrObjEditorForm)
110 chkTL: TCheckBox;
111 chkTR: TCheckBox;
112 chkBL: TCheckBox;
113 chkBR: TCheckBox;
114 lblSqrCorners: TLabel;
115 M1: TMemo;
116 Button5: TButton;
117 Button6: TButton;
118 lblSample: TLabel;
119 colorDlg: TColorDialog;
120 bOk: TButton;
121 bCancel: TButton;
122 Image1: TImage;
123 imgSample: TImage;
124 cbGradian: TCheckBox;
125 panCurve: TPanel;
126 cmShadow: TCheckBox;
127 sCurve: TEdit;
128 lblSWidth: TLabel;
129 ShWidth: TEdit;
130 lblSColor: TLabel;
131 bcolor: TImage;
132 cbCadre: TCheckBox;
133 panGrad: TPanel;
134 Label1: TLabel;
135 bcolor3: TImage;
136 Label2: TLabel;
137 bColor2: TImage;
138 cbStyle: TComboBox;
139 Label3: TLabel;
140 procedure Button5Click(Sender: TObject);
141 procedure Button6Click(Sender: TObject);
142 procedure bColorClick(Sender: TObject);
143 procedure chkTLClick(Sender: TObject);
144 procedure ShWidthChange(Sender: TObject);
145 procedure FormCreate(Sender: TObject);
146 procedure cbCadreClick(Sender: TObject);
147 procedure cbGradianChange(Sender: TObject);
148 procedure cmShadowClick(Sender: TObject);
149 procedure M1KeyDown(Sender: TObject; var Key: Word;
150 Shift: TShiftState);
151 procedure FormKeyDown(Sender: TObject; var Key: Word;
152 Shift: TShiftState);
153 procedure cbGradianClick(Sender: TObject);
154 procedure FormShow(Sender: TObject);
155 private
156 { D�clarations priv�es }
157 fShadowColor: TColor;
158 fNormalColor: TColor;
159
160 procedure ChgColorButton(S: TObject; C: TColor);
161 procedure SetCorners(AValue: TCornerSet);
162 procedure UpdateSample;
GetCornersnull163 function GetCorners: TCornerSet;
164 public
165 { D�clarations publiques }
166 procedure ShowEditor(t: TfrView); override;
167 property Corners: TCornerSet read GetCorners write SetCorners;
168 end;
169
170 implementation
171
172 uses LR_Const, LR_Var, LR_Flds;
173
174 {$R *.lfm}
175
176 var
177 frRoundRectForm: TfrRoundRectForm;
178
RGBnull179 function RGB(R,G,B : Byte): TColor;
180 begin
181 Result:=(R or (G shl 8) or (B shl 16));
182 end;
183
184
185 procedure PaintGrad(Cv: TCanvas; X, Y, X1, Y1: Word;
186 FBeginClr, FEndClr: TColor; FGradientStyle: TGradientStyle);
187 var
188 FromR, FromG, FromB: Integer; //These are the separate color values for RGB
189 DiffR, DiffG, DiffB: Integer; // of color values.
190 bm: TBitMap;
191
192 {To speed things up and reduce flicker, I use a Bitmap to draw the button in
193 its entirety, ten BitBlt it to the canvas of the control.}
194 procedure DoHorizontal(fr, fg, fb, dr, dg, db: Integer);
195 var
196 ColorRect: TRect;
197 I: Integer;
198 R, G, B: Byte;
199 begin
200 DebugLn('DoHorizontal');
201 ColorRect.Top := 0; //Set rectangle top
202 ColorRect.Bottom := bm.Height;
203 for I := 0 to 255 do
204 begin //Make lines (rectangles) of color
205 ColorRect.Left := MulDiv (I, bm.Width, 256); //Find left for this color
206 ColorRect.Right := MulDiv (I + 1, bm.Width, 256); //Find Right
207 R := fr + MulDiv(I, dr, 255); //Find the RGB values
208 G := fg + MulDiv(I, dg, 255);
209 B := fb + MulDiv(I, db, 255);
210 bm.Canvas.Brush.Color := RGB(R, G, B); //Plug colors into brush
211 bm.Canvas.FillRect(ColorRect); //Draw on Bitmap
212 end;
213 end;
214
215 procedure DoVertical(fr, fg, fb, dr, dg, db: Integer);
216 var
217 ColorRect: TRect;
218 I: Integer;
219 R, G, B: Byte;
220 begin
221 DebugLn('DoVertical');
222
223 ColorRect.Left := 0; //Set rectangle left&right
224 ColorRect.Right := bm.Width;
225 for I := 0 to 255 do
226 begin //Make lines (rectangles) of color
227 ColorRect.Top := MulDiv (I, bm.Height, 256); //Find top for this color
228 ColorRect.Bottom := MulDiv (I + 1, bm.Height, 256); //Find Bottom
229 R := fr + MulDiv(I, dr, 255); //Find the RGB values
230 G := fg + MulDiv(I, dg, 255);
231 B := fb + MulDiv(I, db, 255);
232 bm.Canvas.Brush.Color := RGB(R, G, B); //Plug colors into brush
233 bm.Canvas.FillRect(ColorRect); //Draw on Bitmap
234 end;
235 end;
236
237 procedure DoElliptic(fr, fg, fb, dr, dg, db: Integer);
238 var
239 I: Integer;
240 R, G, B: Byte;
241 Pw, Ph: Double;
242 x1, y1, x2, y2: Double;
243 {The elliptic is a bit different, since I had to use real numbers. I cut down
244 on the number (to 155 instead of 255) of iterations in an attempt to speed
245 things up, to no avail. I think it just takes longer for windows to draw an
246 ellipse as opposed to a rectangle.}
247 begin
248 DebugLn('DoElliptic');
249
250 bm.Canvas.Pen.Style := psClear;
251 bm.Canvas.Pen.Mode := pmCopy;
252 x1 := 0 - (bm.Width / 4);
253 x2 := bm.Width + (bm.Width / 4);
254 y1 := 0 - (bm.Height / 4);
255 y2 := bm.Height + (bm.Height / 4);
256 Pw := ((bm.Width / 4) + (bm.Width / 2)) / 155;
257 Ph := ((bm.Height / 4) + (bm.Height / 2)) / 155;
258 for I := 0 to 155 do
259 begin //Make ellipses of color
260 x1 := x1 + Pw;
261 x2 := X2 - Pw;
262 y1 := y1 + Ph;
263 y2 := y2 - Ph;
264 R := fr + MulDiv(I, dr, 155); //Find the RGB values
265 G := fg + MulDiv(I, dg, 155);
266 B := fb + MulDiv(I, db, 155);
267 bm.Canvas.Brush.Color := R or (G shl 8) or (b shl 16); //Plug colors into brush
268 bm.Canvas.Ellipse(Trunc(x1), Trunc(y1), Trunc(x2), Trunc(y2));
269 end;
270 bm.Canvas.Pen.Style := psSolid;
271 end;
272
273 procedure DoRectangle(fr, fg, fb, dr, dg, db: Integer);
274 var
275 I: Integer;
276 R, G, B: Byte;
277 Pw, Ph: Real;
278 x1, y1, x2, y2: Double;
279 begin
280 DebugLn('DoRectangle');
281
282 bm.Canvas.Pen.Style := psClear;
283 bm.Canvas.Pen.Mode := pmCopy;
284 x1 := 0;
285 x2 := bm.Width;
286 y1 := 0;
287 y2 := bm.Height;
288 Pw := (bm.Width / 2) / 255;
289 Ph := (bm.Height / 2) / 255;
290 for I := 0 to 255 do
291 begin //Make rectangles of color
292 x1 := x1 + Pw;
293 x2 := X2 - Pw;
294 y1 := y1 + Ph;
295 y2 := y2 - Ph;
296 R := fr + MulDiv(I, dr, 255); //Find the RGB values
297 G := fg + MulDiv(I, dg, 255);
298 B := fb + MulDiv(I, db, 255);
299 bm.Canvas.Brush.Color := RGB(R, G, B); //Plug colors into brush
300 bm.Canvas.FillRect(Rect(Trunc(x1), Trunc(y1), Trunc(x2), Trunc(y2)));
301 end;
302 bm.Canvas.Pen.Style := psSolid;
303 end;
304
305 procedure DoVertCenter(fr, fg, fb, dr, dg, db: Integer);
306 var
307 ColorRect: TRect;
308 I: Integer;
309 R, G, B: Byte;
310 Haf: Integer;
311 begin
312 DebugLn('DoVertCenter');
313
314 Haf := bm.Height Div 2;
315 ColorRect.Left := 0;
316 ColorRect.Right := bm.Width;
317 for I := 0 to Haf do
318 begin
319 ColorRect.Top := MulDiv(I, Haf, Haf);
320 ColorRect.Bottom := MulDiv(I + 1, Haf, Haf);
321 R := fr + MulDiv(I, dr, Haf);
322 G := fg + MulDiv(I, dg, Haf);
323 B := fb + MulDiv(I, db, Haf);
324 bm.Canvas.Brush.Color := RGB(R, G, B);
325 bm.Canvas.FillRect(ColorRect);
326 ColorRect.Top := bm.Height - (MulDiv (I, Haf, Haf));
327 ColorRect.Bottom := bm.Height - (MulDiv (I + 1, Haf, Haf));
328 bm.Canvas.FillRect(ColorRect);
329 end;
330 end;
331
332 procedure DoHorizCenter(fr, fg, fb, dr, dg, db: Integer);
333 var
334 ColorRect: TRect;
335 I: Integer;
336 R, G, B: Byte;
337 Haf: Integer;
338 begin
339 DebugLn('DoHorizCenter');
340
341 Haf := bm.Width Div 2;
342 ColorRect.Top := 0;
343 ColorRect.Bottom := bm.Height;
344 for I := 0 to Haf do
345 begin
346 ColorRect.Left := MulDiv(I, Haf, Haf);
347 ColorRect.Right := MulDiv(I + 1, Haf, Haf);
348 R := fr + MulDiv(I, dr, Haf);
349 G := fg + MulDiv(I, dg, Haf);
350 B := fb + MulDiv(I, db, Haf);
351 bm.Canvas.Brush.Color := RGB(R, G, B);
352 bm.Canvas.FillRect(ColorRect);
353 ColorRect.Left := bm.Width - (MulDiv (I, Haf, Haf));
354 ColorRect.Right := bm.Width - (MulDiv (I + 1, Haf, Haf));
355 bm.Canvas.FillRect(ColorRect);
356 end;
357 end;
358
359 begin
360 DebugLn('PaintGrad');
361 try
362 bm := TBitMap.Create;
363 if Cv = nil then Exit;
364 bm.Width := X1 - X; //Set BMP dimensions to match control's
365 bm.Height :=Y1 - Y;
366 FromR := FBeginClr and $000000ff; //Strip out separate RGB values
367 FromG := (FBeginClr shr 8) and $000000ff;
368 FromB := (FBeginClr shr 16) and $000000ff;
369 DiffR := (FEndClr and $000000ff) - FromR; //Find the difference
370 DiffG := ((FEndClr shr 8) and $000000ff) - FromG;
371 DiffB := ((FEndClr shr 16) and $000000ff) - FromB;
372 //Depending on gradient style selected, go draw it on the Bitmap canvas.
373 if FGradientStyle = gsHorizontal then
374 DoHorizontal(FromR, FromG, FromB, DiffR, DiffG, DiffB);
375 if FGradientStyle = gsVertical then
376 DoVertical(FromR, FromG, FromB, DiffR, DiffG, DiffB);
377 if FGradientStyle = gsElliptic then
378 DoElliptic(FromR, FromG, FromB, DiffR, DiffG, DiffB);
379 if FGradientStyle = gsRectangle then
380 DoRectangle(FromR, FromG, FromB, DiffR, DiffG, DiffB);
381 if FGradientStyle = gsVertCenter then
382 DoVertCenter(FromR, FromG, FromB, DiffR, DiffG, DiffB);
383 if FGradientStyle = gsHorizCenter then
384 DoHorizCenter(FromR, FromG, FromB, DiffR, DiffG, DiffB);
385 //By setting the Brush style to Clear, it will draw without overlaying bkgrnd
386 bm.Canvas.Brush.Style := bsClear; //Gradient is done, time for Hilite-Shadow
387 {Finally, the button is all painted on the bitmap canvas. Now we just need
388 to copy it to the canvas of our control. BitBlt is one method; there are
389 several others.}
390 BitBlt(Cv.Handle, X, Y, bm.Width, bm.Height, bm.Canvas.Handle, 0, 0, SRCCOPY);
391 finally
392 bm.Free;
393 end;
394 end;
395
396 procedure MixedRoundRect(Canvas:TCanvas; X1, Y1, X2, Y2: integer; RX, RY: integer;
397 SqrCorners: TCornerSet);
398 var
399 Pts: PPoint;
400 c: Integer;
401 Mx,My: Integer;
402
403 procedure Corner(Ax,Ay,Bx,By,Cx,Cy:Integer);
404 begin
405 ReallocMem(Pts, SizeOf(TPoint)*(c+3));
406 Pts[c].x:=ax; Pts[c].y:=ay; inc(c);
407 Pts[c].x:=bx; Pts[c].y:=by; inc(c);
408 Pts[c].x:=cx; Pts[c].y:=cy; inc(c);
409 end;
410
411 begin
412
413 X2 := X2-1;
414 Y2 := Y2-1;
415
416 // basic checks
417 if X1>X2 then
418 begin
419 c :=X2;
420 X2 := X1;
421 X1 := c;
422 end;
423 if Y1>Y2 then
424 begin
425 c := Y2;
426 Y2 := Y1;
427 Y1 := c;
428 end;
429 if RY>(Y2-Y1) then
430 RY:=(Y2-Y1);
431 if RX>(X2-X1) then
432 RX :=(X2-X1);
433
434 MX := RX div 2;
435 MY := RY div 2;
436
437 c := 0;
438 Pts := nil;
439 if ctTopLeft in SqrCorners then
440 Corner(X1+MX,Y1, X1,Y1, X1,Y1+MY)
441 else
442 BezierArcPoints(X1,Y1,RX,RY, 90*16, 90*16, 0, Pts, c);
443 if ctBottomLeft in SqrCorners then
444 Corner(X1,Y2-MY,X1,Y2,X1+MX,Y2)
445 else
446 BezierArcPoints(X1,Y2-RY,RX,RY, 180*16, 90*16, 0, Pts, c);
447 if ctBottomRight in SqrCorners then
448 Corner(X2-MX,Y2, X2,Y2, X2, Y2-MY)
449 else
450 BezierArcPoints(X2-RX,Y2-RY,RX,RY, 270*16, 90*16, 0, Pts, c);
451 if ctTopRight in SqrCorners then
452 Corner(X2,Y1+MY, X2,Y1, X2-MX,Y1)
453 else
454 BezierArcPoints(X2-RX,Y1,RX,RY, 0, 90*16, 0, Pts, c);
455
456 Canvas.Polygon(Pts, c);
457 ReallocMem(Pts, 0);
458 end;
459
GetRoundRectnull460 function TfrRoundRectView.GetRoundRect: boolean;
461 begin
462 Result:=fCadre.sCurve;
463 end;
464
GetGradStylenull465 function TfrRoundRectView.GetGradStyle: TGradientStyle;
466 begin
467 Result:=fCadre.GradStyle;
468 end;
469
GetRoundRectCurvenull470 function TfrRoundRectView.GetRoundRectCurve: Integer;
471 begin
472 Result:=fCadre.wCurve;
473 end;
474
GetShadowColornull475 function TfrRoundRectView.GetShadowColor: TColor;
476 begin
477 Result:=fCadre.SdColor;
478 end;
479
GetShadowWidthnull480 function TfrRoundRectView.GetShadowWidth: Integer;
481 begin
482 Result:=fCadre.wShadow;
483 end;
484
GetShowGradnull485 function TfrRoundRectView.GetShowGrad: Boolean;
486 begin
487 Result:=fCadre.SGradian;
488 end;
489
490 procedure TfrRoundRectView.SetCorners(AValue: TCornerSet);
491 begin
492 BeforeChange;
493 fCadre.Corners := Avalue;
494 AfterChange;
495 end;
496
497 procedure TfrRoundRectView.SetGradStyle(const AValue: TGradientStyle);
498 begin
499 BeforeChange;
500 fCadre.GradStyle:=aValue;
501 AfterChange;
502 end;
503
504 procedure TfrRoundRectView.SetRoundRect(const AValue: boolean);
505 begin
506 BeforeChange;
507 fCadre.sCurve:=aValue;
508 AfterChange;
509 end;
510
511 procedure TfrRoundRectView.SetRoundRectCurve(const AValue: Integer);
512 begin
513 BeforeChange;
514 fCadre.wCurve:=aValue;
515 AfterChange;
516 end;
517
518 procedure TfrRoundRectView.SetShadowColor(const AValue: TColor);
519 begin
520 BeforeChange;
521 fCadre.SdColor:=aValue;
522 AfterChange;
523 end;
524
525 procedure TfrRoundRectView.SetShadowWidth(const AValue: Integer);
526 begin
527 BeforeChange;
528 fCadre.wShadow:=aValue;
529 AfterChange;
530 end;
531
532 procedure TfrRoundRectView.SetShowGrad(const AValue: Boolean);
533 begin
534 BeforeChange;
535 fCadre.SGradian:=aValue;
536 AfterChange;
537 end;
538
GetCornersnull539 function TfrRoundRectView.GetCorners: TCornerSet;
540 begin
541 result := fCadre.Corners;
542 end;
543
544 (********************************************************)
545 constructor TfrRoundRectView.Create(AOwnerPage: TfrPage);
546 begin
547 inherited Create(AOwnerPage);
548 BeginUpdate;
549 try
550 //Initialization
551 Typ := gtAddIn;
552 Frames := frAllFrames;
553 BaseName := 'RoundRect';
554
555 //Default values
556 fCadre.SGradian:=False;
557 fCadre.GradStyle:=gsHorizontal;
558 fCadre.SdColor := clGray;
559 fCadre.wShadow := 6;
560 fCadre.sCurve := True;
561 fCadre.wCurve := 10;
562 fCadre.Corners := [];
563 finally
564 Endupdate;
565 end;
566 end;
567
568 procedure TfrRoundRectView.Assign(Source: TPersistent);
569 begin
570 inherited Assign(Source);
571
572 if Source is TfrRoundRectView then
573 fCadre := TfrRoundRectView(Source).fCadre
574 else
575 begin
576 fCadre.wCurve:=10;
577 fCadre.sCurve:=true;
578 fCadre.SGradian:=false;
579 fCadre.wShadow:=0;
580 fCadre.Corners:=[ctTopLeft,ctBottomLeft,ctBottomRight,ctTopRight];
581 end;
582 end;
583
584 procedure TfrRoundRectView.LoadFromStream(Stream: TStream);
585 begin
586 inherited LoadFromStream(Stream);
587 Stream.Read(fCadre, SizeOf(fCadre));
588 end;
589
590 procedure TfrRoundRectView.SaveToStream(Stream: TStream);
591 begin
592 inherited SaveToStream(Stream);
593 Stream.Write(fCadre, SizeOf(fCadre));
594 end;
595
596 procedure TfrRoundRectView.LoadFromXML(XML: TLrXMLConfig; const Path: String);
597 begin
598 inherited LoadFromXML(XML, Path);
599
600 RestoreProperty('GradianStyle',XML.GetValue(Path+'Data/GradianStyle/Value',''));
601 RestoreProperty('ShowGradian',XML.GetValue(Path+'Data/ShowGradian/Value',''));
602 RestoreProperty('ShadowColor',XML.GetValue(Path+'Data/ShadowColor/Value',''));
603 RestoreProperty('ShadowWidth',XML.GetValue(Path+'Data/ShadowWidth/Value',''));
604 RestoreProperty('RoundRect',XML.GetValue(Path+'Data/RoundRect/Value',''));
605 RestoreProperty('RoundRectCurve',XML.GetValue(Path+'Data/RoundRectCurve/Value',''));
606 RestoreProperty('SquaredCorners',XML.GetValue(Path+'Data/SquaredCorners/Value',''));
607 end;
608
609 procedure TfrRoundRectView.SaveToXML(XML: TLrXMLConfig; const Path: String);
610 begin
611 inherited SaveToXML(XML, Path);
612
613 XML.SetValue(Path+'Data/ShowGradian/Value', GetSaveProperty('ShowGradian'));
614 XML.SetValue(Path+'Data/GradianStyle/Value', GetSaveProperty('GradianStyle'));
615 XML.SetValue(Path+'Data/ShadowColor/Value', GetSaveProperty('ShadowColor'));
616 XML.SetValue(Path+'Data/ShadowWidth/Value', GetSaveProperty('ShadowWidth'));
617 XML.SetValue(Path+'Data/RoundRect/Value', GetSaveProperty('RoundRect'));
618 XML.SetValue(Path+'Data/RoundRectCurve/Value', GetSaveProperty('RoundRectCurve'));
619 XML.SetValue(Path+'Data/SquaredCorners/Value', GetSaveProperty('SquaredCorners'));
620 end;
621
622 procedure TfrRoundRectView.ShowBackGround;
623 var
624 OldDRect: TRect;
625 OldFill: TColor;
626 begin
627 // prevent screen garbage in designer
628 if (DocMode <> dmDesigning) or fCadre.SGradian then Exit;
629 BeginUpdate;
630 try
631 OldDRect := DRect;
632 OldFill := FillColor;
633 DRect := Rect(x, y, x + dx + 1, y + dy + 1);
634 FillColor := clWhite;
635 inherited;
636 DRect := OldDRect;
637 FillColor := OldFill;
638 Finally
639 EndUpdate;
640 end;
641 end;
642
643 procedure TfrRoundRectView.ShowFrame;
644 var
645 FSW, FCU: Integer;
646
647 procedure Line(x, y, dx, dy: Integer);
648 begin
649 Canvas.MoveTo(x, y);
650 Canvas.LineTo(x + dx, y + dy);
651 end;
652
653 procedure FrameLine(i: Integer);
654 begin
655 Canvas.Pen.Width := Round(FrameWidth);
656 case i of
657 0: Line(x + dx, y, 0, dy);
658 1: Line(x, y, 0, dy);
659 2: Line(x, y + dy, dx, 0);
660 3: Line(x, y, dx, 0);
661 end;
662 end;
663
664 begin
665 if DisableDrawing then Exit;
666 with Canvas do
667 begin
668 if fCadre.SGradian then
669 begin
670 if fCadre.wCurve < 0 then
671 fCadre.wCurve := 0;
672 PaintGrad(Canvas, X, Y, X + DX, Y + DY, FillColor, fCadre.SdColor,fCadre.GradStyle);
673 Pen.Width := Round(FrameWidth);
674 Pen.Color := FrameColor;
675
676 //(frbLeft, frbTop, frbRight, frbBottom)
677 if (frbRight in Frames) then FrameLine(0);
678 if (frbLeft in Frames) then FrameLine(1);
679 if (frbBottom in Frames) then FrameLine(2);
680 if (frbTop in Frames) then FrameLine(3);
681
682 Exit;
683 end;
684
685 // Trace l'ombre
686 Pen.Style := psSolid;
687 if FillColor=clNone then
688 Brush.Style := bsClear
689 else
690 Brush.Style := bsSolid;
691 Pen.Color := fCadre.SdColor;
692 Pen.Width := Round(FrameWidth);
693 Brush.Color := fCadre.SdColor;
694
695 FSW := Round(fCadre.wShadow * ScaleY);
696 FCU := Round(fCadre.wCurve * ScaleY);
697
698 if fCadre.sCurve then
699 begin
700 MixedRoundRect(Canvas, x + FSW, y + FSW, x + dx + 1, y + dy + 1, FCu, Fcu, GetCorners);
701 end
702 else
703 Rectangle(x + FSW, y + FSW, x + dx + 1, y + dy + 1);
704
705 // Trace la zone de texte
706 Pen.Width := Round(FrameWidth);
707
708 if (Frames=[]) then
709 Pen.Color := FillColor
710 else
711 Pen.Color := FrameColor; // Trace le cadre
712
713 Brush.Color := FillColor;
714 if fCadre.sCurve then
715 begin
716 MixedRoundRect(Canvas, x, y, x + dx + 1 - FSW, y + dy + 1 - FSW, FCu, Fcu, GetCorners);
717 end
718 else
719 Rectangle(x, y, x + dx + 1 - FSW, y + dy + 1 - FSW);
720
721 Brush.Style := bsSolid;
722 end;
723 end;
724
725
726 (****************************************************)
727 procedure TfrRoundRectForm.FormCreate(Sender: TObject);
728 var
729 i: Integer;
730 s: String;
731 begin
732 if sender=nil then ;
733 Caption := sRoundRectFormCaption;
734 LblSample.Caption := sRoundRectFormSample;
735 Button5.Caption := sRoundRectFormVar;
736 Button6.Caption := sRoundRectFormData;
737 cbGradian.Caption := sRoundRectFormGradient;
738 lblSWidth.Caption := sRoundRectFormShadow;
739 LblSColor.Caption := sRoundRectFormColor;
740 cmShadow.Caption := sRoundRectFormCurve;
741 cbCadre.Caption := sRoundRectFormFramed;
742 Label1.Caption := sRoundRectFormEndColor;
743 Label2.Caption := sRoundRectFormBeginColor;
744 Label3.Caption := sRoundRectFormStyle;
745 bColor.Hint := sRoundRectFormHint;
746 bColor2.Hint := bColor.Hint;
747 bColor3.Hint := bColor3.Hint;
748 BOk.Caption := sOk;
749 bCancel.Caption := sCancel;
750 lblSqrCorners.Caption := sRoundRectSqrCorners;
751
752 cbStyle.Items.CommaText := sRoundRectFormStyleDif;
753 for i := 0 to cbStyle.Items.Count - 1 do
754 begin
755 s := cbStyle.Items.Strings[i];
756 if Pos('_', s) <> 0 then
757 begin
758 s[Pos('_', s)] := ' ';
759 cbStyle.Items.Strings[i] := s;
760 end;
761 end;
762
763 panGrad.Left := panCurve.Left;
764 panGrad.Top := panCurve.Top;
765 panGrad.Visible := False;
766 end;
767
768 procedure TfrRoundRectForm.Button5Click(Sender: TObject);
769 begin
770 if sender=nil then ;
771 frVarForm := TfrVarForm.Create(nil);
772 with frVarForm do
773 if ShowModal = mrOk then
774 begin
775 ClipBoard.Clear;
776 if SelectedItem <> '' then
777 Begin
778 ClipBoard.Clear;
779 ClipBoard.AsText := '[' + SelectedItem + ']';
780 M1.PasteFromClipboard;
781 end;
782 end;
783 frVarForm.Free;
784 M1.SetFocus;
785 end;
786
787 procedure TfrRoundRectForm.Button6Click(Sender: TObject);
788 begin
789 if sender=nil then ;
790 frFieldsForm := TfrFieldsForm.Create(nil);
791 with frFieldsForm do
792 if ShowModal = mrOk then
793 if DBField <> '' then
794 begin
795 ClipBoard.Clear;
796 ClipBoard.AsText := '[' + DBField + ']';
797 M1.PasteFromClipboard;
798 end;
799 frFieldsForm.Free;
800 M1.SetFocus;
801 end;
802
803 procedure TfrRoundRectForm.ChgColorButton(S: TObject; C: TColor);
804 var
805 BM: TBitmap;
806 Bc: TImage;
807 begin
808 BM := TBitmap.Create;
809 Bc := S as TImage;
810 BM.Height := bC.Height;
811 BM.Width := bC.Width;
812
813 with BM.Canvas do
814 begin
815 Pen.Color := clBlack;
816 Brush.Color := C;
817 Rectangle(0, 0, bC.Width, bC.Height);
818 end;
819
820 if Bc.Tag = 0 then
821 fShadowColor := C
822 else
823 fNormalColor := C;
824
825 bC.Picture.Assign(BM);
826 BM.Free;
827 end;
828
829 procedure TfrRoundRectForm.SetCorners(AValue: TCornerSet);
830 begin
831 chkTL.Checked := ctTopLeft in AValue;
832 chkBL.Checked := ctBottomLeft in AValue;
833 chkBR.Checked := ctBottomRight in AValue;
834 chkTR.Checked := ctTopRight in AValue;
835 end;
836
837 procedure TfrRoundRectForm.UpdateSample;
838 var
839 CC: TCanvas;
840 FsW: Integer;
841 FCu: Integer;
842 BM: TBitmap;
843 begin
844 try
845 FsW := StrToInt(ShWidth.Text);
846 except
847 FsW := 10;
848 end;
849
850 try
851 FCu := StrToInt(SCurve.Text);
852 except
853 FCu := 10;
854 end;
855
856 BM := TBitmap.Create;
857 BM.Height := imgSample.Height;
858 BM.Width := imgSample.Width;
859
860 CC := BM.Canvas;
861
862 if cbGradian.Checked then
863 begin
864 FsW := cbStyle.ItemIndex;
865 if FsW < 0 then FsW:=0;
866 PaintGrad(CC, 0, 0, bm.Width, bm.Height, fNormalColor, fShadowColor,
867 TGradientStyle(FsW));
868 end
869 else
870 begin
871 // R�initialise le panel
872 CC.Pen.Color := clBtnFace;
873 CC.Brush.Color := clBtnFace;
874 CC.Rectangle(0, 0, imgSample.Width, imgSample.Height);
875
876 // Trace l'ombre
877 CC.Pen.Color := fShadowColor;
878 CC.Brush.Color := fShadowColor;
879
880 if cmShadow.Checked then
881 MixedRoundRect(CC,0 + FSW, 0 + FSW, imgSample.Width, imgSample.Height,
882 FCu, FCu, GetCorners)
883 else
884 CC.Rectangle(0 + FSW, 0 + FSW, imgSample.Width, imgSample.Height);
885
886 // Trace la zone de texte
887 if not cbCadre.Checked then
888 CC.Pen.Color := fNormalColor
889 else
890 CC.Pen.Color := clBlack; // Trace le cadre
891
892 CC.Brush.Color := fNormalColor;
893 if cmShadow.Checked then
894 MixedRoundRect(CC,0, 0, imgSample.Width - FSW, imgSample.Height - FSW,
895 FCu, FCu, GetCorners)
896 else
897 CC.Rectangle(0, 0, imgSample.Width - FSW, imgSample.Height - FSW);
898 end;
899
900 imgSample.Picture.Assign(BM);
901 BM.Free;
902 end;
903
GetCornersnull904 function TfrRoundRectForm.GetCorners: TCornerSet;
905 begin
906 result := [];
907 if chkTL.Checked then Include(result, ctTopLeft);
908 if chkBL.Checked then Include(result, ctBottomLeft);
909 if chkBR.Checked then Include(result, ctBottomRight);
910 if chkTR.Checked then Include(result, ctTopRight);
911 end;
912
913 procedure TfrRoundRectForm.bColorClick(Sender: TObject);
914 begin
915 if sender=nil then ;
916 ColorDlg.Color := fShadowColor;
917 if ColorDlg.Execute then
918 begin
919 ChgColorButton(Sender, ColorDlg.Color);
920 UpdateSample;
921 end;
922 end;
923
924 procedure TfrRoundRectForm.chkTLClick(Sender: TObject);
925 begin
926 //
927 UpdateSample;
928 end;
929
930 procedure TfrRoundRectForm.ShWidthChange(Sender: TObject);
931 begin
932 if Sender is TEdit then
933 if TEdit(Sender).Text = '' then Exit;
934 UpdateSample;
935 end;
936
937 procedure TfrRoundRectForm.cbCadreClick(Sender: TObject);
938 begin
939 if sender=nil then ;
940 UpdateSample;
941 end;
942
943 procedure TfrRoundRectForm.cbGradianChange(Sender: TObject);
944 begin
945 if sender=nil then ;
946 end;
947
948 procedure TfrRoundRectForm.cmShadowClick(Sender: TObject);
949 begin
950 if sender=nil then ;
951 UpdateSample;
952 end;
953
954 procedure TfrRoundRectForm.cbGradianClick(Sender: TObject);
955 begin
956 if sender=nil then ;
957 panGrad.Visible := cbGradian.Checked;
958 panCurve.Visible := not panGrad.Visible;
959 if panGrad.Visible then
960 begin
961 sCurve.Text := '0';
962 cbStyle.ItemIndex := 0;
963 end
964 else
965 sCurve.Text := '10';
966 end;
967
968 procedure TfrRoundRectForm.M1KeyDown(Sender: TObject; var Key: Word;
969 Shift: TShiftState);
970 begin
971 if sender=nil then ;
972 if (Key = vk_Insert) and (Shift = []) then Button5Click(Self);
973 if Key = vk_Escape then ModalResult := mrCancel;
974 end;
975
976 procedure TfrRoundRectForm.FormKeyDown(Sender: TObject; var Key: Word;
977 Shift: TShiftState);
978 begin
979 if sender=nil then ;
980 if (Key = vk_Return) and (ssCtrl in Shift) then
981 begin
982 ModalResult := mrOk;
983 Key := 0;
984 end;
985 end;
986
987 procedure TfrRoundRectForm.ShowEditor(t:TfrView);
988 begin
989 M1.Lines.Assign(t.Memo);
990 with t as TfrRoundRectView do
991 begin
992 shWidth.Text := IntToStr(fCadre.wShadow);
993 if not fCadre.SGradian then
994 begin // RoundRect
995 cbGradian.Checked := False;
996 fShadowColor := fCadre.sdColor;
997 fNormalColor := FillColor;
998 cbCadre.Checked := (t.Frames<>[]);
999 cmShadow.Checked := fCadre.sCurve;
1000 sCurve.Text := IntToStr(fCadre.wCurve);
1001 Corners := fCadre.Corners;
1002 end
1003 else
1004 begin //Gradian
1005 cbGradian.Checked := True;
1006 fShadowColor := fCadre.sdColor;
1007 fNormalColor := FillColor;
1008 if fCadre.wCurve > cbStyle.Items.Count - 1 then
1009 fCadre.wCurve := 0;
1010 cbStyle.ItemIndex :=Ord(fCadre.GradStyle);
1011 end;
1012
1013 if ShowModal = mrOk then
1014 begin
1015 Memo.Assign(M1.Lines);
1016 fCadre.sdColor := fShadowColor;
1017 FillColor := fNormalColor;
1018 fCadre.sCurve := cmShadow.Checked;
1019 if cbCadre.Checked then
1020 Frames:=frAllFrames
1021 else
1022 Frames:=[];
1023 try
1024 fCadre.wShadow := StrToInt(shWidth.Text);
1025 except
1026 fCadre.wShadow := 6;
1027 end;
1028
1029 fCadre.Corners := Corners;
1030
1031 fCadre.SGradian:=cbGradian.checked;
1032
1033 try
1034 fCadre.wCurve := StrToInt(sCurve.Text);
1035 if fCadre.SGradian then
1036 fCadre.GradStyle:=TGradientStyle(cbStyle.ItemIndex);
1037 except
1038 fCadre.wCurve := 10;
1039 end;
1040 end;
1041 end;
1042 end;
1043
1044 procedure TfrRoundRectForm.FormShow(Sender: TObject);
1045 begin
1046 if sender=nil then ;
1047 M1.SetFocus;
1048 UpdateSample;
1049 ChgColorButton(bColor, fShadowColor);
1050 ChgColorButton(bColor2, fNormalColor);
1051 ChgColorButton(bColor3, fShadowColor);
1052 end;
1053
1054
1055 { TfrRoundRectObject }
1056
1057 constructor TfrRoundRectObject.Create(aOwner: TComponent);
1058 begin
1059 inherited Create(aOwner);
1060
1061 if not assigned(frRoundRectForm) {and not (csDesigning in ComponentState)} then
1062 begin
1063 frRoundRectForm := TfrRoundRectForm.Create(nil);
1064 frRegisterObject(TfrRoundRectView, frRoundRectForm.Image1.Picture.Bitmap,
1065 sInsRoundRect, frRoundRectForm);
1066 end;
1067 end;
1068
1069 initialization
1070
1071 frRoundRectForm:=nil;
1072
1073 finalization
1074
1075 if Assigned(frRoundRectForm) then
1076 frRoundRectForm.Free;
1077
1078 end.
1079
1080