| 1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918 |
- // SPDX-License-Identifier: LGPL-3.0-linking-exception
- { Customizable component which using BGRABitmap for drawing. Control mostly rendered
- using framework.
- Functionality:
- - Gradients
- - Double gradients
- - Rounding
- - Drop down list
- - Glyph
- - States (normal, hover, clicked)
- - Caption with shadow
- - Full alpha and antialias support
- originally written in 2012 by Krzysztof Dibowski dibowski at interia.pl
- }
- {******************************* CONTRIBUTOR(S) ******************************
- - Edivando S. Santos Brasil | [email protected]
- (Compatibility with delphi VCL 11/2018)
- ***************************** END CONTRIBUTOR(S) *****************************}
- unit BCButtonFocus;
- {$I bgracontrols.inc}
- interface
- uses
- Classes, {$IFDEF FPC}LCLType, LResources, LMessages,{$ENDIF} Controls, Dialogs,
- ActnList, ImgList, Menus, // MORA
- Buttons, Graphics, types,
- {$IFNDEF FPC}Windows, Messages, BGRAGraphics, GraphType, FPImage, {$ENDIF}
- BGRABitmap, BGRABitmapTypes, BCTypes, Forms, BCBasectrls, BCThemeManager;
- {off $DEFINE DEBUG}
- type
- TBCButtonFocusMemoryUsage = (bmuLowF, bmuMediumF, bmuHighF);
- TBCButtonFocusState = class;
- TBCButtonFocusStyle = (bbtButtonF, bbtDropDownF);
- TOnAfterRenderBCButtonFocus = procedure(Sender: TObject; const ABGRA: TBGRABitmap;
- AState: TBCButtonFocusState; ARect: TRect) of object;
- TBCButtonFocusPropertyData = (pdNoneF, pdUpdateSizeF);
- // MORA: DropDown styles
- TBCButtonFocusDropDownStyle = (
- bdsSeparateF, // DropDown is a separate button (default)
- bdsCommonF // DropDown is same as main button
- );
- TBCButtonFocusDropDownPosition = (
- bdpLeftF, // default
- bdpBottomF);
- { TBCButtonFocusState }
- TBCButtonFocusState = class(TBCProperty)
- private
- FBackground: TBCBackground;
- FBorder: TBCBorder;
- FFontEx: TBCFont;
- procedure OnChangeFont({%H-}Sender: TObject; {%H-}AData: PtrInt);
- procedure OnChangeChildProperty({%H-}Sender: TObject; AData: PtrInt);
- procedure SetBackground(AValue: TBCBackground);
- procedure SetBorder(AValue: TBCBorder);
- procedure SetFontEx(const AValue: TBCFont);
- public
- constructor Create(AControl: TControl); override;
- destructor Destroy; override;
- procedure Assign(Source: TPersistent); override;
- published
- property Background: TBCBackground read FBackground write SetBackground;
- property Border: TBCBorder read FBorder write SetBorder;
- property FontEx: TBCFont read FFontEx write SetFontEx;
- end;
- { TCustomBCButtonFocus }
- TCustomBCButtonFocus = class(TBCStyleCustomControl)
- private
- { Private declarations }
- {$IFDEF INDEBUG}
- FRenderCount: integer;
- {$ENDIF}
- FDropDownArrowSize: integer;
- FDropDownWidth: integer;
- FFlipArrow: boolean;
- FActiveButt: TBCButtonFocusStyle;
- FBGRANormal, FBGRAHover, FBGRAClick: TBGRABitmapEx;
- FGlyphAlignment: TBCAlignment;
- FGlyphOldPlacement: boolean;
- FInnerMargin: single;
- FMemoryUsage: TBCButtonFocusMemoryUsage;
- FOnPaintButton: TNotifyEvent;
- FPreserveGlyphOnAssign: boolean;
- FRounding: TBCRounding;
- FRoundingDropDown: TBCRounding;
- FStateClicked: TBCButtonFocusState;
- FStateHover: TBCButtonFocusState;
- FStateNormal: TBCButtonFocusState;
- FDown: boolean;
- FGlyph: TBitmap;
- FGlyphMargin: integer;
- FButtonState: TBCMouseState;
- FDownButtonState: TBCMouseState;
- FOnAfterRenderBCButton: TOnAfterRenderBCButtonFocus;
- FOnButtonClick: TNotifyEvent;
- FStaticButton: boolean;
- FStyle: TBCButtonFocusStyle;
- FGlobalOpacity: byte;
- FTextApplyGlobalOpacity: boolean;
- AutoSizeExtraY: integer;
- AutoSizeExtraX: integer;
- FLastBorderWidth: integer;
- // MORA
- FClickOffset: boolean;
- FDropDownArrow: boolean;
- FDropDownMenu: TPopupMenu;
- FDropDownMenuVisible: boolean;
- FDropDownClosingTime: TDateTime;
- FDropDownPosition: TBCButtonFocusDropDownPosition;
- FDropDownStyle: TBCButtonFocusDropDownStyle;
- FImageChangeLink: TChangeLink;
- FImageIndex: integer;
- FImages: TCustomImageList;
- FSaveDropDownClosed: TNotifyEvent;
- FShowCaption: boolean;
- procedure AssignDefaultStyle;
- procedure CalculateGlyphSize(out NeededWidth, NeededHeight: integer);
- procedure DropDownClosed(Sender: TObject);
- procedure RenderAll(ANow: boolean = False);
- function GetButtonRect: TRect;
- function GetDropDownWidth(AFull: boolean = True): integer;
- function GetDropDownRect(AFull: boolean = True): TRect;
- procedure SeTBCButtonStateClicked(const AValue: TBCButtonFocusState);
- procedure SeTBCButtonStateHover(const AValue: TBCButtonFocusState);
- procedure SeTBCButtonStateNormal(const AValue: TBCButtonFocusState);
- procedure SetClickOffset(AValue: boolean);
- procedure SetDown(AValue: boolean);
- procedure SetDropDownArrow(AValue: boolean);
- procedure SetDropDownArrowSize(AValue: integer);
- procedure SetDropDownPosition(AValue: TBCButtonFocusDropDownPosition);
- procedure SetDropDownWidth(AValue: integer);
- procedure SetFlipArrow(AValue: boolean);
- procedure SetGlyph(const AValue: TBitmap);
- procedure SetGlyphAlignment(AValue: TBCAlignment);
- procedure SetGlyphMargin(const AValue: integer);
- procedure SetGlyphOldPlacement(AValue: boolean);
- procedure SetImageIndex(AValue: integer);
- procedure SetImages(AValue: TCustomImageList);
- procedure SetInnerMargin(AValue: single);
- procedure SetMemoryUsage(AValue: TBCButtonFocusMemoryUsage);
- procedure SetRounding(AValue: TBCRounding);
- procedure SetRoundingDropDown(AValue: TBCRounding);
- procedure SetShowCaption(AValue: boolean);
- procedure SetStaticButton(const AValue: boolean);
- procedure SetStyle(const AValue: TBCButtonFocusStyle);
- procedure SetGlobalOpacity(const AValue: byte);
- procedure SetTextApplyGlobalOpacity(const AValue: boolean);
- procedure UpdateSize;
- procedure OnChangeGlyph({%H-}Sender: TObject);
- procedure OnChangeState({%H-}Sender: TObject; AData: PtrInt);
- procedure ImageListChange(ASender: TObject);
- function GetGlyph: TBitmap;
- protected
- { Protected declarations }
- procedure LimitMemoryUsage;
- procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
- {%H-}WithThemeSpace: boolean); override;
- class function GetControlClassDefaultSize: TSize; override;
- procedure Click; override;
- procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
- X, Y: integer); override;
- procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
- procedure MouseEnter; override;
- procedure MouseLeave; override;
- procedure MouseMove(Shift: TShiftState; X, Y: integer); override;
- procedure SetEnabled(Value: boolean); override;
- procedure TextChanged; override;
- procedure KeyDown(var Key: word; Shift: TShiftState); override;
- procedure KeyUp(var Key: word; Shift: TShiftState); override;
- protected
- // MORA
- procedure ActionChange(Sender: TObject; CheckDefaults: boolean); override;
- function GetActionLinkClass: TControlActionLinkClass; override;
- procedure Notification(AComponent: TComponent; Operation: TOperation);
- override;
- procedure Render(ABGRA: TBGRABitmapEx; AState: TBCButtonFocusState); virtual;
- procedure RenderState(ABGRA: TBGRABitmapEx; AState: TBCButtonFocusState;
- const ARect: TRect; ARounding: TBCRounding); virtual;
- property ClickOffset: boolean read FClickOffset write SetClickOffset default False;
- property DropDownArrow: boolean
- read FDropDownArrow write SetDropDownArrow default False;
- property DropDownMenu: TPopupMenu read FDropDownMenu write FDropDownMenu;
- property DropDownStyle: TBCButtonFocusDropDownStyle
- read FDropDownStyle write FDropDownStyle default bdsSeparateF;
- property DropDownPosition: TBCButtonFocusDropDownPosition
- read FDropDownPosition write SetDropDownPosition default bdpLeftF;
- property Images: TCustomImageList read FImages write SetImages;
- property ImageIndex: integer read FImageIndex write SetImageIndex default -1;
- property ShowCaption: boolean read FShowCaption write SetShowCaption default True;
- protected
- {$IFDEF INDEBUG}
- function GetDebugText: string; override;
- {$ENDIF}
- function GetStyleExtension: string; override;
- procedure DrawControl; override;
- procedure RenderControl; override;
- protected
- procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
- procedure WMKillFocus(var Message: {$IFDEF FPC}TLMKillFocus{$ELSE}TWMKillFocus{$ENDIF}); message {$IFDEF FPC}LM_KILLFOCUS{$ELSE}WM_KILLFOCUS{$ENDIF};
- procedure UpdateFocus(AFocused: boolean);
- property AutoSizeExtraVertical: integer read AutoSizeExtraY;
- property AutoSizeExtraHorizontal: integer read AutoSizeExtraX;
- property StateNormal: TBCButtonFocusState read FStateNormal write SeTBCButtonStateNormal;
- property StateHover: TBCButtonFocusState read FStateHover write SeTBCButtonStateHover;
- property StateClicked: TBCButtonFocusState read FStateClicked
- write SeTBCButtonStateClicked;
- property Down: boolean read FDown write SetDown default False;
- property DropDownWidth: integer read FDropDownWidth write SetDropDownWidth;
- property DropDownArrowSize: integer read FDropDownArrowSize
- write SetDropDownArrowSize;
- property FlipArrow: boolean read FFlipArrow write SetFlipArrow default False;
- property Glyph: TBitmap read GetGlyph write SetGlyph;
- property GlyphMargin: integer read FGlyphMargin write SetGlyphMargin default 5;
- property GlyphAlignment: TBCAlignment read FGlyphAlignment write SetGlyphAlignment default bcaCenter;
- property GlyphOldPlacement: boolean read FGlyphOldPlacement write SetGlyphOldPlacement default true;
- property Style: TBCButtonFocusStyle read FStyle write SetStyle default bbtButtonF;
- property StaticButton: boolean
- read FStaticButton write SetStaticButton default False;
- property GlobalOpacity: byte read FGlobalOpacity write SetGlobalOpacity;
- property Rounding: TBCRounding read FRounding write SetRounding;
- property RoundingDropDown: TBCRounding read FRoundingDropDown
- write SetRoundingDropDown;
- property TextApplyGlobalOpacity: boolean
- read FTextApplyGlobalOpacity write SetTextApplyGlobalOpacity;
- property OnAfterRenderBCButton: TOnAfterRenderBCButtonFocus
- read FOnAfterRenderBCButton write FOnAfterRenderBCButton;
- property OnButtonClick: TNotifyEvent read FOnButtonClick write FOnButtonClick;
- property MemoryUsage: TBCButtonFocusMemoryUsage read FMemoryUsage write SetMemoryUsage;
- property InnerMargin: single read FInnerMargin write SetInnerMargin;
- property OnPaintButton: TNotifyEvent read FOnPaintButton write FOnPaintButton;
- property PreserveGlyphOnAssign: boolean read FPreserveGlyphOnAssign write FPreserveGlyphOnAssign default True;
- public
- { Constructor }
- constructor Create(AOwner: TComponent); override;
- { Destructor }
- destructor Destroy; override;
- { Assign the properties from Source to this instance }
- procedure Assign(Source: TPersistent); override;
- { Set dropdown size and autosize extra padding }
- procedure SetSizeVariables(newDropDownWidth, newDropDownArrowSize,
- newAutoSizeExtraVertical, newAutoSizeExtraHorizontal: integer);
- { Called by EndUpdate }
- procedure UpdateControl; override;
- public
- {$IFDEF FPC}
- { Save all published settings to file }
- procedure SaveToFile(AFileName: string);
- { Load and assign all published settings from file }
- procedure LoadFromFile(AFileName: string);
- { Assign the properties from AFileName to this instance }
- procedure AssignFromFile(AFileName: string);
- {$ENDIF}
- { Used by SaveToFile/LoadFromFile }
- procedure OnFindClass({%H-}Reader: TReader; const AClassName: string;
- var ComponentClass: TComponentClass);
- end;
- TBCButtonFocus = class(TCustomBCButtonFocus)
- private
- FBCThemeManager: TBCThemeManager;
- procedure SetFBCThemeManager(AValue: TBCThemeManager);
- published
- property Action;
- property Align;
- property Anchors;
- { Click to edit the style. Available when editing only. If you want to stream the style from a file at runtime please use LoadFromFile and SaveToFile methods. }
- property AssignStyle;
- property AutoSize;
- { The style of the button when pressed. }
- property StateClicked;
- { The style of the button when hovered. }
- property StateHover;
- { The default style of the button. }
- property StateNormal;
- property BorderSpacing;
- property Caption;
- property Color;
- property Constraints;
- { Set to True to change the button to always show a StateClicked style that will not change when button is clicked or hovered. }
- property Down;
- { The width of the dropdown arrow area. }
- property DropDownWidth;
- { The size of the dropdown arrow. }
- property DropDownArrowSize;
- property Enabled;
- { Changes the direction of the arrow. Default: False. }
- property FlipArrow;
- { Set the opacity that will be applied to the whole button. Default: 255. }
- property GlobalOpacity;
- { The glyph icon. }
- property Glyph;
- property GlyphAlignment;
- property GlyphOldPlacement;
- property PreserveGlyphOnAssign;
- { The margin of the glyph icon. }
- property GlyphMargin;
- property Hint;
- property InnerMargin;
- { Called when the button finish the render. Use it to add your own drawings to the button. }
- property OnAfterRenderBCButton;
- { Called when the button part is clicked, not the dropdown. }
- property OnButtonClick;
- property OnClick;
- property OnDblClick;
- property OnMouseDown;
- property OnMouseEnter;
- property OnMouseLeave;
- property OnMouseMove;
- property OnMouseUp;
- property OnMouseWheel;
- property OnMouseWheelDown;
- property OnMouseWheelUp;
- property ParentColor;
- property PopupMenu;
- { Change the style of the rounded corners of the button. }
- property Rounding;
- { Change the style of the rounded corners of the dropdown part of the button. }
- property RoundingDropDown;
- { Set to True to change the button to always show a StateNormal style that will not change when button is clicked or hovered. }
- property StaticButton;
- property ShowHint;
- { The style of button that will be used. bbtButton or bbtDropDownF. }
- property Style;
- { Apply the global opacity to rendered text. Default: False. }
- property TextApplyGlobalOpacity;
- property Visible;
- { -ToDo: Unused property? }
- property ClickOffset;
- { Show the dropdown arrow. }
- property DropDownArrow;
- { The dropdown menu that will be displayed when the button is pressed. }
- property DropDownMenu;
- { The kind of dropdown that will be used. bdsSeparate will show the dropdown down the dropdown arrow side. bdsCommon will show the dropdown down the whole button. }
- property DropDownStyle;
- { The position of the dropdown arrow. }
- property DropDownPosition;
- { The image list that holds an image to be used with the button ImageIndex property. }
- property Images;
- { The index of the image that will be used for the button as glyph icon if glyph property is not set. }
- property ImageIndex;
- { Show caption or hides it. Default: True. }
- property ShowCaption;
- { Limit memory usage by selecting one of the options. Default: bmuHighF. }
- property MemoryUsage;
- { The unique name of the control in the form. }
- property Name;
- { TabStop }
- property TabOrder;
- property TabStop;
- property ThemeManager: TBCThemeManager read FBCThemeManager write SetFBCThemeManager;
- property OnPaintButton;
- end;
- { TBCButtonFocusActionLink }
- TBCButtonFocusActionLink = class(TControlActionLink)
- protected
- procedure AssignClient(AClient: TObject); override;
- procedure SetChecked(Value: boolean); override;
- procedure SetImageIndex(Value: integer); override;
- public
- function IsCheckedLinked: boolean; override;
- function IsImageIndexLinked: boolean; override;
- end;
- {$IFDEF FPC}procedure Register;{$ENDIF}
- implementation
- uses {$IFDEF FPC}LCLIntf, PropEdits, LCLProc, GraphPropEdits,{$ENDIF} Math, BCTools, SysUtils;
- const
- DropDownReopenDelay = 0.2/(24*60*60);
- {$IFDEF FPC}//#
- type
- TBCButtonImageIndexPropertyEditor = class(TImageIndexPropertyEditor)
- protected
- function GetImageList: TCustomImageList; override;
- end;
- function TBCButtonImageIndexPropertyEditor.GetImageList: TCustomImageList;
- var
- Component: TPersistent;
- begin
- Component := GetComponent(0);
- if Component is TCustomBCButtonFocus then
- Result := TCustomBCButtonFocus(Component).Images
- else
- Result := nil;
- end;
- {$ENDIF}
- { TBCButtonFocus }
- procedure TBCButtonFocus.SetFBCThemeManager(AValue: TBCThemeManager);
- begin
- if FBCThemeManager=AValue then Exit;
- FBCThemeManager:=AValue;
- end;
- {$IFDEF FPC}
- procedure Register;
- begin
- RegisterComponents('BGRA Button Controls', [TBCButtonFocus]);
- {$IFDEF FPC}
- RegisterPropertyEditor(TypeInfo(integer), TBCButtonFocus,
- 'ImageIndex', TBCButtonImageIndexPropertyEditor);
- {$ENDIF}
- end;
- {$ENDIF}
- { TBCButtonFocusActionLink }
- procedure TBCButtonFocusActionLink.AssignClient(AClient: TObject);
- begin
- inherited AssignClient(AClient);
- FClient := AClient as TCustomBCButtonFocus;
- end;
- procedure TBCButtonFocusActionLink.SetChecked(Value: boolean);
- begin
- if IsCheckedLinked then
- TCustomBCButtonFocus(FClient).Down := Value;
- end;
- procedure TBCButtonFocusActionLink.SetImageIndex(Value: integer);
- begin
- if IsImageIndexLinked then
- TCustomBCButtonFocus(FClient).ImageIndex := Value;
- end;
- function TBCButtonFocusActionLink.IsCheckedLinked: boolean;
- begin
- Result := inherited IsCheckedLinked and (TCustomBCButtonFocus(FClient).Down =
- (Action as TCustomAction).Checked);
- end;
- function TBCButtonFocusActionLink.IsImageIndexLinked: boolean;
- begin
- Result := inherited IsImageIndexLinked and
- (TCustomBCButtonFocus(FClient).ImageIndex = (Action as TCustomAction).ImageIndex);
- end;
- { TBCButtonFocusState }
- procedure TBCButtonFocusState.SetFontEx(const AValue: TBCFont);
- begin
- if FFontEx = AValue then
- exit;
- FFontEx.Assign(AValue);
- Change;
- end;
- procedure TBCButtonFocusState.OnChangeFont(Sender: TObject; AData: PtrInt);
- begin
- Change(PtrInt(pdUpdateSizeF));
- end;
- procedure TBCButtonFocusState.OnChangeChildProperty(Sender: TObject; AData: PtrInt);
- begin
- Change(AData);
- end;
- procedure TBCButtonFocusState.SetBackground(AValue: TBCBackground);
- begin
- if FBackground = AValue then
- Exit;
- FBackground.Assign(AValue);
- Change;
- end;
- procedure TBCButtonFocusState.SetBorder(AValue: TBCBorder);
- begin
- if FBorder = AValue then
- Exit;
- FBorder.Assign(AValue);
- Change;
- end;
- constructor TBCButtonFocusState.Create(AControl: TControl);
- begin
- FBackground := TBCBackground.Create(AControl);
- FBorder := TBCBorder.Create(AControl);
- FFontEx := TBCFont.Create(AControl);
- FBackground.OnChange := OnChangeChildProperty;
- FBorder.OnChange := OnChangeChildProperty;
- FFontEx.OnChange := OnChangeFont;
- inherited Create(AControl);
- end;
- destructor TBCButtonFocusState.Destroy;
- begin
- FBackground.Free;
- FBorder.Free;
- FFontEx.Free;
- inherited Destroy;
- end;
- procedure TBCButtonFocusState.Assign(Source: TPersistent);
- begin
- if Source is TBCButtonFocusState then
- begin
- FBackground.Assign(TBCButtonFocusState(Source).FBackground);
- FBorder.Assign(TBCButtonFocusState(Source).FBorder);
- FFontEx.Assign(TBCButtonFocusState(Source).FFontEx);
- Change(PtrInt(pdUpdateSizeF));
- end
- else
- inherited Assign(Source);
- end;
- { TCustomBCButtonFocus }
- procedure TCustomBCButtonFocus.AssignDefaultStyle;
- begin
- FRounding.RoundX := 12;
- FRounding.RoundY := 12;
- // Normal
- with StateNormal do
- begin
- Border.Style := bboNone;
- FontEx.Color := RGBToColor(230, 230, 255);
- FontEx.Style := [fsBold];
- FontEx.Shadow := True;
- FontEx.ShadowOffsetX := 1;
- FontEx.ShadowOffsetY := 1;
- FontEx.ShadowRadius := 2;
- Background.Gradient1EndPercent := 60;
- Background.Style := bbsGradient;
- // Gradient1
- with Background.Gradient1 do
- begin
- EndColor := RGBToColor(64, 64, 128);
- StartColor := RGBToColor(0, 0, 64);
- end;
- // Gradient2
- with Background.Gradient2 do
- begin
- EndColor := RGBToColor(0, 0, 64);
- GradientType := gtRadial;
- Point1XPercent := 50;
- Point1YPercent := 100;
- Point2YPercent := 0;
- StartColor := RGBToColor(64, 64, 128);
- end;
- end;
- // Hover
- with StateHover do
- begin
- Border.Style := bboNone;
- FontEx.Color := RGBToColor(255, 255, 255);
- FontEx.Style := [fsBold];
- FontEx.Shadow := True;
- FontEx.ShadowOffsetX := 1;
- FontEx.ShadowOffsetY := 1;
- FontEx.ShadowRadius := 2;
- Background.Gradient1EndPercent := 100;
- Background.Style := bbsGradient;
- // Gradient1
- with Background.Gradient1 do
- begin
- EndColor := RGBToColor(0, 64, 128);
- GradientType := gtRadial;
- Point1XPercent := 50;
- Point1YPercent := 100;
- Point2YPercent := 0;
- StartColor := RGBToColor(0, 128, 255);
- end;
- end;
- // Clicked
- with StateClicked do
- begin
- Border.Style := bboNone;
- FontEx.Color := RGBToColor(230, 230, 255);
- FontEx.Style := [fsBold];
- FontEx.Shadow := True;
- FontEx.ShadowOffsetX := 1;
- FontEx.ShadowOffsetY := 1;
- FontEx.ShadowRadius := 2;
- Background.Gradient1EndPercent := 100;
- Background.Style := bbsGradient;
- // Gradient1
- with Background.Gradient1 do
- begin
- EndColor := RGBToColor(0, 0, 64);
- GradientType := gtRadial;
- Point1XPercent := 50;
- Point1YPercent := 100;
- Point2YPercent := 0;
- StartColor := RGBToColor(0, 64, 128);
- end;
- end;
- end;
- procedure TCustomBCButtonFocus.CalculateGlyphSize(out NeededWidth, NeededHeight: integer);
- begin
- if Assigned(FGlyph) and not FGlyph.Empty then
- begin
- NeededWidth := FGlyph.Width;
- NeededHeight := FGlyph.Height;
- end
- else
- if Assigned(FImages) then
- begin
- NeededWidth := FImages.Width;
- NeededHeight := FImages.Height;
- end
- else
- begin
- NeededHeight := 0;
- NeededWidth := 0;
- end;
- end;
- procedure TCustomBCButtonFocus.RenderAll(ANow: boolean);
- begin
- if (csCreating in ControlState) or IsUpdating or (FBGRANormal = nil) then
- Exit;
- if ANow then
- begin
- Render(FBGRANormal, FStateNormal);
- Render(FBGRAHover, FStateHover);
- Render(FBGRAClick, FStateClicked);
- end
- else
- begin
- FBGRANormal.NeedRender := True;
- FBGRAHover.NeedRender := True;
- FBGRAClick.NeedRender := True;
- end;
- end;
- function TCustomBCButtonFocus.GetButtonRect: TRect;
- begin
- Result := GetClientRect;
- if FStyle = bbtDropDownF then
- case FDropDownPosition of
- bdpBottomF:
- Dec(Result.Bottom, GetDropDownWidth(False));
- else
- // bdpLeft:
- Dec(Result.Right, GetDropDownWidth(False));
- end;
- end;
- function TCustomBCButtonFocus.GetDropDownWidth(AFull: boolean): integer;
- begin
- Result := FDropDownWidth + (ifthen(AFull, 2, 1) * FStateNormal.FBorder.Width);
- end;
- function TCustomBCButtonFocus.GetGlyph: TBitmap;
- begin
- Result := FGlyph as TBitmap;
- end;
- function TCustomBCButtonFocus.GetDropDownRect(AFull: boolean): TRect;
- begin
- Result := GetClientRect;
- case FDropDownPosition of
- bdpBottomF:
- Result.Top := Result.Bottom - GetDropDownWidth(AFull);
- else
- // bdpLeft:
- Result.Left := Result.Right - GetDropDownWidth(AFull);
- end;
- end;
- procedure TCustomBCButtonFocus.Render(ABGRA: TBGRABitmapEx; AState: TBCButtonFocusState);
- function GetActualGlyph: TBitmap;
- begin
- if Assigned(FGlyph) and not FGlyph.Empty then result := FGlyph else
- if Assigned(FImages) and (FImageIndex > -1) and (FImageIndex < FImages.Count) then
- begin
- result := TBitmap.Create;
- {$IFDEF FPC}
- FImages.GetBitmap(FImageIndex, result);
- {$ELSE}
- FImages.GetBitmapRaw(FImageIndex, result);
- {$ENDIF}
- end else exit(nil);
- end;
- procedure RenderGlyph(ARect: TRect; AGlyph: TBitmap);
- begin
- if ARect.IsEmpty or (AGlyph = nil) then exit;
- ABGRA.PutImage(ARect.Left, ARect.Top, AGlyph, dmLinearBlend);
- end;
- var
- r, r_a, r_g: TRect;
- g: TBitmap;
- actualCaption: TCaption;
- begin
- if (csCreating in ControlState) or IsUpdating then
- Exit;
- ABGRA.NeedRender := False;
- { Refreshing size }
- ABGRA.SetSize(Width, Height);
- { Clearing previous paint }
- ABGRA.Fill(BGRAPixelTransparent);
- { Basic body }
- r := GetButtonRect;
- RenderState(ABGRA, AState, r, FRounding);
- if not GlyphOldPlacement then
- r.Inflate(-round(InnerMargin),-round(InnerMargin));
- { Calculating rect }
- CalculateBorderRect(AState.Border, r);
- if FStyle = bbtDropDownF then
- begin
- r_a := GetDropDownRect;
- RenderState(ABGRA, AState, r_a, FRoundingDropDown);
- CalculateBorderRect(AState.Border, r_a);
- // Click offset for arrow
- if FClickOffset and (AState = FStateClicked) then
- r_a.Offset(1,1);
- if FFlipArrow then
- RenderArrow(TBGRABitmap(ABGRA), r_a, FDropDownArrowSize, badUp,
- AState.FontEx.Color)
- else
- RenderArrow(TBGRABitmap(ABGRA), r_a, FDropDownArrowSize, badDown,
- AState.FontEx.Color);
- end;
- // Click offset for text and glyph
- if FClickOffset and (AState = FStateClicked) then
- r.Offset(1,1);
- // DropDown arrow
- if FDropDownArrow and (FStyle <> bbtDropDownF) then
- begin
- r_a := r;
- r_a.Left := r_a.Right - FDropDownWidth;
- if FFlipArrow then
- RenderArrow(TBGRABitmap(ABGRA), r_a, FDropDownArrowSize, badUp,
- AState.FontEx.Color)
- else
- RenderArrow(TBGRABitmap(ABGRA), r_a, FDropDownArrowSize, badDown,
- AState.FontEx.Color);
- Dec(R.Right, FDropDownWidth);
- end;
- g := GetActualGlyph;
- if FShowCaption then actualCaption := self.Caption else actualCaption := '';
- r_g := ComputeGlyphPosition(r, g, GlyphAlignment, GlyphMargin, actualCaption, AState.FontEx, GlyphOldPlacement);
- if FTextApplyGlobalOpacity then
- begin
- { Drawing text }
- RenderText(r, AState.FontEx, actualCaption, ABGRA, Enabled);
- RenderGlyph(r_g, g);
- { Set global opacity }
- ABGRA.ApplyGlobalOpacity(FGlobalOpacity);
- end
- else
- begin
- { Set global opacity }
- ABGRA.ApplyGlobalOpacity(FGlobalOpacity);
- { Drawing text }
- RenderText(r, AState.FontEx, actualCaption, ABGRA, Enabled);
- RenderGlyph(r_g, g);
- end;
- if g <> FGlyph then g.Free;
- { Convert to gray if not enabled }
- if not Enabled then ABGRA.InplaceGrayscale;
- if Assigned(FOnAfterRenderBCButton) then
- FOnAfterRenderBCButton(Self, ABGRA, AState, r);
- {$IFDEF INDEBUG}
- FRenderCount := FRenderCount +1;
- {$ENDIF}
- end;
- procedure TCustomBCButtonFocus.RenderState(ABGRA: TBGRABitmapEx;
- AState: TBCButtonFocusState; const ARect: TRect; ARounding: TBCRounding);
- begin
- RenderBackgroundAndBorder(ARect, AState.FBackground, TBGRABitmap(ABGRA),
- ARounding, AState.FBorder, FInnerMargin);
- end;
- procedure TCustomBCButtonFocus.OnChangeGlyph(Sender: TObject);
- begin
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.OnChangeState(Sender: TObject; AData: PtrInt);
- begin
- RenderControl;
- if (TBCButtonFocusPropertyData(AData) = pdUpdateSizeF) or
- (FStateNormal.Border.Width <> FLastBorderWidth) then
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.ImageListChange(ASender: TObject);
- begin
- if ASender = Images then
- begin
- RenderControl;
- Invalidate;
- end;
- end;
- procedure TCustomBCButtonFocus.LimitMemoryUsage;
- begin
- {$IFNDEF FPC}//# //@ IN DELPHI NEEDRENDER NEDD TO BE TRUE. IF FALSE COMPONENT IN BGRANORMAL BE BLACK AFTER INVALIDATE.
- if Assigned(FBGRAHover) then FBGRANormal.NeedRender := True;
- if Assigned(FBGRAHover) then FBGRAHover.NeedRender := True;
- if Assigned(FBGRAClick) then FBGRAClick.NeedRender := True;
- {$ENDIF}
- if (FMemoryUsage = bmuLowF) and Assigned(FBGRANormal) then FBGRANormal.Discard;
- if (FMemoryUsage <> bmuHighF) then
- begin
- if Assigned(FBGRAHover) then FBGRAHover.Discard;
- if Assigned(FBGRAClick) then FBGRAClick.Discard;
- end;
- end;
- procedure TCustomBCButtonFocus.SeTBCButtonStateClicked(const AValue: TBCButtonFocusState);
- begin
- if FStateClicked = AValue then
- exit;
- FStateClicked.Assign(AValue);
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SeTBCButtonStateHover(const AValue: TBCButtonFocusState);
- begin
- if FStateHover = AValue then
- exit;
- FStateHover.Assign(AValue);
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SeTBCButtonStateNormal(const AValue: TBCButtonFocusState);
- begin
- if FStateNormal = AValue then
- exit;
- FStateNormal.Assign(AValue);
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetClickOffset(AValue: boolean);
- begin
- if FClickOffset = AValue then
- Exit;
- FClickOffset := AValue;
- RenderControl;
- end;
- procedure TCustomBCButtonFocus.SetDown(AValue: boolean);
- begin
- if FDown = AValue then
- exit;
- FDown := AValue;
- if FDown then
- FButtonState := msClicked
- else
- FButtonState := msNone;
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetDropDownArrow(AValue: boolean);
- begin
- if FDropDownArrow = AValue then
- Exit;
- FDropDownArrow := AValue;
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetDropDownArrowSize(AValue: integer);
- begin
- if FDropDownArrowSize = AValue then
- Exit;
- FDropDownArrowSize := AValue;
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetDropDownPosition(AValue: TBCButtonFocusDropDownPosition);
- begin
- if FDropDownPosition = AValue then
- Exit;
- FDropDownPosition := AValue;
- if FStyle <> bbtDropDownF then
- Exit;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetDropDownWidth(AValue: integer);
- begin
- if FDropDownWidth = AValue then
- Exit;
- FDropDownWidth := AValue;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetFlipArrow(AValue: boolean);
- begin
- if FFlipArrow = AValue then
- Exit;
- FFlipArrow := AValue;
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetGlyph(const AValue: TBitmap);
- begin
- if (FGlyph <> nil) and (FGlyph = AValue) then
- exit;
- FGlyph.Assign(AValue);
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetGlyphAlignment(AValue: TBCAlignment);
- begin
- if FGlyphAlignment=AValue then Exit;
- FGlyphAlignment:=AValue;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetGlyphMargin(const AValue: integer);
- begin
- if FGlyphMargin = AValue then
- exit;
- FGlyphMargin := AValue;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetGlyphOldPlacement(AValue: boolean);
- begin
- if FGlyphOldPlacement=AValue then Exit;
- FGlyphOldPlacement:=AValue;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetImageIndex(AValue: integer);
- begin
- if FImageIndex = AValue then
- Exit;
- FImageIndex := AValue;
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetImages(AValue: TCustomImageList);
- begin
- if FImages = AValue then
- Exit;
- FImages := AValue;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetInnerMargin(AValue: single);
- begin
- if FInnerMargin=AValue then Exit;
- FInnerMargin:=AValue;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetMemoryUsage(AValue: TBCButtonFocusMemoryUsage);
- begin
- if FMemoryUsage=AValue then Exit;
- FMemoryUsage:=AValue;
- LimitMemoryUsage;
- end;
- procedure TCustomBCButtonFocus.SetRounding(AValue: TBCRounding);
- begin
- if FRounding = AValue then
- Exit;
- FRounding.Assign(AValue);
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetRoundingDropDown(AValue: TBCRounding);
- begin
- if FRoundingDropDown = AValue then
- Exit;
- FRoundingDropDown.Assign(AValue);
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetShowCaption(AValue: boolean);
- begin
- if FShowCaption = AValue then
- Exit;
- FShowCaption := AValue;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetStaticButton(const AValue: boolean);
- begin
- if FStaticButton = AValue then
- exit;
- FStaticButton := AValue;
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetStyle(const AValue: TBCButtonFocusStyle);
- begin
- if FStyle = AValue then
- exit;
- FStyle := AValue;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.UpdateSize;
- begin
- InvalidatePreferredSize;
- AdjustSize;
- end;
- procedure TCustomBCButtonFocus.CalculatePreferredSize(
- var PreferredWidth, PreferredHeight: integer; WithThemeSpace: boolean);
- var
- // AWidth: integer;
- gh,gw: integer;
- actualCaption: TCaption;
- horizAlign, relHorizAlign: TAlignment;
- vertAlign, relVertAlign: TTextLayout;
- glyphHorzMargin, glyphVertMargin: integer;
- tw, th, availW: integer;
- begin
- gh := 0;
- gw := 0;
- if (Parent = nil) or (not Parent.HandleAllocated) then
- Exit;
- { if WidthIsAnchored then
- AWidth := Width
- else
- AWidth := 10000;}
- FLastBorderWidth := FStateNormal.Border.Width;
- CalculateGlyphSize(gw, gh);
- if GlyphOldPlacement then
- begin
- { if WidthIsAnchored then
- AWidth := Width
- else
- AWidth := 10000;}
- PreferredWidth := 0;
- PreferredHeight := 0;
- if FShowCaption then
- CalculateTextSize(Caption, FStateNormal.FontEx, PreferredWidth, PreferredHeight);
- // Extra pixels for DropDown
- if Style = bbtDropDownF then
- if FDropDownPosition in [bdpBottomF] then
- Inc(PreferredHeight, GetDropDownWidth)
- else
- Inc(PreferredWidth, GetDropDownWidth);
- if (Style = bbtButtonF) and FDropDownArrow then
- Inc(PreferredWidth, FDropDownArrowSize);// GetDropDownWidth);
- //if (FGlyph <> nil) and (not FGlyph.Empty) then
- if (gw > 0) and (gh > 0) then
- begin
- //if Caption = '' then
- if PreferredWidth = 0 then
- begin
- Inc(PreferredWidth, gw{ - AutoSizeExtraY * 2});
- Inc(PreferredHeight, gh);
- end
- else
- begin
- Inc(PreferredWidth, gw + FGlyphMargin);
- if gh > PreferredHeight then
- PreferredHeight := gh;
- end;
- end;
- // Extra pixels for AutoSize
- Inc(PreferredWidth, AutoSizeExtraX);
- Inc(PreferredHeight, AutoSizeExtraY);
- end else
- begin
- if ShowCaption then actualCaption := Caption else actualCaption := '';
- PreferredWidth := round(InnerMargin);
- PreferredHeight := round(InnerMargin);
- case FStyle of
- bbtDropDownF:
- case FDropDownPosition of
- bdpBottomF: inc(PreferredHeight, GetDropDownWidth(False));
- else{bdpLeft} inc(PreferredWidth, GetDropDownWidth(False));
- end;
- else{bbtButton} if FDropDownArrow then
- inc(PreferredWidth, FDropDownWidth);
- end;
- inc(PreferredWidth, FStateNormal.Border.Width);
- inc(PreferredHeight, FStateNormal.Border.Width);
- if actualCaption='' then
- begin
- inc(PreferredWidth,gw);
- inc(PreferredHeight,gh);
- if gw>0 then inc(PreferredWidth, GlyphMargin*2);
- if gh>0 then inc(PreferredHeight, GlyphMargin*2);
- end else
- begin
- GetGlyphActualLayout(actualCaption, FStateNormal.FontEx, GlyphAlignment, GlyphMargin,
- horizAlign, vertAlign, relHorizAlign, relVertAlign, glyphHorzMargin, glyphVertMargin);
- availW := 65535;
- if (Align in [alTop,alBottom]) and (Parent <> nil) then
- availW := Parent.ClientWidth - PreferredWidth;
- CalculateTextSizeEx(actualCaption, FStateNormal.FontEx, tw, th, availW);
- if (tw<>0) and FStateNormal.FontEx.WordBreak then inc(tw);
- if vertAlign<>relVertAlign then
- begin
- inc(PreferredWidth, max(gw+2*GlyphMargin,tw));
- inc(PreferredHeight, GlyphMargin+gh+th);
- end
- else
- begin
- inc(PreferredWidth, GlyphMargin+gw+tw);
- inc(PreferredHeight, max(gh+2*GlyphMargin,th));
- end;
- end;
- end;
- // Extra pixels for AutoSize
- Inc(PreferredWidth, AutoSizeExtraX);
- Inc(PreferredHeight, AutoSizeExtraY);
- end;
- class function TCustomBCButtonFocus.GetControlClassDefaultSize: TSize;
- begin
- Result.CX := 123;
- Result.CY := 33;
- end;
- procedure TCustomBCButtonFocus.Click;
- begin
- if (FActiveButt = bbtDropDownF) and Assigned(FOnButtonClick) then
- begin
- FOnButtonClick(Self);
- Exit;
- end;
- inherited Click;
- end;
- procedure TCustomBCButtonFocus.DropDownClosed(Sender: TObject);
- begin
- if Assigned(FSaveDropDownClosed) then
- FSaveDropDownClosed(Sender);
- {$IFDEF FPC}
- if Assigned(FDropDownMenu) then
- FDropDownMenu.OnClose := FSaveDropDownClosed;
- {$ENDIF}
- // MORA: DropDownMenu is still visible if mouse is over control
- FDropDownMenuVisible := {$IFNDEF FPC}BGRAGraphics.{$ENDIF}PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos));
- FDropDownClosingTime := Now;
- end;
- procedure TCustomBCButtonFocus.MouseDown(Button: TMouseButton; Shift: TShiftState;
- X, Y: integer);
- var
- ClientToScreenPoint : TPoint;
- begin
- inherited MouseDown(Button, Shift, X, Y);
- if csDesigning in ComponentState then
- exit;
- if CanFocus() then SetFocus();
- if (Button = mbLeft) and Enabled {and (not (FButtonState = msClicked)) } then
- begin
- case FActiveButt of
- bbtButtonF:
- if not (FButtonState = msClicked) then
- begin
- FButtonState := msClicked;
- if FDropDownStyle = bdsCommonF then
- FDownButtonState := msClicked
- else
- FDownButtonState := msNone;
- Invalidate;
- end;
- bbtDropDownF:
- if not (FDownButtonState = msClicked) then
- begin
- if FDropDownStyle = bdsCommonF then
- FButtonState := msClicked
- else
- FButtonState := msNone;
- FDownButtonState := msClicked;
- Invalidate;
- end;
- end;
- // Old
- {FButtonState := msClicked;
- Invalidate;}
- // MORA: Show DropDown menu
- if FDropDownMenuVisible or (Now < FDropDownClosingTime+DropDownReopenDelay) then
- FDropDownMenuVisible := False // Prevent redropping
- else
- if ((FActiveButt = bbtDropDownF) or (FStyle = bbtButtonF)) and
- (FDropDownMenu <> nil) and Enabled then
- begin
- ClientToScreenPoint := ClientToScreen(Point(0, Height));
- with ClientToScreenPoint do
- begin
- // normal button
- if FStyle = bbtButtonF then
- begin
- x := x + Width * integer(FDropDownMenu.Alignment = paRight);
- if FFlipArrow then
- y := y -Height;
- end
- else
- // dropdown button
- begin
- if FDropDownPosition = bdpBottomF then
- begin
- x := x + Width * integer(FDropDownMenu.Alignment = paRight);
- if FFlipArrow then
- y := y -(FDropDownWidth + (FStateNormal.FBorder.Width * 2));
- end
- else
- begin
- if FFlipArrow then
- y := y -Height;
- if FDropDownStyle = bdsSeparateF then
- x := x + Width - (FDropDownWidth + (FStateNormal.FBorder.Width * 2)) *
- integer(FDropDownMenu.Alignment <> paRight)
- else
- x := x + Width * integer(FDropDownMenu.Alignment = paRight);
- end;
- end;
- FDropDownMenuVisible := True;
- {$IFDEF FPC}
- FSaveDropDownClosed := FDropDownMenu.OnClose;
- FDropDownMenu.OnClose := DropDownClosed;
- {$ENDIF}
- FDropDownMenu.PopUp(x, y);
- end;
- end;
- end;
- end;
- procedure TCustomBCButtonFocus.MouseUp(Button: TMouseButton; Shift: TShiftState;
- X, Y: integer);
- {var
- p: TPoint;}
- begin
- inherited MouseUp(Button, Shift, X, Y);
- if csDesigning in ComponentState then
- exit;
- if (Button = mbLeft) and Enabled {and (FButtonState = msClicked)} then
- begin
- case FActiveButt of
- bbtButtonF:
- if FButtonState = msClicked then
- begin
- FButtonState := msHover;
- if FDropDownStyle = bdsCommonF then
- FDownButtonState := msHover
- else
- FDownButtonState := msNone;
- Invalidate;
- end;
- bbtDropDownF:
- if FDownButtonState = msClicked then
- begin
- FDownButtonState := msHover;
- if FDropDownStyle = bdsCommonF then
- FButtonState := msHover
- else
- FButtonState := msNone;
- Invalidate;
- end;
- end;
- // Old
- {FButtonState := msHover;
- Invalidate;}
- end;
- //if (FActiveButt = bbtDropDownF) and (PopupMenu <> nil) and Enabled then
- //begin
- // if FFlipArrow then
- // p := ClientToScreen(Point(Width - FDropDownWidth - (FStateNormal.FBorder.Width * 2),
- // {PopupMenu.Height} -1))
- // else
- // p := ClientToScreen(Point(Width - FDropDownWidth - (FStateNormal.FBorder.Width * 2), Height + 1));
- // PopupMenu.PopUp(p.x, p.y);
- //end;
- end;
- procedure TCustomBCButtonFocus.MouseEnter;
- begin
- if csDesigning in ComponentState then
- exit;
- case FActiveButt of
- bbtButtonF:
- begin
- if FDown then
- FButtonState := msClicked
- else
- FButtonState := msHover;
- if FDropDownStyle = bdsSeparateF then
- FDownButtonState := msNone
- else
- FDownButtonState := msHover;
- end;
- bbtDropDownF:
- begin
- if FDown then
- FButtonState := msClicked
- else
- if FDropDownStyle = bdsSeparateF then
- FButtonState := msNone
- else
- FButtonState := msHover;
- FDownButtonState := msHover;
- end;
- end;
- Invalidate;
- // Old
- {FButtonState := msHover;
- Invalidate;}
- {$IFDEF FPC}
- inherited MouseEnter;
- {$ENDIF}
- end;
- procedure TCustomBCButtonFocus.MouseLeave;
- begin
- if csDesigning in ComponentState then
- exit;
- if FDown then
- begin
- FButtonState := msClicked;
- FActiveButt := bbtButtonF;
- end
- else
- FButtonState := msNone;
- FDownButtonState := msNone;
- Invalidate;
- {$IFDEF FPC} //#
- inherited MouseLeave;
- {$ENDIF}
- end;
- procedure TCustomBCButtonFocus.MouseMove(Shift: TShiftState; X, Y: integer);
- function IsOverDropDown: boolean;
- begin
- with GetButtonRect do
- case FDropDownPosition of
- bdpBottomF:
- Result := Y > Bottom;
- else
- Result := X > GetButtonRect.Right;
- end;
- end;
- begin
- inherited MouseMove(Shift, X, Y);
- if FStyle = bbtButtonF then
- FActiveButt := bbtButtonF
- else
- begin
- // Calling invalidate only when active button changed. Otherwise, we leave
- // this for LCL. This reduce paint call
- if (FActiveButt = bbtButtonF) and IsOverDropDown then
- begin
- FActiveButt := bbtDropDownF;
- if FDropDownStyle <> bdsCommonF then // Don't need invalidating
- begin
- FDownButtonState := msHover;
- if FDown then
- FButtonState := msClicked
- else
- FButtonState := msNone;
- Invalidate;
- end;
- end
- else
- if (FActiveButt = bbtDropDownF) and not IsOverDropDown then
- begin
- FActiveButt := bbtButtonF;
- if FDropDownStyle <> bdsCommonF then // Don't need invalidating
- begin
- if FDown then
- FButtonState := msClicked
- else
- FButtonState := msHover;
- FDownButtonState := msNone;
- Invalidate;
- end;
- end;
- end;
- end;
- procedure TCustomBCButtonFocus.SetEnabled(Value: boolean);
- begin
- inherited SetEnabled(Value);
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.TextChanged;
- begin
- {$IFDEF FPC}
- inherited TextChanged;
- {$ENDIF}
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.KeyDown(var Key: word; Shift: TShiftState);
- begin
- inherited KeyDown(Key, Shift);
- if (Key = VK_SPACE) or (Key = VK_RETURN) then
- MouseDown(mbLeft, [], 0, 0);
- end;
- procedure TCustomBCButtonFocus.KeyUp(var Key: word; Shift: TShiftState);
- begin
- if (Key = VK_SPACE) or (Key = VK_RETURN) then
- begin
- MouseLeave;
- Self.Click;
- end;
- inherited KeyUp(Key, Shift);
- end;
- procedure TCustomBCButtonFocus.ActionChange(Sender: TObject; CheckDefaults: boolean);
- var
- NewAction: TCustomAction;
- begin
- inherited ActionChange(Sender, CheckDefaults);
- if Sender is TCustomAction then
- begin
- NewAction := TCustomAction(Sender);
- if (not CheckDefaults) or (not Down) then
- Down := NewAction.Checked;
- if (not CheckDefaults) or (ImageIndex < 0) then
- ImageIndex := NewAction.ImageIndex;
- end;
- end;
- function TCustomBCButtonFocus.GetActionLinkClass: TControlActionLinkClass;
- begin
- Result := TBCButtonFocusActionLink;
- end;
- procedure TCustomBCButtonFocus.Notification(AComponent: TComponent; Operation: TOperation);
- begin
- inherited Notification(AComponent, Operation);
- if (AComponent = FImages) and (Operation = opRemove) then
- Images := nil;
- end;
- procedure TCustomBCButtonFocus.UpdateControl;
- begin
- RenderControl;
- inherited UpdateControl; // indalidate
- end;
- {$IFDEF FPC}
- procedure TCustomBCButtonFocus.SaveToFile(AFileName: string);
- var
- AStream: TMemoryStream;
- begin
- AStream := TMemoryStream.Create;
- try
- WriteComponentAsTextToStream(AStream, Self);
- AStream.SaveToFile(AFileName);
- finally
- AStream.Free;
- end;
- end;
- procedure TCustomBCButtonFocus.LoadFromFile(AFileName: string);
- var
- AStream: TMemoryStream;
- begin
- AStream := TMemoryStream.Create;
- try
- AStream.LoadFromFile(AFileName);
- ReadComponentFromTextStream(AStream, TComponent(Self), OnFindClass);
- finally
- AStream.Free;
- end;
- end;
- procedure TCustomBCButtonFocus.AssignFromFile(AFileName: string);
- var
- AStream: TMemoryStream;
- AButton: TBCButtonFocus;
- begin
- AButton := TBCButtonFocus.Create(nil);
- AStream := TMemoryStream.Create;
- try
- AStream.LoadFromFile(AFileName);
- ReadComponentFromTextStream(AStream, TComponent(AButton), OnFindClass);
- Assign(AButton);
- finally
- AStream.Free;
- AButton.Free;
- end;
- end;
- {$ENDIF}
- procedure TCustomBCButtonFocus.OnFindClass(Reader: TReader; const AClassName: string;
- var ComponentClass: TComponentClass);
- begin
- if CompareText(AClassName, 'TBCButton') = 0 then
- ComponentClass := TBCButtonFocus;
- end;
- {$IFDEF INDEBUG}
- function TCustomBCButtonFocus.GetDebugText: string;
- begin
- Result := 'R: ' + IntToStr(FRenderCount);
- end;
- {$ENDIF}
- procedure TCustomBCButtonFocus.DrawControl;
- var
- bgra: TBGRABitmapEx;
- begin
- // If style is without dropdown button or state of each button
- // is the same (possible only for msNone) or static button then
- // we can draw whole BGRABitmap
- if (FStyle = bbtButtonF) or (FButtonState = FDownButtonState) or FStaticButton then
- begin
- // Main button
- if FStaticButton then
- bgra := FBGRANormal
- else
- if FDown then
- bgra := FBGRAClick
- else
- case FButtonState of
- msNone: bgra := FBGRANormal;
- msHover: bgra := FBGRAHover;
- msClicked: bgra := FBGRAClick;
- end;
- if {%H-}bgra.NeedRender then
- Render(bgra, TBCButtonFocusState(bgra.CustomData));
- bgra.Draw(Self.Canvas, 0, 0, False);
- end
- // Otherwise we must draw part of state for each button
- else
- begin
- // The active button must be draw as last because right edge of button and
- // left edge of dropdown are overlapping each other, so we must draw edge
- // for current state of active button
- case FActiveButt of
- bbtButtonF:
- begin
- // Drop down button
- case FDownButtonState of
- msNone: bgra := FBGRANormal;
- msHover: bgra := FBGRAHover;
- msClicked: bgra := FBGRAClick;
- end;
- if bgra.NeedRender then
- Render(bgra, TBCButtonFocusState(bgra.CustomData));
- bgra.DrawPart(GetDropDownRect, Self.Canvas, GetDropDownRect.Left,
- GetDropDownRect.Top, False);
- // Main button
- if FDown then
- bgra := FBGRAClick
- else
- case FButtonState of
- msNone: bgra := FBGRANormal;
- msHover: bgra := FBGRAHover;
- msClicked: bgra := FBGRAClick;
- end;
- if bgra.NeedRender then
- Render(bgra, TBCButtonFocusState(bgra.CustomData));
- bgra.DrawPart(GetButtonRect, Self.Canvas, 0, 0, False);
- end;
- bbtDropDownF:
- begin
- // Main button
- if FDown then
- bgra := FBGRAClick
- else
- case FButtonState of
- msNone: bgra := FBGRANormal;
- msHover: bgra := FBGRAHover;
- msClicked: bgra := FBGRAClick;
- end;
- if bgra.NeedRender then
- Render(bgra, TBCButtonFocusState(bgra.CustomData));
- bgra.DrawPart(GetButtonRect, Self.Canvas, 0, 0, False);
- // Drop down button
- case FDownButtonState of
- msNone: bgra := FBGRANormal;
- msHover: bgra := FBGRAHover;
- msClicked: bgra := FBGRAClick;
- end;
- if bgra.NeedRender then
- Render(bgra, TBCButtonFocusState(bgra.CustomData));
- bgra.DrawPart(GetDropDownRect, Self.Canvas, GetDropDownRect.Left,
- GetDropDownRect.Top, False);
- end;
- end;
- end;
- if Assigned(FOnPaintButton) then
- FOnPaintButton(Self);
- LimitMemoryUsage;
- end;
- procedure TCustomBCButtonFocus.RenderControl;
- begin
- inherited RenderControl;
- RenderAll;
- end;
- procedure TCustomBCButtonFocus.WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF});
- begin
- inherited;
- UpdateFocus(True);
- end;
- procedure TCustomBCButtonFocus.WMKillFocus(var Message: {$IFDEF FPC}TLMKillFocus{$ELSE}TWMKillFocus{$ENDIF});
- begin
- inherited;
- if Message.FocusedWnd <> Handle then
- UpdateFocus(False);
- end;
- procedure TCustomBCButtonFocus.UpdateFocus(AFocused: boolean);
- var
- lForm: TCustomForm;
- begin
- lForm := GetParentForm(Self);
- if lForm = nil then
- exit;
- {$IFDEF FPC}//#
- if AFocused then
- ActiveDefaultControlChanged(lForm.ActiveControl)
- else
- ActiveDefaultControlChanged(nil);
- {$ENDIF}
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetGlobalOpacity(const AValue: byte);
- begin
- if FGlobalOpacity = AValue then
- exit;
- FGlobalOpacity := AValue;
- RenderControl;
- Invalidate;
- end;
- procedure TCustomBCButtonFocus.SetTextApplyGlobalOpacity(const AValue: boolean);
- begin
- if FTextApplyGlobalOpacity = AValue then
- exit;
- FTextApplyGlobalOpacity := AValue;
- RenderControl;
- Invalidate;
- end;
- constructor TCustomBCButtonFocus.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- ControlStyle := ControlStyle + [csParentBackground];
- {$IFDEF INDEBUG}
- FRenderCount := 0;
- {$ENDIF}
- FMemoryUsage := bmuHighF;
- {$IFDEF FPC}
- DisableAutoSizing;
- Include(FControlState, csCreating);
- {$ELSE} //#
- {$ENDIF}
- //{$IFDEF WINDOWS}
- // default sizes under different dpi settings
- //SetSizeVariables(ScaleX(8,96), ScaleX(16,96), ScaleY(8,96), ScaleX(24,96));
- //{$ELSE}
- // default sizes
- SetSizeVariables(16, 8, 8, 24);
- //{$ENDIF}
- BeginUpdate;
- try
- with GetControlClassDefaultSize do
- SetInitialBounds(0, 0, CX, CY);
- ControlStyle := ControlStyle + [csAcceptsControls];
- FBGRANormal := TBGRABitmapEx.Create(Width, Height, BGRAPixelTransparent);
- FBGRAHover := TBGRABitmapEx.Create(Width, Height, BGRAPixelTransparent);
- FBGRAClick := TBGRABitmapEx.Create(Width, Height, BGRAPixelTransparent);
- ParentColor := False;
- Color := clNone;
- FStateNormal := TBCButtonFocusState.Create(Self);
- FStateHover := TBCButtonFocusState.Create(Self);
- FStateClicked := TBCButtonFocusState.Create(Self);
- FStateNormal.OnChange := OnChangeState;
- FStateHover.OnChange := OnChangeState;
- FStateClicked.OnChange := OnChangeState;
- FRounding := TBCRounding.Create(Self);
- FRounding.OnChange := OnChangeState;
- FRoundingDropDown := TBCRounding.Create(Self);
- FRoundingDropDown.OnChange := OnChangeState;
- { Connecting bitmaps with states property to easy call and access }
- FBGRANormal.CustomData := PtrInt(FStateNormal);
- FBGRAHover.CustomData := PtrInt(FStateHover);
- FBGRAClick.CustomData := PtrInt(FStateClicked);
- FButtonState := msNone;
- FDownButtonState := msNone;
- FFlipArrow := False;
- FGlyph := TBitmap.Create;
- FGlyph.OnChange := OnChangeGlyph;
- FGlyphMargin := 5;
- FGlyphAlignment:= bcaCenter;
- FGlyphOldPlacement:= true;
- FStyle := bbtButtonF;
- FStaticButton := False;
- FActiveButt := bbtButtonF;
- FGlobalOpacity := 255;
- FTextApplyGlobalOpacity := False;
- //FStates := [];
- FDown := False;
- { Default style }
- AssignDefaultStyle;
- FImageChangeLink := TChangeLink.Create;
- FImageChangeLink.OnChange := ImageListChange;
- FImageIndex := -1;
- FShowCaption := True;
- FPreserveGlyphOnAssign := True;
- finally
- {$IFDEF FPC}
- Exclude(FControlState, csCreating);
- EnableAutoSizing;
- {$ELSE} //#
- {$ENDIF}
- EndUpdate;
- end;
- end;
- destructor TCustomBCButtonFocus.Destroy;
- begin
- FImageChangeLink.Free;
- FStateNormal.Free;
- FStateHover.Free;
- FStateClicked.Free;
- FBGRANormal.Free;
- FBGRAHover.Free;
- FBGRAClick.Free;
- FreeAndNil(FGlyph);
- FRounding.Free;
- FRoundingDropDown.Free;
- inherited Destroy;
- end;
- procedure TCustomBCButtonFocus.Assign(Source: TPersistent);
- begin
- if Source is TCustomBCButtonFocus then
- begin
- if not PreserveGlyphOnAssign then
- Glyph := TCustomBCButtonFocus(Source).Glyph;
- FGlyphMargin := TCustomBCButtonFocus(Source).FGlyphMargin;
- FStyle := TCustomBCButtonFocus(Source).FStyle;
- FFlipArrow := TCustomBCButtonFocus(Source).FFlipArrow;
- FStaticButton := TCustomBCButtonFocus(Source).FStaticButton;
- FGlobalOpacity := TCustomBCButtonFocus(Source).FGlobalOpacity;
- FTextApplyGlobalOpacity := TCustomBCButtonFocus(Source).FTextApplyGlobalOpacity;
- FStateNormal.Assign(TCustomBCButtonFocus(Source).FStateNormal);
- FStateHover.Assign(TCustomBCButtonFocus(Source).FStateHover);
- FStateClicked.Assign(TCustomBCButtonFocus(Source).FStateClicked);
- FDropDownArrowSize := TCustomBCButtonFocus(Source).FDropDownArrowSize;
- FDropDownWidth := TCustomBCButtonFocus(Source).FDropDownWidth;
- AutoSizeExtraX := TCustomBCButtonFocus(Source).AutoSizeExtraX;
- AutoSizeExtraY := TCustomBCButtonFocus(Source).AutoSizeExtraY;
- FDown := TCustomBCButtonFocus(Source).FDown;
- FRounding.Assign(TCustomBCButtonFocus(Source).FRounding);
- FRoundingDropDown.Assign(TCustomBCButtonFocus(Source).FRoundingDropDown);
- RenderControl;
- Invalidate;
- UpdateSize;
- end
- else
- inherited Assign(Source);
- end;
- procedure TCustomBCButtonFocus.SetSizeVariables(newDropDownWidth,
- newDropDownArrowSize, newAutoSizeExtraVertical, newAutoSizeExtraHorizontal: integer);
- begin
- FDropDownArrowSize := newDropDownArrowSize;
- FDropDownWidth := newDropDownWidth;
- AutoSizeExtraY := newAutoSizeExtraVertical;
- AutoSizeExtraX := newAutoSizeExtraHorizontal;
- if csCreating in ControlState then
- Exit;
- RenderControl;
- UpdateSize;
- Invalidate;
- end;
- function TCustomBCButtonFocus.GetStyleExtension: string;
- begin
- Result := 'bcbtn';
- end;
- end.
|