1 // SPDX-License-Identifier: GPL-3.0-only
2 unit LCVectorialFillInterface;
3 
4 {$mode objfpc}{$H+}
5 
6 interface
7 
8 uses
9   Classes, SysUtils, Types,
10   Controls, ComCtrls, Menus, Dialogs, ExtDlgs, ExtCtrls,
11   BGRAImageList, BCTrackbarUpdown,
12   BGRABitmap, BGRABitmapTypes, LCVectorialFill, LCVectorOriginal,
13   BGRAGradientScanner, Graphics, BGRAGraphics;
14 
GradRepetitionToStrnull15 function GradRepetitionToStr(AValue: TBGRAGradientRepetition): string;
ColorInterpToStrnull16 function ColorInterpToStr(AValue: TBGRAColorInterpolation): string;
TextureRepetitionToStrnull17 function TextureRepetitionToStr(AValue: TTextureRepetition): string;
18 
19 type
20   TLCFillTarget = (ftPen, ftBack, ftOutline);
21   TChooseColorEvent = procedure(ASender: TObject; AButton: TMouseButton; AColorIndex: integer;
22     var AColorValue: TBGRAPixel; out AHandled: boolean) of object;
23 
24   { TVectorialFillInterface }
25 
26   TVectorialFillInterface = class(TComponent)
27   private
28     FCanEditGradTexPoints: boolean;
29     FIsTarget: boolean;
30     FOnMouseDown: TMouseEvent;
31     FOnMouseEnter: TNotifyEvent;
32     FOnMouseLeave: TNotifyEvent;
33     FOnMouseMove: TMouseMoveEvent;
34     FOnMouseUp: TMouseEvent;
35     procedure EditGradTextPointsClick(Sender: TObject);
GetEditingGradTexPointsnull36     function GetEditingGradTexPoints: boolean;
37     procedure Preview_MouseUp(Sender: TObject; Button: TMouseButton;
38       {%H-}Shift: TShiftState; X, {%H-}Y: Integer);
39     procedure SetCanEditGradTexPoints(AValue: boolean);
40     procedure SetEditingGradTexPoints(AValue: boolean);
41     procedure SetIsTarget(AValue: boolean);
42     procedure SetVerticalPadding(AValue: integer);
43     procedure ToolbarMouseDown(Sender: TObject; Button: TMouseButton;
44       Shift: TShiftState; X, Y: Integer);
45     procedure ToolbarMouseEnter(Sender: TObject);
46     procedure ToolbarMouseLeave(Sender: TObject);
47     procedure ToolbarMouseMove(Sender: TObject; Shift: TShiftState; X,
48       Y: Integer);
49     procedure ToolbarMouseUp(Sender: TObject; Button: TMouseButton;
50       Shift: TShiftState; X, Y: Integer);
51     procedure AnyButtonMouseDown(Sender: TObject; Button: TMouseButton;
52       Shift: TShiftState; X, Y: Integer);
53     procedure AnyButtonMouseEnter(Sender: TObject);
54     procedure AnyButtonMouseLeave(Sender: TObject);
55     procedure AnyButtonMouseMove(Sender: TObject; Shift: TShiftState; X,
56       Y: Integer);
57     procedure AnyButtonMouseUp(Sender: TObject; Button: TMouseButton;
58       Shift: TShiftState; X, Y: Integer);
59   protected
60     FFillType: TVectorialFillType;
61     FAllowedFillTypes: TVectorialFillTypes;
62     FSolidColor: TBGRAPixel;
63     FOnChooseColor: TChooseColorEvent;
64 
65     FGradStartColor, FGradEndColor: TBGRAPixel;
66     FGradType: TGradientType;
67     FGradRepetition: TBGRAGradientRepetition;
68     FGradInterp: TBGRAColorInterpolation;
69 
70     FTexRepetition: TTextureRepetition;
71     FTexture: TBGRABitmap;
72     FTexOpacity: byte;
73     FTextureAverageColor: TBGRAPixel;
74     FTextureAverageColorComputed: boolean;
75 
76     //interface
77     FContainer: TWinControl;
78     FVerticalPadding: integer;
79 
80     FPreview: TImage;
81     FButtonFillNone, FButtonFillSolid,
82     FButtonFillGradient, FButtonFillTexture: TToolButton;
83     FOnFillChange, FOnFillTypeChange: TNotifyEvent;
84     FButtonEditGradTexPoints, FButtonAdjustToShape: TToolButton;
85     FOnEditGradTexPoints, FOnAdjustToShape: TNotifyEvent;
86 
87     FSolidColorInterfaceCreated: boolean;
88     FShapeSolidColor: TShape;
89     FUpDownSolidAlpha: TBCTrackbarUpdown;
90     FSolidColorChange: TNotifyEvent;
91 
92     FTextureInterfaceCreated: boolean;
93     FCanAdjustToShape: boolean;
94     FButtonTexRepeat, FButtonLoadTexture: TToolButton;
95     FUpDownTexAlpha: TBCTrackbarUpdown;
96     FOnTextureClick: TNotifyEvent;
97     FOnTextureChange: TNotifyEvent;
98 
99     FGradientInterfaceCreated: boolean;
100     //FShapeStartColor, FShapeEndColor: TShape;
101     FUpDownStartAlpha, FUpDownEndAlpha: TBCTrackbarUpdown;
102     FButtonSwapColor, FButtonGradRepetition, FButtonGradInterp: TToolButton;
103     FGradTypeMenu, FGradRepetitionMenu, FGradInterpMenu: TPopupMenu;
104 
105     FColorDlg: TColorDialog;
106     FOpenPictureDlg: TOpenPictureDialog;
107     FTexRepetitionMenu: TPopupMenu;
108 
109     FToolbar: TToolBar;
110     FImageList: TBGRAImageList;
111     FImageListLoaded: boolean;
112     FImageListSize: TSize;
113 
114     procedure AdjustToShapeClick(Sender: TObject);
115     procedure ButtonFillChange(Sender: TObject);
116     procedure ButtonFillGradClick(Sender: TObject);
117     procedure ButtonFillTexClick(Sender: TObject);
118     procedure ButtonGradInterpClick(Sender: TObject);
119     procedure ButtonGradRepetitionClick(Sender: TObject);
120     procedure ButtonLoadTextureClick(Sender: TObject);
121     procedure ButtonSwapColorClick(Sender: TObject);
122     procedure ButtonTexRepeatClick(Sender: TObject);
123     procedure Changed(AUpdatePreview: boolean = True);
124     procedure OnClickBackGradType(ASender: TObject);
125     procedure OnClickBackTexRepeat(ASender: TObject);
126     procedure OnClickGradInterp(ASender: TObject);
127     procedure OnClickGradRepeat(ASender: TObject);
GetPreferredSizenull128     function GetPreferredSize: TSize;
GetAverageColornull129     function GetAverageColor: TBGRAPixel;
130     procedure SetCanAdjustToShape(AValue: boolean);
131     procedure SetContainer(AValue: TWinControl);
132     procedure SetFillType(AValue: TVectorialFillType);
133     procedure SetAllowedFillTypes(AValue: TVectorialFillTypes);
134     procedure SetSolidColor(AValue: TBGRAPixel);
135     procedure SetGradientType(AValue: TGradientType);
136     procedure SetGradEndColor(AValue: TBGRAPixel);
137     procedure SetGradStartColor(AValue: TBGRAPixel);
138     procedure SetGradRepetition(AValue: TBGRAGradientRepetition);
139     procedure SetGradInterpolation(AValue: TBGRAColorInterpolation);
140     procedure SetImageListSize(AValue: TSize);
141     procedure SetTexture(AValue: TBGRABitmap);
142     procedure SetTextureRepetition(AValue: TTextureRepetition);
143     procedure SetTextureOpacity(AValue: byte);
144     procedure SetOnTextureClick(AValue: TNotifyEvent);
145 //    procedure ShapeEndColorMouseUp({%H-}Sender: TObject; {%H-}Button: TMouseButton;
146 //      {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
147     procedure ShapeSolidColorMouseUp({%H-}Sender: TObject; {%H-}Button: TMouseButton;
148       {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
149 //    procedure ShapeStartColorMouseUp({%H-}Sender: TObject; {%H-}Button: TMouseButton;
150 //      {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
151     procedure UpdateAccordingToFillType;
152     procedure UpdateTopToolbar;
153     procedure UpdatePreview;
154     procedure UpdateShapeSolidColor;
155     procedure UpdateTextureParams;
156     procedure UpdateGradientParams;
157     procedure UpdateButtonAdjustToShape;
158     procedure UpDownEndAlphaChange(Sender: TObject; AByUser: boolean);
159     procedure UpDownSolidAlphaChange(Sender: TObject; AByUser: boolean);
160     procedure UpDownStartAlphaChange(Sender: TObject; AByUser: boolean);
161     procedure UpDownTexAlphaChange(Sender: TObject; AByUser: boolean);
162     procedure ChooseColor(AColorIndex: integer; AButton: TMouseButton);
163     procedure CreateSolidColorInterface;
164     procedure CreateGradientInterface;
165     procedure CreateTextureInterface;
166     procedure HideSolidColorInterface;
167     procedure HideGradientInterface;
168     procedure HideTextureInterface;
169     procedure Init(AImageListWidth,AImageListHeight: Integer);
170     procedure AttachMouseEvent(AControl: TToolBar); overload;
171     procedure AttachMouseEvent(AControl: TToolButton); overload;
172     procedure AttachMouseEvent(AControl: TBCTrackbarUpdown); overload;
173     procedure AttachMouseEvent(AControl: TImage); overload;
174   public
175     constructor Create(AOwner: TComponent); override;
176     constructor Create(AOwner: TComponent; AImageListWidth,AImageListHeight: Integer);
177     destructor Destroy; override;
178     procedure LoadTexture;
179     procedure LoadImageList;
180     procedure ContainerSizeChanged;
GetTextureThumbnailnull181     function GetTextureThumbnail(AWidth, AHeight: integer; ABackColor: TColor): TBitmap;
182     procedure AssignFill(AFill: TVectorialFill);
183     procedure UpdateFillExceptGeometry(ATargetFill: TVectorialFill);
CreateShapeFillnull184     function CreateShapeFill(AShape: TVectorShape): TVectorialFill;
185     procedure UpdateShapeFill(AShape: TVectorShape; ATarget: TLCFillTarget);
186     property FillType: TVectorialFillType read FFillType write SetFillType;
187     property IsTarget: boolean read FIsTarget write SetIsTarget;
188     property SolidColor: TBGRAPixel read FSolidColor write SetSolidColor;
189     property AverageColor: TBGRAPixel read GetAverageColor;
190     property GradientType: TGradientType read FGradType write SetGradientType;
191     property GradStartColor: TBGRAPixel read FGradStartColor write SetGradStartColor;
192     property GradEndColor: TBGRAPixel read FGradEndColor write SetGradEndColor;
193     property GradRepetition: TBGRAGradientRepetition read FGradRepetition write SetGradRepetition;
194     property GradInterpolation: TBGRAColorInterpolation read FGradInterp write SetGradInterpolation;
195     property Texture: TBGRABitmap read FTexture write SetTexture;
196     property TextureRepetition: TTextureRepetition read FTexRepetition write SetTextureRepetition;
197     property TextureOpacity: byte read FTexOpacity write SetTextureOpacity;
198     property CanAdjustToShape: boolean read FCanAdjustToShape write SetCanAdjustToShape;
199     property CanEditGradTexPoints: boolean read FCanEditGradTexPoints write SetCanEditGradTexPoints;
200     property EditingGradTexPoints: boolean read GetEditingGradTexPoints write SetEditingGradTexPoints;
201     property OnFillChange: TNotifyEvent read FOnFillChange write FOnFillChange;
202     property OnTextureChange: TNotifyEvent read FOnTextureChange write FOnTextureChange;
203     property OnTextureClick: TNotifyEvent read FOnTextureClick write SetOnTextureClick;
204     property OnAdjustToShape: TNotifyEvent read FOnAdjustToShape write FOnAdjustToShape;
205     property OnEditGradTexPoints: TNotifyEvent read FOnEditGradTexPoints write FOnEditGradTexPoints;
206     property OnFillTypeChange: TNotifyEvent read FOnFillTypeChange write FOnFillTypeChange;
207     property OnChooseColor: TChooseColorEvent read FOnChooseColor write FOnChooseColor;
208     property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
209     property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
210     property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
211     property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
212     property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
213     property Container: TWinControl read FContainer write SetContainer;
214     property ImageListSize: TSize read FImageListSize write SetImageListSize;
215     property VerticalPadding: integer read FVerticalPadding write SetVerticalPadding;
216     property PreferredSize: TSize read GetPreferredSize;
217     property AllowedFillTypes: TVectorialFillTypes read FAllowedFillTypes write SetAllowedFillTypes;
218   end;
219 
220 implementation
221 
222 uses LCToolbars, BGRAThumbnail, LResources,
223   LCVectorShapes, BGRAGradientOriginal, BGRATransform, math,
224   LCResourceString;
225 
GradRepetitionToStrnull226 function GradRepetitionToStr(AValue: TBGRAGradientRepetition): string;
227 begin
228   case AValue of
229     grPad: result := rsGrPad;
230     grRepeat: result := rsGrRepeat;
231     grReflect: result := rsGrReflect;
232     grSine: result := rsGrSine;
233     else result := '';
234   end;
235 end;
236 
ColorInterpToStrnull237 function ColorInterpToStr(AValue: TBGRAColorInterpolation): string;
238 begin
239   case AValue of
240     ciStdRGB: result := rsCiStdRGB;
241     ciLinearRGB: result := rsCiLinearRGB;
242     ciLinearHSLPositive: result := rsCiLinearHSLPositive;
243     ciLinearHSLNegative: result := rsCiLinearHSLNegative;
244     ciGSBPositive: result := rsCiGSBPositive;
245     ciGSBNegative: result := rsCiGSBNegative;
246     else result := '';
247   end;
248 end;
249 
TextureRepetitionToStrnull250 function TextureRepetitionToStr(AValue: TTextureRepetition): string;
251 begin
252   case AValue of
253     trNone: result := rsTrNone;
254     trRepeatX: result := rsTrRepeatX;
255     trRepeatY: result := rsTrRepeatY;
256     trRepeatBoth: result := rsTrRepeatBoth;
257     else result := '';
258   end;
259 end;
260 
261 { TVectorialFillInterface }
262 
263 procedure TVectorialFillInterface.LoadImageList;
264 var
265   i: Integer;
266   lst: TStringList;
267 begin
268   if FImageList = nil then FImageList := TBGRAImageList.Create(self);
269   if FImageListLoaded and (FImageList.Width=FImageListSize.cx) and (FImageList.Height=FImageListSize.cy) then exit;
270   FImageList.Clear;
271   FImageList.Width := FImageListSize.cx;
272   FImageList.Height := FImageListSize.cy;
273   {$IFDEF DARWIN}
274   FImageList.Scaled := true;
275   FImageList.RegisterResolutions([FImageListSize.cx, FImageListSize.cx*2]);
276   {$ENDIF}
277 
278   lst := TStringList.Create;
279   lst.CommaText := GetResourceString('fillimages.lst');
280   for i := 0 to lst.Count-1 do
281     LoadToolbarImage(FImageList, i, lst[i]);
282   lst.Free;
283 
284   FImageListLoaded := true;
285   if Assigned(FToolbar) then
286   begin
287     SetToolbarImages(FToolbar, FImageList, 5, VerticalPadding);
288     for i := 0 to FToolbar.ControlCount-1 do
289       if FToolbar.Controls[i] is TBCTrackbarUpdown then
290         FToolbar.Controls[i].Width := FToolbar.ButtonWidth*2
291       else if FToolbar.Controls[i] is TShape then
292         FToolbar.Controls[i].Width := FToolbar.ButtonWidth;
293   end;
294 
295   UpdatePreview;
296 end;
297 
298 procedure TVectorialFillInterface.Changed(AUpdatePreview: boolean);
299 begin
300   if AUpdatePreview then UpdatePreview;
301   if Assigned(FOnFillChange) then
302     FOnFillChange(self);
303 end;
304 
305 procedure TVectorialFillInterface.OnClickBackGradType(ASender: TObject);
306 begin
307   GradientType:= TGradientType((ASender as TMenuItem).Tag);
308   FillType := vftGradient;
309 end;
310 
311 procedure TVectorialFillInterface.OnClickBackTexRepeat(ASender: TObject);
312 begin
313   TextureRepetition := TTextureRepetition((ASender as TMenuItem).Tag);
314 end;
315 
316 procedure TVectorialFillInterface.OnClickGradInterp(ASender: TObject);
317 begin
318   GradInterpolation:= TBGRAColorInterpolation((ASender as TMenuItem).Tag);
319 end;
320 
321 procedure TVectorialFillInterface.OnClickGradRepeat(ASender: TObject);
322 begin
323   GradRepetition:= TBGRAGradientRepetition((ASender as TMenuItem).Tag);
324 end;
325 
326 procedure TVectorialFillInterface.SetTexture(AValue: TBGRABitmap);
327 begin
328   if FTexture=AValue then Exit;
329 
330   if Assigned(FTexture) then
331   begin
332     FTexture.FreeReference;
333     FTexture := nil;
334   end;
335   if Assigned(AValue) then
336     FTexture := AValue.NewReference as TBGRABitmap;
337 
338   FTextureAverageColorComputed := false;
339   if Assigned(FOnTextureChange) then FOnTextureChange(self);
340   if FFillType = vftTexture then Changed;
341 end;
342 
343 procedure TVectorialFillInterface.LoadTexture;
344 var
345   newTex: TBGRABitmap;
346 begin
347   if FOpenPictureDlg.Execute then
348   begin
349     try
350       newTex := TBGRABitmap.Create(FOpenPictureDlg.FileName, true);
351       Texture := newTex;
352       newTex.FreeReference;
353       FillType:= vftTexture;
354     except
355       on ex: exception do
356         ShowMessage(ex.Message);
357     end;
358   end;
359 end;
360 
361 procedure TVectorialFillInterface.ContainerSizeChanged;
362 begin
363   FToolbar.Align:= alTop;
364   FToolbar.Height := FContainer.Height;
365 end;
366 
367 procedure TVectorialFillInterface.SetFillType(AValue: TVectorialFillType);
368 begin
369   if FFillType=AValue then Exit;
370   FFillType:=AValue;
371   UpdateAccordingToFillType;
372   UpdatePreview;
373   if Assigned(FOnFillTypeChange) then FOnFillTypeChange(self);
374   Changed(False);
375 end;
376 
377 procedure TVectorialFillInterface.ShapeSolidColorMouseUp(Sender: TObject;
378   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
379 begin
380   ChooseColor(-1, Button);
381 end;
382 
383 {procedure TVectorialFillInterface.ShapeStartColorMouseUp(Sender: TObject;
384   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
385 begin
386   ChooseColor(0, Button);
387 end;}
388 
389 procedure TVectorialFillInterface.UpdateAccordingToFillType;
390 begin
391   FButtonFillNone.Down := FillType = vftNone;
392   FButtonFillSolid.Down := FillType = vftSolid;
393   FButtonFillGradient.Down := FillType = vftGradient;
394   FButtonFillTexture.Down := FillType = vftTexture;
395   UpdateButtonAdjustToShape;
396 
397   if FillType <> vftSolid then HideSolidColorInterface;
398   if FillType <> vftGradient then HideGradientInterface;
399   if FillType <> vftTexture then HideTextureInterface;
400 
401   case FillType of
402     vftSolid: begin
403       CreateSolidColorInterface;
404       UpdateShapeSolidColor;
405       ShowAppendToolButtons([FShapeSolidColor,FUpDownSolidAlpha]);
406     end;
407     vftGradient: begin
408       CreateGradientInterface;
409       UpdateGradientParams;
410       ShowAppendToolButtons([FButtonGradRepetition,FButtonGradInterp,
411                            {FShapeStartColor,}FUpDownStartAlpha,FButtonSwapColor,
412                            {FShapeEndColor,}FUpDownEndAlpha]);
413     end;
414     vftTexture: begin
415       CreateTextureInterface;
416       UpdateTextureParams;
417       ShowAppendToolButtons([FButtonTexRepeat,FUpDownTexAlpha,FButtonLoadTexture]);
418     end;
419   end;
420 end;
421 
422 procedure TVectorialFillInterface.UpdateTopToolbar;
423 var
424   x: Integer;
425 begin
426   FToolbar.BeginUpdate;
427   x := FToolbar.Indent;
428   FButtonFillNone.Left := x;
429   //FButtonFillNone.Wrap := [vftSolid,vftGradient,vftTexture]*FAllowedFillTypes = [];
430   FButtonFillNone.Visible:= vftNone in FAllowedFillTypes;
431   if vftNone in FAllowedFillTypes then inc(x, FButtonFillNone.Width);
432   FButtonFillSolid.Left := x;
433   //FButtonFillSolid.Wrap := [vftGradient,vftTexture]*FAllowedFillTypes = [];
434   FButtonFillSolid.Visible:= vftSolid in FAllowedFillTypes;
435   if vftSolid in FAllowedFillTypes then inc(x, FButtonFillSolid.Width);
436   FButtonFillGradient.Left := x;
437   //FButtonFillGradient.Wrap := [vftTexture]*FAllowedFillTypes = [];
438   FButtonFillGradient.Visible:= vftGradient in FAllowedFillTypes;
439   if vftGradient in FAllowedFillTypes then inc(x, FButtonFillGradient.Width);
440   FButtonFillTexture.Left := x;
441   FButtonFillTexture.Visible:= vftTexture in FAllowedFillTypes;
442   if vftTexture in FAllowedFillTypes then inc(x, FButtonFillTexture.Width);
443 
444   FPreview.Left := x;
445   inc(x, FPreview.Width);
446 
447   FButtonEditGradTexPoints.Left := x;
448   inc(x, FButtonEditGradTexPoints.Width);
449 
450   FButtonAdjustToShape.Left := x;
451   FToolbar.EndUpdate;
452 end;
453 
454 procedure TVectorialFillInterface.UpdatePreview;
455 var
456   bmp, thumb: TBGRABitmap;
457   grad: TBGRALayerGradientOriginal;
458   bmpCopy: TBitmap;
459   ratio: single;
460   previewWidth: Integer;
461 begin
462   if FillType = vftGradient then
463     previewWidth := round(FToolbar.ButtonWidth*1.5)
464   else previewWidth := FToolbar.ButtonWidth;
465   FPreview.Width:= previewWidth + round(FToolbar.ButtonWidth*0.2);
466   FPreview.Height:= FToolbar.ButtonHeight;
467 
468   if not FImageListLoaded then exit;
469   bmp := TBGRABitmap.Create(previewWidth, FPreview.Height - VerticalPadding);
470   bmp.DrawCheckers(bmp.ClipRect, CSSWhite, CSSSilver);
471   case FillType of
472     vftSolid: bmp.Fill(SolidColor, dmDrawWithTransparency);
473     vftTexture:
474         if Assigned(FTexture) and (FTexture.Width > 0) and (FTexture.Height > 0) then
475         begin
476           ratio := min(bmp.Width/FTexture.Width, bmp.Height/FTexture.Height);
477           if ratio > 1 then ratio := 1;
478           thumb := TBGRABitmap.Create(max(round(FTexture.Width*ratio),1),
479                                       max(round(FTexture.Height*ratio),1));
480           thumb.StretchPutImage(thumb.ClipRect, FTexture, dmSet);
481           bmp.Fill(thumb, dmDrawWithTransparency, TextureOpacity*$0101);
482           thumb.Free;
483         end;
484     vftGradient:
485       begin
486         grad := TBGRALayerGradientOriginal.Create;
487         grad.StartColor := GradStartColor;
488         grad.EndColor := GradEndColor;
489         grad.Origin := PointF(0,0);
490         grad.XAxis := PointF(bmp.Width, 0);
491         grad.ColorInterpolation:= GradInterpolation;
492         grad.Render(bmp, AffineMatrixIdentity, false, dmDrawWithTransparency);
493         grad.Free;
494       end;
495   end;
496   if IsTarget then
497   begin
498     if bmp.GetPixel(bmp.Width/2,bmp.Height/2).Lightness > 20000 then
499       bmp.Rectangle(bmp.ClipRect, BGRABlack, dmDrawWithTransparency)
500       else bmp.Rectangle(bmp.ClipRect, CSSSilver, dmDrawWithTransparency);
501   end
502     else bmp.Rectangle(bmp.ClipRect, BGRA(0,0,0,128), dmDrawWithTransparency);
503   bmpCopy := bmp.MakeBitmapCopy(clBtnFace);
504   bmp.Free;
505   FPreview.Picture.Assign(bmpCopy);
506   bmpCopy.Free;
507 
508   if (FillType = vftTexture) and Assigned(Texture) and Assigned(FOnTextureClick) then
509     FPreview.Cursor := crHandPoint
510   else
511     FPreview.Cursor := crDefault;
512 end;
513 
514 procedure TVectorialFillInterface.UpdateShapeSolidColor;
515 var
516   c: TBGRAPixel;
517 begin
518   c := SolidColor;
519   c.alpha := 255;
520   if Assigned(FShapeSolidColor) then FShapeSolidColor.Brush.Color := c;
521   if Assigned(FUpDownSolidAlpha) then FUpDownSolidAlpha.Value := SolidColor.alpha;
522 end;
523 
524 procedure TVectorialFillInterface.UpdateTextureParams;
525 begin
526   if Assigned(FButtonTexRepeat) then FButtonTexRepeat.ImageIndex := 17 + ord(TextureRepetition);
527   if Assigned(FUpDownTexAlpha) then FUpDownTexAlpha.Value := TextureOpacity;
528 end;
529 
530 procedure TVectorialFillInterface.UpdateGradientParams;
531 {var
532   c: TBGRAPixel;}
533 begin
534 {  c := GradStartColor;
535   c.alpha := 255;
536   if Assigned(FShapeStartColor) then FShapeStartColor.Brush.Color := c;}
537   if Assigned(FUpDownStartAlpha) then FUpDownStartAlpha.Value := GradStartColor.alpha;
538 {  c := GradEndColor;
539   c.alpha := 255;
540   if Assigned(FShapeEndColor) then FShapeEndColor.Brush.Color := c;}
541   if Assigned(FUpDownEndAlpha) then FUpDownEndAlpha.Value := GradEndColor.alpha;
542 
543   if Assigned(FButtonGradRepetition) then FButtonGradRepetition.ImageIndex := 7+ord(FGradRepetition);
544   if Assigned(FButtonGradInterp) then FButtonGradInterp.ImageIndex := 11+ord(FGradInterp);
545 end;
546 
547 procedure TVectorialFillInterface.UpdateButtonAdjustToShape;
548 begin
549   if Assigned(FButtonAdjustToShape) then
550   begin
551     FButtonAdjustToShape.Enabled := FCanAdjustToShape and (FillType in[vftGradient,vftTexture]);
552     if FillType in[vftGradient,vftTexture] then
553       FButtonAdjustToShape.Style := tbsButton
554     else
555       FButtonAdjustToShape.Style := tbsDivider;
556   end;
557   if Assigned(FButtonEditGradTexPoints) then
558   begin
559     FButtonEditGradTexPoints.Enabled := FCanEditGradTexPoints and (FillType in [vftGradient,vftTexture]);
560     if FillType in [vftGradient,vftTexture] then
561       FButtonEditGradTexPoints.Style := tbsCheck
562     else
563       FButtonEditGradTexPoints.Style := tbsDivider;
564   end;
565 end;
566 
567 procedure TVectorialFillInterface.UpDownEndAlphaChange(Sender: TObject;
568   AByUser: boolean);
569 var
570   c: TBGRAPixel;
571 begin
572   if AByUser then
573   begin
574     c := GradEndColor;
575     c.alpha := FUpDownEndAlpha.Value;
576     GradEndColor:= c;
577   end;
578 end;
579 
580 procedure TVectorialFillInterface.UpDownSolidAlphaChange(Sender: TObject;
581   AByUser: boolean);
582 begin
583   if AByUser then
584     SolidColor:= ColorToBGRA(FShapeSolidColor.Brush.Color, FUpDownSolidAlpha.Value);
585 end;
586 
587 procedure TVectorialFillInterface.UpDownStartAlphaChange(Sender: TObject;
588   AByUser: boolean);
589 var
590   c: TBGRAPixel;
591 begin
592   if AByUser then
593   begin
594     c := GradStartColor;
595     c.alpha := FUpDownStartAlpha.Value;
596     GradStartColor:= c;
597   end;
598 end;
599 
600 procedure TVectorialFillInterface.UpDownTexAlphaChange(Sender: TObject;
601   AByUser: boolean);
602 begin
603   if AByUser then
604   begin
605     FTexOpacity:= FUpDownTexAlpha.Value;
606     if FillType = vftTexture then Changed;
607   end;
608 end;
609 
610 procedure TVectorialFillInterface.ChooseColor(AColorIndex: integer; AButton: TMouseButton);
611 
612   procedure AssignNewColor(AColor: TBGRAPixel);
613   begin
614     case AColorIndex of
615       -1: SolidColor := AColor;
616       0: GradStartColor := AColor;
617       1: GradEndColor := AColor;
618     end;
619   end;
620 
621 var
622   curColorBGRA: TBGRAPixel;
623   curColor: TColor;
624   handled: boolean;
625 begin
626   case AColorIndex of
627     -1: curColorBGRA := SolidColor;
628     0: curColorBGRA := GradStartColor;
629     1: curColorBGRA := GradEndColor;
630   else exit;
631   end;
632   if Assigned(FOnChooseColor) then
633   begin
634     FOnChooseColor(self, AButton, AColorIndex, curColorBGRA, handled);
635     if handled then
636     begin
637       AssignNewColor( curColorBGRA );
638       exit;
639     end;
640   end;
641   curColor := RGBToColor(curColorBGRA.red, curColorBGRA.green, curColorBGRA.blue);
642   FColorDlg.Color := curColor;
643   if FColorDlg.Execute then
644   begin
645     if curColorBGRA.alpha = 0 then
646       AssignNewColor( ColorToBGRA(FColorDlg.Color) )
647     else
648       AssignNewColor( ColorToBGRA(FColorDlg.Color, curColorBGRA.alpha) );
649   end;
650 end;
651 
652 procedure TVectorialFillInterface.CreateSolidColorInterface;
653 begin
654   if FSolidColorInterfaceCreated then exit;
655   FSolidColorInterfaceCreated := true;
656 
657   //solid color interface
658   FShapeSolidColor := TShape.Create(FToolbar);
659   FShapeSolidColor.Width := FToolbar.ButtonWidth;
660   FShapeSolidColor.Height := FToolbar.ButtonHeight;
661   FShapeSolidColor.OnMouseUp:= @ShapeSolidColorMouseUp;
662   FShapeSolidColor.Hint := rsColor;
663   AddToolbarControl(FToolbar, FShapeSolidColor);
664   FUpDownSolidAlpha := TBCTrackbarUpdown.Create(FToolbar);
665   FUpDownSolidAlpha.Width := FToolbar.ButtonWidth*2;
666   FUpDownSolidAlpha.Height := FToolbar.ButtonHeight;
667   FUpDownSolidAlpha.MinValue := 0;
668   FUpDownSolidAlpha.MaxValue := 255;
669   FUpDownSolidAlpha.Increment:= 15;
670   FUpDownSolidAlpha.OnChange:=@UpDownSolidAlphaChange;
671   FUpDownSolidAlpha.Hint := rsOpacity;
672   AddToolbarControl(FToolbar, FUpDownSolidAlpha);
673   AttachMouseEvent(FUpDownSolidAlpha);
674 end;
675 
676 procedure TVectorialFillInterface.CreateGradientInterface;
677 var
678   gr: TBGRAGradientRepetition;
679   ci: TBGRAColorInterpolation;
680   item: TMenuItem;
681 begin
682   if FGradientInterfaceCreated then exit;
683   FGradientInterfaceCreated := true;
684 
685   FButtonGradRepetition := AddToolbarButton(FToolbar, rsGradientRepetition+'...', 7+ord(FGradRepetition), @ButtonGradRepetitionClick);
686   AttachMouseEvent(FButtonGradRepetition);
687   FButtonGradInterp := AddToolbarButton(FToolbar, rsColorInterpolation+'...', 11+ord(FGradInterp), @ButtonGradInterpClick);
688   AttachMouseEvent(FButtonGradInterp);
689 
690 {  FShapeStartColor := TShape.Create(FToolbar);
691   FShapeStartColor.Width := FToolbar.ButtonWidth*3 div 4;
692   FShapeStartColor.Height := FToolbar.ButtonHeight;
693   FShapeStartColor.OnMouseUp:=@ShapeStartColorMouseUp;
694   FShapeStartColor.Hint := 'Start color';
695   AddToolbarControl(FToolbar, FShapeStartColor);}
696   FUpDownStartAlpha := TBCTrackbarUpdown.Create(FToolbar);
697   FUpDownStartAlpha.Width := FToolbar.ButtonWidth*2;
698   FUpDownStartAlpha.Height := FToolbar.ButtonHeight;
699   FUpDownStartAlpha.MinValue := 0;
700   FUpDownStartAlpha.MaxValue := 255;
701   FUpDownStartAlpha.Increment:= 15;
702   FUpDownStartAlpha.OnChange:=@UpDownStartAlphaChange;
703   FUpDownStartAlpha.Hint := rsStartOpacity;
704   AddToolbarControl(FToolbar, FUpDownStartAlpha);
705   AttachMouseEvent(FUpDownStartAlpha);
706   FButtonSwapColor := AddToolbarButton(FToolbar, rsSwapColors, 23, @ButtonSwapColorClick);
707   AttachMouseEvent(FButtonSwapColor);
708 {  FShapeEndColor := TShape.Create(FToolbar);
709   FShapeEndColor.Width := FToolbar.ButtonWidth*3 div 4;
710   FShapeEndColor.Height := FToolbar.ButtonHeight;
711   FShapeEndColor.OnMouseUp:=@ShapeEndColorMouseUp;
712   FShapeEndColor.Hint := 'End color';
713   AddToolbarControl(FToolbar, FShapeEndColor);}
714   FUpDownEndAlpha := TBCTrackbarUpdown.Create(FToolbar);
715   FUpDownEndAlpha.Width := FToolbar.ButtonWidth*2;
716   FUpDownEndAlpha.Height := FToolbar.ButtonHeight;
717   FUpDownEndAlpha.MinValue := 0;
718   FUpDownEndAlpha.MaxValue := 255;
719   FUpDownEndAlpha.Increment:= 15;
720   FUpDownEndAlpha.OnChange:=@UpDownEndAlphaChange;
721   FUpDownEndAlpha.Hint := rsEndOpacity;
722   AddToolbarControl(FToolbar, FUpDownEndAlpha);
723   AttachMouseEvent(FUpDownEndAlpha);
724 
725   FGradRepetitionMenu := TPopupMenu.Create(self);
726   FGradRepetitionMenu.Images := FImageList;
727   for gr := low(TBGRAGradientRepetition) to high(TBGRAGradientRepetition) do
728   begin
729     item := TMenuItem.Create(FGradRepetitionMenu);  item.Caption := GradRepetitionToStr(gr);
730     item.OnClick:=@OnClickGradRepeat;               item.Tag := ord(gr);
731     item.ImageIndex:= 7+ord(gr);
732     FGradRepetitionMenu.Items.Add(item);
733   end;
734 
735   FGradInterpMenu := TPopupMenu.Create(self);
736   FGradInterpMenu.Images := FImageList;
737   for ci := low(TBGRAColorInterpolation) to high(TBGRAColorInterpolation) do
738   begin
739     item := TMenuItem.Create(FGradInterpMenu);  item.Caption := ColorInterpToStr(ci);
740     item.OnClick:=@OnClickGradInterp;           item.Tag := ord(ci);
741     item.ImageIndex:= 11+ord(ci);
742     FGradInterpMenu.Items.Add(item);
743   end;
744 end;
745 
746 procedure TVectorialFillInterface.CreateTextureInterface;
747 var
748   tr: TTextureRepetition;
749   item: TMenuItem;
750 begin
751   if FTextureInterfaceCreated then exit;
752   FTextureInterfaceCreated := true;
753 
754   FButtonTexRepeat := AddToolbarButton(FToolbar, rsTextureRepetition+'...', -1, @ButtonTexRepeatClick);
755   AttachMouseEvent(FButtonTexRepeat);
756   FUpDownTexAlpha := TBCTrackbarUpdown.Create(FToolbar);
757   FUpDownTexAlpha.Width := FToolbar.ButtonWidth*2;
758   FUpDownTexAlpha.Height := FToolbar.ButtonHeight;
759   FUpDownTexAlpha.MinValue := 0;
760   FUpDownTexAlpha.MaxValue := 255;
761   FUpDownTexAlpha.Increment:= 15;
762   FUpDownTexAlpha.OnChange:=@UpDownTexAlphaChange;
763   FUpDownTexAlpha.Hint := rsOpacity;
764   AddToolbarControl(FToolbar, FUpDownTexAlpha);
765   AttachMouseEvent(FUpDownTexAlpha);
766   FButtonLoadTexture := AddToolbarButton(FToolbar, rsLoadTexture+'...', 22, @ButtonLoadTextureClick);
767   AttachMouseEvent(FButtonLoadTexture);
768   FTextureAverageColorComputed := false;
769 
770   FTexRepetitionMenu := TPopupMenu.Create(self);
771   FTexRepetitionMenu.Images := FImageList;
772   for tr := low(TTextureRepetition) to high(TTextureRepetition) do
773   begin
774     item := TMenuItem.Create(FTexRepetitionMenu);  item.Caption := TextureRepetitionToStr(tr);
775     item.OnClick:=@OnClickBackTexRepeat;           item.Tag := ord(tr);
776     item.ImageIndex:= 17+ord(tr);
777     FTexRepetitionMenu.Items.Add(item);
778   end;
779 end;
780 
781 procedure TVectorialFillInterface.HideSolidColorInterface;
782 begin
783   if not FSolidColorInterfaceCreated then exit;
784   FShapeSolidColor.Visible := false;
785   FUpDownSolidAlpha.Visible := false;
786 end;
787 
788 procedure TVectorialFillInterface.HideGradientInterface;
789 begin
790   if not FGradientInterfaceCreated then exit;
791   FButtonGradRepetition.Visible := false;
792   FButtonGradInterp.Visible := false;
793   //FShapeStartColor.Visible := false;
794   FUpDownStartAlpha.Visible := false;
795   FButtonSwapColor.Visible := false;
796   //FShapeEndColor.Visible := false;
797   FUpDownEndAlpha.Visible := false;
798 end;
799 
800 procedure TVectorialFillInterface.HideTextureInterface;
801 begin
802   if not FTextureInterfaceCreated then exit;
803   FButtonTexRepeat.Visible := false;
804   FUpDownTexAlpha.Visible := false;
805   FButtonLoadTexture.Visible := false;
806 end;
807 
808 procedure TVectorialFillInterface.Init(AImageListWidth,
809   AImageListHeight: Integer);
810 var
811   gt: TGradientType;
812   item: TMenuItem;
813 begin
814   FContainer := nil;
815 
816   FAllowedFillTypes := [vftNone, vftSolid, vftGradient, vftTexture];
817   FFillType:= vftSolid;
818   FSolidColor:= BGRAWhite;
819   FGradStartColor:= CSSRed;
820   FGradEndColor:= CSSYellow;
821   FGradType:= gtLinear;
822   FGradRepetition:= grPad;
823   FGradInterp:= ciLinearRGB;
824   FTexture:= nil;
825   FTexRepetition:= trRepeatBoth;
826   FTexOpacity:= 255;
827   FCanAdjustToShape:= true;
828 
829   FVerticalPadding:= 4;
830   FImageList := TBGRAImageList.Create(self);
831   FImageListLoaded:= false;
832   FImageListSize := Size(AImageListWidth,AImageListHeight);
833 
834   FOpenPictureDlg := TOpenPictureDialog.Create(self);
835   FColorDlg:= TColorDialog.Create(self);
836 
837   FOnFillChange:= nil;
838   FOnTextureChange:= nil;
839 
840   FToolbar := CreateToolBar(FImageList);
841   FToolbar.Wrapable := false;
842   AttachMouseEvent(FToolbar);
843   FButtonFillNone := AddToolbarCheckButton(FToolbar, rsNoFill, 0, @ButtonFillChange, False, False);
844   AttachMouseEvent(FButtonFillNone);
845   FButtonFillSolid := AddToolbarCheckButton(FToolbar, rsSolidColor, 1, @ButtonFillChange, False, False);
846   AttachMouseEvent(FButtonFillSolid);
847   FButtonFillGradient := AddToolbarButton(FToolbar, rsGradientFill, 2+ord(FGradType), @ButtonFillGradClick);
848   AttachMouseEvent(FButtonFillGradient);
849   FButtonFillTexture := AddToolbarButton(FToolbar, rsTextureFill, 24, @ButtonFillTexClick);
850   AttachMouseEvent(FButtonFillTexture);
851 
852   FPreview := TImage.Create(FToolbar);
853   FPreview.Center:= true;
854   FPreview.OnMouseUp:=@Preview_MouseUp;
855   FPreview.Hint := rsPreview;
856   UpdatePreview;
857   AddToolbarControl(FToolbar, FPreview);
858   AttachMouseEvent(FPreview);
859 
860   FButtonEditGradTexPoints := AddToolbarCheckButton(FToolbar, rsEditGradTexPoints, 25, @EditGradTextPointsClick, false, false);
861   AttachMouseEvent(FButtonEditGradTexPoints);
862   FButtonAdjustToShape := AddToolbarButton(FToolbar, rsAdjustToShape, 21, @AdjustToShapeClick);
863   AttachMouseEvent(FButtonAdjustToShape);
864   FButtonAdjustToShape.Wrap := true;
865   UpdateButtonAdjustToShape;
866 
867   //menu to access gradient interface
868   FGradTypeMenu := TPopupMenu.Create(self);
869   FGradTypeMenu.Images := FImageList;
870   for gt := low(TGradientType) to high(TGradientType) do
871   begin
872     item := TMenuItem.Create(FGradTypeMenu);  item.Caption := GradientTypeToTranslatedStr(gt);
873     item.OnClick:=@OnClickBackGradType;       item.Tag := ord(gt);
874     item.ImageIndex:= 2+ord(gt);
875     FGradTypeMenu.Items.Add(item);
876   end;
877 
878   FSolidColorInterfaceCreated := false;
879   FGradientInterfaceCreated:= false;
880   FTextureInterfaceCreated:= false;
881 
882   UpdateAccordingToFillType;
883 end;
884 
885 procedure TVectorialFillInterface.AttachMouseEvent(AControl: TToolBar);
886 begin
887   AControl.OnMouseMove:=@ToolbarMouseMove;
888   AControl.OnMouseDown:=@ToolbarMouseDown;
889   AControl.OnMouseUp:=@ToolbarMouseUp;
890   AControl.OnMouseEnter:=@ToolbarMouseEnter;
891   AControl.OnMouseLeave:=@ToolbarMouseLeave;
892 end;
893 
894 procedure TVectorialFillInterface.AttachMouseEvent(AControl: TToolButton);
895 begin
896   AControl.OnMouseMove:=@AnyButtonMouseMove;
897   AControl.OnMouseDown:=@AnyButtonMouseDown;
898   AControl.OnMouseUp:=@AnyButtonMouseUp;
899   AControl.OnMouseEnter:=@AnyButtonMouseEnter;
900   AControl.OnMouseLeave:=@AnyButtonMouseLeave;
901 end;
902 
903 procedure TVectorialFillInterface.AttachMouseEvent(AControl: TBCTrackbarUpdown);
904 begin
905   AControl.OnMouseMove:=@AnyButtonMouseMove;
906   AControl.OnMouseDown:=@AnyButtonMouseDown;
907   AControl.OnMouseUp:=@AnyButtonMouseUp;
908   AControl.OnMouseEnter:=@AnyButtonMouseEnter;
909   AControl.OnMouseLeave:=@AnyButtonMouseLeave;
910 end;
911 
912 procedure TVectorialFillInterface.AttachMouseEvent(AControl: TImage);
913 begin
914   AControl.OnMouseMove:=@AnyButtonMouseMove;
915   AControl.OnMouseEnter:=@AnyButtonMouseEnter;
916   AControl.OnMouseLeave:=@AnyButtonMouseLeave;
917 end;
918 
919 procedure TVectorialFillInterface.SetSolidColor(AValue: TBGRAPixel);
920 begin
921   if FSolidColor.EqualsExactly(AValue) then Exit;
922   FSolidColor:=AValue;
923   UpdateShapeSolidColor;
924   If FillType = vftSolid then Changed;
925 end;
926 
927 procedure TVectorialFillInterface.ButtonFillChange(Sender: TObject);
928 begin
929   if Sender = FButtonFillNone then
930   begin
931     FillType:= vftNone;
932     FButtonFillNone.Down := true;
933   end
934   else if Sender = FButtonFillSolid then
935   begin
936     FillType:= vftSolid;
937     FButtonFillSolid.Down := true;
938   end;
939 end;
940 
941 procedure TVectorialFillInterface.SetTextureRepetition(
942   AValue: TTextureRepetition);
943 begin
944   if FTexRepetition=AValue then Exit;
945   FTexRepetition:=AValue;
946   UpdateTextureParams;
947   If FillType = vftTexture then Changed;
948 end;
949 
950 procedure TVectorialFillInterface.SetTextureOpacity(AValue: byte);
951 begin
952   if FTexOpacity=AValue then Exit;
953   FTexOpacity:=AValue;
954   FUpDownTexAlpha.Value := AValue;
955   If FillType = vftTexture then Changed;
956 end;
957 
958 {procedure TVectorialFillInterface.ShapeEndColorMouseUp(Sender: TObject;
959   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
960 begin
961   ChooseColor(1, Button);
962 end;}
963 
964 procedure TVectorialFillInterface.SetGradientType(AValue: TGradientType);
965 begin
966   if FGradType=AValue then Exit;
967   FGradType:=AValue;
968   FButtonFillGradient.ImageIndex := 2+ord(GradientType);
969   if FillType = vftGradient then Changed;
970 end;
971 
972 procedure TVectorialFillInterface.SetGradEndColor(AValue: TBGRAPixel);
973 begin
974   if FGradEndColor.EqualsExactly(AValue) then Exit;
975   FGradEndColor:=AValue;
976   UpdateGradientParams;
977   if FillType = vftGradient then Changed;
978 end;
979 
980 procedure TVectorialFillInterface.SetGradStartColor(AValue: TBGRAPixel);
981 begin
982   if FGradStartColor.EqualsExactly(AValue) then Exit;
983   FGradStartColor:=AValue;
984   UpdateGradientParams;
985   if FillType = vftGradient then Changed;
986 end;
987 
988 procedure TVectorialFillInterface.SetGradRepetition(AValue: TBGRAGradientRepetition);
989 begin
990   if FGradRepetition=AValue then Exit;
991   FGradRepetition:=AValue;
992   UpdateGradientParams;
993   if FillType = vftGradient then Changed;
994 end;
995 
996 procedure TVectorialFillInterface.SetGradInterpolation(
997   AValue: TBGRAColorInterpolation);
998 begin
999   if FGradInterp=AValue then Exit;
1000   FGradInterp:=AValue;
1001   UpdateGradientParams;
1002   if FillType = vftGradient then Changed;
1003 end;
1004 
1005 procedure TVectorialFillInterface.SetContainer(AValue: TWinControl);
1006 begin
1007   if FContainer=AValue then Exit;
1008   if Assigned(FContainer) then FContainer.RemoveControl(FToolbar);
1009   FContainer:=AValue;
1010   if Assigned(FContainer) then
1011   begin
1012     FContainer.InsertControl(FToolBar);
1013     ContainerSizeChanged;
1014   end;
1015 end;
1016 
GetPreferredSizenull1017 function TVectorialFillInterface.GetPreferredSize: TSize;
1018 begin
1019   result := GetToolbarSize(FToolbar,0);
1020 end;
1021 
1022 procedure TVectorialFillInterface.SetCanAdjustToShape(AValue: boolean);
1023 begin
1024   if FCanAdjustToShape=AValue then Exit;
1025   FCanAdjustToShape:=AValue;
1026   UpdateButtonAdjustToShape;
1027 end;
1028 
1029 procedure TVectorialFillInterface.SetImageListSize(AValue: TSize);
1030 begin
1031   if (FImageListSize.cx=AValue.cx) and (FImageListSize.cy=AValue.cy) then Exit;
1032   FImageListSize:=AValue;
1033   if FImageListLoaded then LoadImageList;
1034 end;
1035 
1036 procedure TVectorialFillInterface.SetAllowedFillTypes(
1037   AValue: TVectorialFillTypes);
1038 begin
1039   Include(AValue, FFillType); //cannot exclude current type
1040   if FAllowedFillTypes=AValue then Exit;
1041   FAllowedFillTypes:=AValue;
1042   UpdateTopToolbar;
1043 end;
1044 
1045 procedure TVectorialFillInterface.SetOnTextureClick(AValue: TNotifyEvent);
1046 begin
1047   if FOnTextureClick=AValue then Exit;
1048   FOnTextureClick:=AValue;
1049   UpdatePreview;
1050 end;
1051 
TVectorialFillInterface.GetAverageColornull1052 function TVectorialFillInterface.GetAverageColor: TBGRAPixel;
1053 begin
1054   case FillType of
1055   vftNone: result := BGRAPixelTransparent;
1056   vftGradient: result := MergeBGRAWithGammaCorrection(GradStartColor, 1, GradEndColor, 1);
1057   vftTexture: begin
1058       if not FTextureAverageColorComputed then
1059       begin
1060         if Assigned(FTexture) then
1061           FTextureAverageColor := FTexture.AverageColor
1062         else
1063           FTextureAverageColor := BGRAPixelTransparent;
1064         FTextureAverageColorComputed := true;
1065       end;
1066       result := FTextureAverageColor;
1067     end
1068   else {vftSolid} result := SolidColor;
1069   end;
1070 end;
1071 
1072 procedure TVectorialFillInterface.ToolbarMouseMove(Sender: TObject;
1073   Shift: TShiftState; X, Y: Integer);
1074 begin
1075   if Assigned(FOnMouseMove) then FOnMouseMove(self, Shift, X+FToolbar.Left,Y+FToolbar.Top);
1076 end;
1077 
1078 procedure TVectorialFillInterface.ToolbarMouseUp(Sender: TObject;
1079   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1080 begin
1081   if Assigned(FOnMouseUp) then FOnMouseUp(self, Button, Shift, X+FToolbar.Left,Y+FToolbar.Top);
1082 end;
1083 
1084 procedure TVectorialFillInterface.AnyButtonMouseDown(Sender: TObject;
1085   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1086 begin
1087   if Assigned(FOnMouseDown) then FOnMouseDown(self, Button, Shift,
1088       X+FToolbar.Left+TControl(Sender).Left,Y+FToolbar.Top+TControl(Sender).Top);
1089 end;
1090 
1091 procedure TVectorialFillInterface.AnyButtonMouseEnter(Sender: TObject);
1092 begin
1093   If Assigned(FOnMouseEnter) then FOnMouseEnter(self);
1094 end;
1095 
1096 procedure TVectorialFillInterface.AnyButtonMouseLeave(Sender: TObject);
1097 begin
1098   If Assigned(FOnMouseLeave) then FOnMouseLeave(self);
1099 end;
1100 
1101 procedure TVectorialFillInterface.AnyButtonMouseMove(Sender: TObject;
1102   Shift: TShiftState; X, Y: Integer);
1103 begin
1104   if Assigned(FOnMouseMove) then FOnMouseMove(self, Shift,
1105       X+FToolbar.Left+TControl(Sender).Left,Y+FToolbar.Top+TControl(Sender).Top);
1106 end;
1107 
1108 procedure TVectorialFillInterface.AnyButtonMouseUp(Sender: TObject;
1109   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1110 begin
1111   if Assigned(FOnMouseUp) then FOnMouseUp(self, Button, Shift,
1112       X+FToolbar.Left+TControl(Sender).Left,Y+FToolbar.Top+TControl(Sender).Top);
1113 end;
1114 
1115 procedure TVectorialFillInterface.ToolbarMouseDown(Sender: TObject;
1116   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1117 begin
1118   if Assigned(FOnMouseDown) then FOnMouseDown(self, Button, Shift, X+FToolbar.Left,Y+FToolbar.Top);
1119 end;
1120 
1121 procedure TVectorialFillInterface.SetVerticalPadding(AValue: integer);
1122 begin
1123   if FVerticalPadding=AValue then Exit;
1124   FVerticalPadding:=AValue;
1125   if Assigned(FToolbar) and Assigned(FImageList) then
1126   begin
1127     FToolbar.ButtonHeight:= FImageList.Height+AValue;
1128     UpdatePreview;
1129   end;
1130 end;
1131 
1132 procedure TVectorialFillInterface.Preview_MouseUp(Sender: TObject;
1133   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1134 begin
1135   case FillType of
1136   vftSolid: ChooseColor(-1, Button);
1137   vftGradient: if X < FPreview.Width div 2 then ChooseColor(0, Button) else ChooseColor(1, Button);
1138   vftTexture: if Assigned(Texture) and Assigned(FOnTextureClick) then
1139                 FOnTextureClick(self);
1140   end;
1141 end;
1142 
1143 procedure TVectorialFillInterface.EditGradTextPointsClick(Sender: TObject);
1144 begin
1145   if Assigned(FOnEditGradTexPoints) then FOnEditGradTexPoints(self);
1146 end;
1147 
TVectorialFillInterface.GetEditingGradTexPointsnull1148 function TVectorialFillInterface.GetEditingGradTexPoints: boolean;
1149 begin
1150   if Assigned(FButtonEditGradTexPoints) then
1151     result := FButtonEditGradTexPoints.Down
1152   else result := false;
1153 end;
1154 
1155 procedure TVectorialFillInterface.SetCanEditGradTexPoints(AValue: boolean);
1156 begin
1157   if FCanEditGradTexPoints=AValue then Exit;
1158   FCanEditGradTexPoints:=AValue;
1159   UpdateButtonAdjustToShape;
1160 end;
1161 
1162 procedure TVectorialFillInterface.SetEditingGradTexPoints(AValue: boolean);
1163 begin
1164   if Assigned(FButtonEditGradTexPoints) then
1165     FButtonEditGradTexPoints.Down := AValue;
1166 end;
1167 
1168 procedure TVectorialFillInterface.SetIsTarget(AValue: boolean);
1169 begin
1170   if FIsTarget=AValue then Exit;
1171   FIsTarget:=AValue;
1172   UpdatePreview;
1173 end;
1174 
1175 procedure TVectorialFillInterface.ToolbarMouseEnter(Sender: TObject);
1176 begin
1177   If Assigned(FOnMouseEnter) then FOnMouseEnter(self);
1178 end;
1179 
1180 procedure TVectorialFillInterface.ToolbarMouseLeave(Sender: TObject);
1181 begin
1182   If Assigned(FOnMouseLeave) then FOnMouseLeave(self);
1183 end;
1184 
1185 procedure TVectorialFillInterface.AdjustToShapeClick(Sender: TObject);
1186 begin
1187   if Assigned(FOnAdjustToShape) then FOnAdjustToShape(self);
1188 end;
1189 
1190 procedure TVectorialFillInterface.ButtonFillGradClick(Sender: TObject);
1191 begin
1192   if Assigned(FGradTypeMenu) then
1193     with FButtonFillGradient.ClientToScreen(Point(0,FButtonFillGradient.Height)) do
1194       FGradTypeMenu.PopUp(X,Y);
1195   FButtonFillGradient.Down := (FillType = vftGradient);
1196 end;
1197 
1198 procedure TVectorialFillInterface.ButtonFillTexClick(Sender: TObject);
1199 begin
1200   if FFillType = vftTexture then
1201   begin
1202     FButtonFillTexture.Down := true;
1203     exit;
1204   end;
1205 
1206   if Assigned(FTexture) then FillType := vftTexture
1207   else LoadTexture;
1208 end;
1209 
1210 procedure TVectorialFillInterface.ButtonGradInterpClick(Sender: TObject);
1211 begin
1212   if Assigned(FGradInterpMenu) then
1213     with FButtonGradInterp.ClientToScreen(Point(0,FButtonGradInterp.Height)) do
1214       FGradInterpMenu.PopUp(X,Y);
1215 end;
1216 
1217 procedure TVectorialFillInterface.ButtonGradRepetitionClick(Sender: TObject);
1218 begin
1219   if Assigned(FGradRepetitionMenu) then
1220     with FButtonGradRepetition.ClientToScreen(Point(0,FButtonGradRepetition.Height)) do
1221       FGradRepetitionMenu.PopUp(X,Y);
1222 end;
1223 
1224 procedure TVectorialFillInterface.ButtonLoadTextureClick(Sender: TObject);
1225 begin
1226   LoadTexture;
1227 end;
1228 
1229 procedure TVectorialFillInterface.ButtonSwapColorClick(Sender: TObject);
1230 var
1231   temp: TBGRAPixel;
1232 begin
1233   temp := GradStartColor;
1234   FGradStartColor := GradEndColor;
1235   FGradEndColor := temp;
1236   UpdateGradientParams;
1237   if FillType = vftGradient then Changed;
1238 end;
1239 
1240 procedure TVectorialFillInterface.ButtonTexRepeatClick(Sender: TObject);
1241 begin
1242   if Assigned(FTexRepetitionMenu) then
1243     with FButtonTexRepeat.ClientToScreen(Point(0,FButtonTexRepeat.Height)) do
1244       FTexRepetitionMenu.PopUp(X,Y);
1245 end;
1246 
1247 constructor TVectorialFillInterface.Create(AOwner: TComponent);
1248 begin
1249   inherited Create(AOwner);
1250   Init(16,16);
1251 end;
1252 
1253 constructor TVectorialFillInterface.Create(AOwner: TComponent; AImageListWidth,
1254   AImageListHeight: Integer);
1255 begin
1256   inherited Create(AOwner);
1257   Init(AImageListWidth,AImageListHeight);
1258 end;
1259 
1260 destructor TVectorialFillInterface.Destroy;
1261 begin
1262   FTexture.FreeReference;
1263   if Assigned(FContainer) then
1264   begin
1265     FContainer.RemoveControl(FToolbar);
1266     FContainer := nil;
1267   end;
1268   FToolbar.Free;
1269   inherited Destroy;
1270 end;
1271 
TVectorialFillInterface.GetTextureThumbnailnull1272 function TVectorialFillInterface.GetTextureThumbnail(AWidth, AHeight: integer; ABackColor: TColor): TBitmap;
1273 var
1274   thumb: TBGRABitmap;
1275 begin
1276   if FTexture = nil then exit(nil);
1277   thumb := GetBitmapThumbnail(FTexture, AWidth,AHeight,BGRAPixelTransparent,true);
1278   try
1279     result := thumb.MakeBitmapCopy(ABackColor);
1280   finally
1281     thumb.Free;
1282   end;
1283 end;
1284 
1285 procedure TVectorialFillInterface.AssignFill(AFill: TVectorialFill);
1286 begin
1287   FillType := AFill.FillType;
1288   case FillType of
1289     vftTexture:
1290       begin
1291         Texture := AFill.Texture;
1292         TextureOpacity:= AFill.TextureOpacity;
1293         TextureRepetition:= AFill.TextureRepetition;
1294       end;
1295     vftSolid: SolidColor := AFill.SolidColor;
1296     vftGradient:
1297       begin
1298         GradStartColor := AFill.Gradient.StartColor;
1299         GradEndColor := AFill.Gradient.EndColor;
1300         GradientType:= AFill.Gradient.GradientType;
1301         GradRepetition:= AFill.Gradient.Repetition;
1302         GradInterpolation := AFill.Gradient.ColorInterpolation;
1303       end;
1304   end;
1305 end;
1306 
1307 procedure TVectorialFillInterface.UpdateFillExceptGeometry(ATargetFill: TVectorialFill);
1308 var
1309   f: TVectorialFill;
1310 begin
1311   f := CreateShapeFill(nil);
1312   if Assigned(ATargetFill) then
1313     ATargetFill.AssignExceptGeometry(f);
1314   f.Free;
1315 end;
1316 
TVectorialFillInterface.CreateShapeFillnull1317 function TVectorialFillInterface.CreateShapeFill(AShape: TVectorShape): TVectorialFill;
1318 var
1319   grad: TBGRALayerGradientOriginal;
1320 begin
1321   if FillType = vftSolid then
1322     exit(TVectorialFill.CreateAsSolid(SolidColor))
1323   else if (FillType = vftTexture) and Assigned(Texture) then
1324     result := TVectorialFill.CreateAsTexture(Texture, AffineMatrixIdentity,
1325          TextureOpacity, TextureRepetition)
1326   else if FillType = vftGradient then
1327   begin
1328     grad := TBGRALayerGradientOriginal.Create;
1329     grad.StartColor := GradStartColor;
1330     grad.EndColor := GradEndColor;
1331     grad.GradientType:= GradientType;
1332     grad.Repetition := GradRepetition;
1333     grad.ColorInterpolation:= GradInterpolation;
1334     result := TVectorialFill.CreateAsGradient(grad, true);
1335   end
1336   else exit(nil); //none
1337 
1338   if Assigned(AShape) then
1339     result.FitGeometry(AShape.SuggestGradientBox(AffineMatrixIdentity));
1340 end;
1341 
1342 procedure TVectorialFillInterface.UpdateShapeFill(AShape: TVectorShape;
1343   ATarget: TLCFillTarget);
1344 var
1345   vectorFill: TVectorialFill;
1346   curFill: TVectorialFill;
1347 begin
1348   case ATarget of
1349     ftPen: curFill:= AShape.PenFill;
1350     ftBack: curFill := AShape.BackFill;
1351     ftOutline: curFill := AShape.OutlineFill;
1352     else exit;
1353   end;
1354 
1355   if (FillType = vftTexture) and (TextureOpacity = 0) then
1356     vectorFill := nil else
1357   if (FillType = vftTexture) and (curFill.FillType = vftTexture) then
1358   begin
1359     vectorFill := TVectorialFill.CreateAsTexture(Texture, curFill.TextureMatrix,
1360                                                  TextureOpacity, TextureRepetition);
1361   end
1362   else if (FillType = vftGradient) and (curFill.FillType = vftGradient) then
1363   begin
1364     vectorFill := curFill.Duplicate;
1365     vectorFill.Gradient.StartColor := GradStartColor;
1366     vectorFill.Gradient.EndColor := GradEndColor;
1367     vectorFill.Gradient.GradientType := GradientType;
1368     vectorFill.Gradient.Repetition := GradRepetition;
1369     vectorFill.Gradient.ColorInterpolation:= GradInterpolation;
1370   end else
1371     vectorFill := CreateShapeFill(AShape);
1372 
1373   case ATarget of
1374     ftPen: AShape.PenFill:= vectorFill;
1375     ftBack: AShape.BackFill:= vectorFill;
1376     ftOutline: AShape.OutlineFill:= vectorFill;
1377   end;
1378   vectorFill.Free;
1379 end;
1380 
1381 begin
1382   {$i fillimages.lrs}
1383 end.
1384 
1385