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