1838 lines
50 KiB
ObjectPascal
1838 lines
50 KiB
ObjectPascal
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
|
{ Base framework classes
|
|
|
|
originally written in 2012 by Krzysztof Dibowski dibowski at interia.pl
|
|
}
|
|
{******************************* CONTRIBUTOR(S) ******************************
|
|
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
|
(Compatibility with delphi VCL 11/2018)
|
|
|
|
***************************** END CONTRIBUTOR(S) *****************************}
|
|
|
|
unit BCBaseCtrls;
|
|
|
|
{$I bgracontrols.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, Controls, ExtCtrls, Graphics,
|
|
{$IFNDEF FPC}Windows, Messages, BGRAGraphics, GraphType, FPImage, {$ELSE} LCLType,{$ENDIF}
|
|
BGRABitmap, BGRABitmapTypes;
|
|
|
|
type
|
|
|
|
{$IFNDEF FPC}
|
|
TSpacingSize = Integer;
|
|
TControlCellAlign = (
|
|
ccaFill,
|
|
ccaLeftTop,
|
|
ccaRightBottom,
|
|
ccaCenter
|
|
);
|
|
TControlCellAligns = set of TControlCellAlign;
|
|
|
|
TControlBorderSpacingDefault = record
|
|
Left: TSpacingSize;
|
|
Top: TSpacingSize;
|
|
Right: TSpacingSize;
|
|
Bottom: TSpacingSize;
|
|
Around: TSpacingSize;
|
|
end;
|
|
PControlBorderSpacingDefault = ^TControlBorderSpacingDefault;
|
|
|
|
|
|
TBGRAGraphicCtrl = class;
|
|
TBGRACustomCtrl = class;
|
|
TControlBorderSpacing = class;
|
|
|
|
ILCLControl = interface
|
|
['{97A3D274-C4BD-4095-9B23-8E50D6E0EA24}']
|
|
procedure DoOnResize;
|
|
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;{%H-}WithThemeSpace: boolean);
|
|
procedure MouseEnter;
|
|
procedure MouseLeave;
|
|
procedure TextChanged;
|
|
procedure FontChanged(Sender: TObject);
|
|
procedure RealSetText(const Value: TCaption);
|
|
procedure Resize;
|
|
procedure SetColor(Value: TColor);
|
|
function GetColor : TColor;
|
|
function ColorIsStored: boolean;
|
|
function RealGetText: TCaption;
|
|
function CreateControlBorderSpacing: TControlBorderSpacing;
|
|
procedure SetBorderSpacing(const AValue: TControlBorderSpacing);
|
|
procedure SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer);
|
|
procedure InvalidatePreferredSize;
|
|
procedure EnableAutoSizing;
|
|
procedure DoBorderSpacingChange(Sender: TObject; InnerSpaceChanged: Boolean);
|
|
function GetInstance : TObject;
|
|
function IsInnerBorderStored: boolean;
|
|
end;
|
|
|
|
TControlBorderSpacing = class(TPersistent)
|
|
private
|
|
FAround: TSpacingSize;
|
|
FBottom: TSpacingSize;
|
|
FCellAlignHorizontal: TControlCellAlign;
|
|
FCellAlignVertical: TControlCellAlign;
|
|
FControl: ILCLControl;
|
|
FInnerBorder: Integer;
|
|
FLeft: TSpacingSize;
|
|
FOnChange: TNotifyEvent;
|
|
FRight: TSpacingSize;
|
|
FTop: TSpacingSize;
|
|
FDefault: PControlBorderSpacingDefault;
|
|
function GetAroundBottom: Integer;
|
|
function GetAroundLeft: Integer;
|
|
function GetAroundRight: Integer;
|
|
function GetAroundTop: Integer;
|
|
function GetControlBottom: Integer;
|
|
function GetControlHeight: Integer;
|
|
function GetControlLeft: Integer;
|
|
function GetControlRight: Integer;
|
|
function GetControlTop: Integer;
|
|
function GetControlWidth: Integer;
|
|
function IsAroundStored: boolean;
|
|
function IsBottomStored: boolean;
|
|
function IsInnerBorderStored: boolean;
|
|
function IsLeftStored: boolean;
|
|
function IsRightStored: boolean;
|
|
function IsTopStored: boolean;
|
|
procedure SetAround(const AValue: TSpacingSize);
|
|
procedure SetBottom(const AValue: TSpacingSize);
|
|
procedure SetCellAlignHorizontal(const AValue: TControlCellAlign);
|
|
procedure SetCellAlignVertical(const AValue: TControlCellAlign);
|
|
procedure SetInnerBorder(const AValue: Integer);
|
|
procedure SetLeft(const AValue: TSpacingSize);
|
|
procedure SetRight(const AValue: TSpacingSize);
|
|
procedure SetSpace(Kind: TAnchorKind; const AValue: integer);
|
|
procedure SetTop(const AValue: TSpacingSize);
|
|
protected
|
|
procedure Change(InnerSpaceChanged: Boolean); virtual;
|
|
public
|
|
constructor Create(OwnerControl: ILCLControl; ADefault: PControlBorderSpacingDefault = nil);
|
|
procedure Assign(Source: TPersistent); override;
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
function IsEqual(Spacing: TControlBorderSpacing): boolean;
|
|
procedure GetSpaceAround(var SpaceAround: TRect); virtual;
|
|
function GetSideSpace(Kind: TAnchorKind): Integer; // Around+GetSpace
|
|
function GetSpace(Kind: TAnchorKind): Integer; virtual;
|
|
procedure AutoAdjustLayout(const AXProportion, AYProportion: Double);
|
|
public
|
|
property Control: ILCLControl read FControl;
|
|
property Space[Kind: TAnchorKind]: integer read GetSpace write SetSpace;
|
|
property AroundLeft: Integer read GetAroundLeft;
|
|
property AroundTop: Integer read GetAroundTop;
|
|
property AroundRight: Integer read GetAroundRight;
|
|
property AroundBottom: Integer read GetAroundBottom;
|
|
property ControlLeft: Integer read GetControlLeft;
|
|
property ControlTop: Integer read GetControlTop;
|
|
property ControlWidth: Integer read GetControlWidth;
|
|
property ControlHeight: Integer read GetControlHeight;
|
|
property ControlRight: Integer read GetControlRight;
|
|
property ControlBottom: Integer read GetControlBottom;
|
|
published
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
property Left: TSpacingSize read FLeft write SetLeft stored IsLeftStored;
|
|
property Top: TSpacingSize read FTop write SetTop stored IsTopStored;
|
|
property Right: TSpacingSize read FRight write SetRight stored IsRightStored;
|
|
property Bottom: TSpacingSize read FBottom write SetBottom stored IsBottomStored;
|
|
property Around: TSpacingSize read FAround write SetAround stored IsAroundStored;
|
|
property InnerBorder: Integer read FInnerBorder write SetInnerBorder stored IsInnerBorderStored default 0;
|
|
property CellAlignHorizontal: TControlCellAlign read FCellAlignHorizontal write SetCellAlignHorizontal default ccaFill;
|
|
property CellAlignVertical: TControlCellAlign read FCellAlignVertical write SetCellAlignVertical default ccaFill;
|
|
end;
|
|
|
|
TChildControlResizeStyle = (
|
|
crsAnchorAligning, // (like Delphi)
|
|
crsScaleChilds, // scale children equally, keep space between children fixed
|
|
crsHomogenousChildResize, // enlarge children equally (i.e. by the same amount of pixel)
|
|
crsHomogenousSpaceResize // enlarge space between children equally
|
|
{$IFDEF EnablecrsSameSize}
|
|
,crsSameSize // each child gets the same size (maybe one pixel difference)
|
|
{$ENDIF}
|
|
);
|
|
|
|
TControlChildrenLayout = (
|
|
cclNone,
|
|
cclLeftToRightThenTopToBottom, // if BiDiMode <> bdLeftToRight then it becomes RightToLeft
|
|
cclTopToBottomThenLeftToRight
|
|
);
|
|
|
|
TControlChildSizing = class(TPersistent)
|
|
private
|
|
FControl: ILCLControl;
|
|
FControlsPerLine: integer;
|
|
FEnlargeHorizontal: TChildControlResizeStyle;
|
|
FEnlargeVertical: TChildControlResizeStyle;
|
|
FHorizontalSpacing: integer;
|
|
FLayout: TControlChildrenLayout;
|
|
FLeftRightSpacing: integer;
|
|
FOnChange: TNotifyEvent;
|
|
FShrinkHorizontal: TChildControlResizeStyle;
|
|
FShrinkVertical: TChildControlResizeStyle;
|
|
FTopBottomSpacing: integer;
|
|
FVerticalSpacing: integer;
|
|
procedure SetControlsPerLine(const AValue: integer);
|
|
procedure SetEnlargeHorizontal(const AValue: TChildControlResizeStyle);
|
|
procedure SetEnlargeVertical(const AValue: TChildControlResizeStyle);
|
|
procedure SetHorizontalSpacing(const AValue: integer);
|
|
procedure SetLayout(const AValue: TControlChildrenLayout);
|
|
procedure SetLeftRightSpacing(const AValue: integer);
|
|
procedure SetShrinkHorizontal(const AValue: TChildControlResizeStyle);
|
|
procedure SetShrinkVertical(const AValue: TChildControlResizeStyle);
|
|
procedure SetTopBottomSpacing(const AValue: integer);
|
|
procedure SetVerticalSpacing(const AValue: integer);
|
|
protected
|
|
procedure Change; virtual;
|
|
public
|
|
constructor Create(OwnerControl: ILCLControl);
|
|
procedure Assign(Source: TPersistent); override;
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
function IsEqual(Sizing: TControlChildSizing): boolean;
|
|
procedure SetGridSpacing(Spacing: integer);
|
|
public
|
|
property Control: ILCLControl read FControl;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
published
|
|
property LeftRightSpacing: integer read FLeftRightSpacing write SetLeftRightSpacing default 0;
|
|
property TopBottomSpacing: integer read FTopBottomSpacing write SetTopBottomSpacing default 0;
|
|
property HorizontalSpacing: integer read FHorizontalSpacing write SetHorizontalSpacing default 0;
|
|
property VerticalSpacing: integer read FVerticalSpacing write SetVerticalSpacing default 0;
|
|
property EnlargeHorizontal: TChildControlResizeStyle read FEnlargeHorizontal
|
|
write SetEnlargeHorizontal default crsAnchorAligning;
|
|
property EnlargeVertical: TChildControlResizeStyle read FEnlargeVertical
|
|
write SetEnlargeVertical default crsAnchorAligning;
|
|
property ShrinkHorizontal: TChildControlResizeStyle read FShrinkHorizontal
|
|
write SetShrinkHorizontal default crsAnchorAligning;
|
|
property ShrinkVertical: TChildControlResizeStyle read FShrinkVertical
|
|
write SetShrinkVertical default crsAnchorAligning;
|
|
property Layout: TControlChildrenLayout read FLayout write SetLayout default cclNone;
|
|
property ControlsPerLine: integer read FControlsPerLine write SetControlsPerLine default 0;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF FPC}
|
|
TBGRAGraphicCtrl = class(TGraphicControl)
|
|
{$ELSE}
|
|
TBGRAGraphicCtrl = class(TGraphicControl, ILCLControl)
|
|
protected
|
|
FBorderSpacing: TControlBorderSpacing;
|
|
FOnChange: TNotifyEvent;
|
|
FMouseInClient: boolean;
|
|
procedure DoOnResize; virtual;
|
|
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;{%H-}WithThemeSpace: boolean); virtual;
|
|
procedure MouseEnter; virtual;
|
|
procedure MouseLeave; virtual;
|
|
procedure TextChanged; virtual;
|
|
procedure FontChanged(Sender: TObject); virtual;
|
|
procedure RealSetText(const Value: TCaption); virtual;
|
|
procedure Resize; override;
|
|
class function GetControlClassDefaultSize: TSize; virtual;
|
|
procedure SetColor(Value: TColor); virtual;
|
|
function GetColor : TColor;
|
|
procedure CMMouseEnter(var Message :TMessage); message CM_MOUSEENTER;
|
|
procedure CMMouseLeave(var Message :TMessage); message CM_MOUSELEAVE;
|
|
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
|
|
function ColorIsStored: boolean; virtual;
|
|
function RealGetText: TCaption; virtual;
|
|
function CreateControlBorderSpacing: TControlBorderSpacing; virtual;
|
|
procedure SetBorderSpacing(const AValue: TControlBorderSpacing);
|
|
procedure DoBorderSpacingChange(Sender: TObject; InnerSpaceChanged: Boolean); virtual;
|
|
function GetInstance : TObject;
|
|
function IsInnerBorderStored: boolean;
|
|
public
|
|
constructor Create(TheOwner: TComponent);override;
|
|
destructor Destroy;override;
|
|
procedure SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer); virtual;
|
|
procedure InvalidatePreferredSize; virtual;
|
|
procedure EnableAutoSizing;
|
|
property Color: TColor read GetColor write SetColor stored ColorIsStored default clWindow;
|
|
property BorderSpacing: TControlBorderSpacing read FBorderSpacing write SetBorderSpacing;
|
|
property Caption;
|
|
property Canvas;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{$IFDEF FPC}
|
|
TBGRACustomCtrl = class(TCustomControl)
|
|
{$ELSE}
|
|
TBGRACustomCtrl = class(TCustomControl, ILCLControl)
|
|
protected
|
|
FBorderSpacing: TControlBorderSpacing;
|
|
FChildSizing: TControlChildSizing;
|
|
FOnChange: TNotifyEvent;
|
|
FMouseInClient: boolean;
|
|
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;{%H-}WithThemeSpace: boolean); {$IFDEF FPC}override;{$ELSE}virtual;{$ENDIF}
|
|
procedure DoOnResize; virtual;
|
|
procedure MouseEnter; virtual;
|
|
procedure MouseLeave; virtual;
|
|
procedure TextChanged; virtual;
|
|
procedure FontChanged(Sender: TObject); virtual;
|
|
function GetDefaultDockCaption: String; virtual;
|
|
procedure RealSetText(const Value: TCaption); virtual;
|
|
procedure EnabledChanged; virtual;
|
|
procedure Resize; override;
|
|
class function GetControlClassDefaultSize: TSize; virtual;
|
|
procedure SetColor(Value: TColor); virtual;
|
|
function GetColor : TColor;
|
|
procedure UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF}); virtual;
|
|
procedure CMMouseEnter(var Message :TMessage); message CM_MOUSEENTER;
|
|
procedure CMMouseLeave(var Message :TMessage); message CM_MOUSELEAVE;
|
|
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
|
|
function ColorIsStored: boolean; virtual;
|
|
function RealGetText: TCaption; virtual;
|
|
function CreateControlBorderSpacing: TControlBorderSpacing; virtual;
|
|
procedure SetBorderSpacing(const AValue: TControlBorderSpacing);
|
|
procedure DoBorderSpacingChange(Sender: TObject; InnerSpaceChanged: Boolean); virtual;
|
|
function GetInstance : TObject;
|
|
function IsInnerBorderStored: boolean;
|
|
procedure SetChildSizing(const AValue: TControlChildSizing);
|
|
procedure DoChildSizingChange(Sender: TObject); virtual;
|
|
public
|
|
constructor Create(TheOwner: TComponent);override;
|
|
destructor Destroy;override;
|
|
procedure SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer); virtual;
|
|
procedure InvalidatePreferredSize; virtual;
|
|
procedure EnableAutoSizing;
|
|
property Color: TColor read GetColor write SetColor stored ColorIsStored default clWindow;
|
|
property BorderSpacing: TControlBorderSpacing read FBorderSpacing write SetBorderSpacing;
|
|
property ChildSizing: TControlChildSizing read FChildSizing write SetChildSizing;
|
|
property Caption;
|
|
property Canvas;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
|
|
{$IFDEF FPC}
|
|
TBGRACustomPanel = class(TCustomPanel)
|
|
{$ELSE}
|
|
TBGRACustomPanel = class(TCustomPanel, ILCLControl)
|
|
protected
|
|
FBorderSpacing: TControlBorderSpacing;
|
|
FChildSizing: TControlChildSizing;
|
|
FOnChange: TNotifyEvent;
|
|
FMouseInClient: boolean;
|
|
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;{%H-}WithThemeSpace: boolean); {$IFDEF FPC}override;{$ELSE}virtual;{$ENDIF}
|
|
procedure DoOnResize; virtual;
|
|
procedure MouseEnter; virtual;
|
|
procedure MouseLeave; virtual;
|
|
procedure TextChanged; virtual;
|
|
procedure FontChanged(Sender: TObject); virtual;
|
|
function GetDefaultDockCaption: String; virtual;
|
|
procedure RealSetText(const Value: TCaption); virtual;
|
|
procedure EnabledChanged; virtual;
|
|
procedure Resize; override;
|
|
class function GetControlClassDefaultSize: TSize; virtual;
|
|
procedure SetColor(Value: TColor); virtual;
|
|
function GetColor : TColor;
|
|
procedure UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF}); virtual;
|
|
procedure CMMouseEnter(var Message :TMessage); message CM_MOUSEENTER;
|
|
procedure CMMouseLeave(var Message :TMessage); message CM_MOUSELEAVE;
|
|
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
|
|
function ColorIsStored: boolean; virtual;
|
|
function RealGetText: TCaption; virtual;
|
|
function CreateControlBorderSpacing: TControlBorderSpacing; virtual;
|
|
procedure SetBorderSpacing(const AValue: TControlBorderSpacing);
|
|
procedure DoBorderSpacingChange(Sender: TObject; InnerSpaceChanged: Boolean); virtual;
|
|
function GetInstance : TObject;
|
|
function IsInnerBorderStored: boolean;
|
|
procedure SetChildSizing(const AValue: TControlChildSizing);
|
|
procedure DoChildSizingChange(Sender: TObject); virtual;
|
|
public
|
|
constructor Create(TheOwner: TComponent);override;
|
|
destructor Destroy;override;
|
|
procedure SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer); virtual;
|
|
procedure InvalidatePreferredSize; virtual;
|
|
procedure EnableAutoSizing;
|
|
property Color: TColor read GetColor write SetColor stored ColorIsStored default clWindow;
|
|
property BorderSpacing: TControlBorderSpacing read FBorderSpacing write SetBorderSpacing;
|
|
property ChildSizing: TControlChildSizing read FChildSizing write SetChildSizing;
|
|
property Canvas;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
TOnBCPropertyChange = procedure(ASender: TObject; AData: PtrInt) of object;
|
|
|
|
{ TBCProperty
|
|
Base BC Property with OnChange event support
|
|
}
|
|
|
|
TBCProperty = class(TPersistent)
|
|
private
|
|
FOnChange: TOnBCPropertyChange;
|
|
protected
|
|
FControl: TControl;
|
|
procedure Change(AData: PtrInt = 0); virtual;
|
|
public
|
|
constructor Create(AControl: TControl); virtual;
|
|
public
|
|
property Control: TControl read FControl;
|
|
property OnChange: TOnBCPropertyChange read FOnChange write FOnChange;
|
|
end;
|
|
|
|
{ TBGRABitmapEx
|
|
Some BGRABitmap descendant which can store custom data and has NeedRender flag
|
|
}
|
|
|
|
TBGRABitmapEx = class(TBGRABitmap)
|
|
private
|
|
FCustomData: PtrInt;
|
|
FNeedRender: Boolean;
|
|
protected
|
|
procedure Init; override;
|
|
public
|
|
property NeedRender: Boolean read FNeedRender write FNeedRender;
|
|
property CustomData: PtrInt read FCustomData write FCustomData;
|
|
procedure Discard;
|
|
end;
|
|
|
|
{ TBCGraphicControl
|
|
BC graphic control with some basic functionality like begin/end update and
|
|
debug functions
|
|
}
|
|
|
|
TBCGraphicControl = class(TBGRAGraphicCtrl)
|
|
private
|
|
{$IFDEF INDEBUG}
|
|
FPaintCount: Integer;
|
|
{$ENDIF}
|
|
FUpdateCount: Integer;
|
|
protected
|
|
procedure DoOnResize; override;
|
|
protected
|
|
{$IFDEF INDEBUG}
|
|
function GetDebugText: String; virtual;
|
|
{$ENDIF}
|
|
procedure Paint; override; // do not override in descendants!
|
|
// All descendants should use DrawControl method instead of Paint.
|
|
// DrawControl is not called between BeginUpdate and EndUpdate
|
|
procedure DrawControl; virtual;
|
|
// This method is called when control should be rendered (when some
|
|
// general action occur which change "body" e.g. resize)
|
|
procedure RenderControl; virtual;
|
|
public
|
|
{$IFDEF FPC}
|
|
{ Save all published settings to file }
|
|
procedure SaveToFile(AFileName: string); virtual; abstract;
|
|
{ Load and assign all published settings from file }
|
|
procedure LoadFromFile(AFileName: string); virtual; abstract;
|
|
{ Assign the properties from AFileName to this instance }
|
|
procedure AssignFromFile(AFileName: string); virtual; abstract;
|
|
{ Used by SaveToFile/LoadFromFile }
|
|
{$ENDIF}
|
|
constructor Create(AOwner: TComponent); override;
|
|
// This disable DrawControl method
|
|
procedure BeginUpdate; virtual;
|
|
// This enable DrawControl method
|
|
procedure EndUpdate; virtual;
|
|
// Called on EndUpdate if FUpdateCount is 0
|
|
procedure UpdateControl; virtual;
|
|
// Check if BeginUpdate was called
|
|
function IsUpdating: Boolean;
|
|
end;
|
|
|
|
{ TBCStyleDummyProperty
|
|
This is only dummy property type for access to style editor from
|
|
object inspector
|
|
}
|
|
|
|
TBCStyleDummyProperty = class(TBCProperty)
|
|
|
|
end;
|
|
|
|
{ TBCStyleGraphicControl
|
|
All descendants of this class have support for saving and loading styles and
|
|
access to style editor from object inspector or component context menu
|
|
}
|
|
|
|
TBCStyleGraphicControl = class(TBCGraphicControl)
|
|
private
|
|
FAssignStyle: TBCStyleDummyProperty;
|
|
protected
|
|
function GetStyleExtension: String; virtual; abstract;
|
|
// Dummy property for access to style editor dialog
|
|
property AssignStyle: TBCStyleDummyProperty read FAssignStyle;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
property StyleExtension: String read GetStyleExtension;
|
|
end;
|
|
|
|
{ TBCCustomControl
|
|
BC custom control with some basic functionality like begin/end update and
|
|
debug functions
|
|
}
|
|
|
|
TBCCustomControl = class(TBGRACustomCtrl)
|
|
private
|
|
{$IFDEF INDEBUG}
|
|
FPaintCount: Integer;
|
|
{$ENDIF}
|
|
FUpdateCount: Integer;
|
|
protected
|
|
procedure DoOnResize; override;
|
|
protected
|
|
{$IFDEF INDEBUG}
|
|
function GetDebugText: String; virtual;
|
|
{$ENDIF}
|
|
procedure Paint; override; // do not override in descendants!
|
|
// All descendants should use DrawControl method instead of Paint.
|
|
// DrawControl is not called between BeginUpdate and EndUpdate
|
|
procedure DrawControl; virtual;
|
|
// This method is called when control should be rendered (when some
|
|
// general action occur which change "body" e.g. resize)
|
|
procedure RenderControl; virtual;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
// This disable DrawControl method
|
|
procedure BeginUpdate; virtual;
|
|
// This enable DrawControl method
|
|
procedure EndUpdate; virtual;
|
|
// Called on EndUpdate if FUpdateCount is 0
|
|
procedure UpdateControl; virtual;
|
|
// Check if BeginUpdate was called
|
|
function IsUpdating: Boolean;
|
|
end;
|
|
|
|
{ TBCStyleCustomControl
|
|
All descendants of this class have support for saving and loading styles and
|
|
access to style editor from object inspector or component context menu
|
|
}
|
|
|
|
TBCStyleCustomControl = class(TBCCustomControl)
|
|
private
|
|
FAssignStyle: TBCStyleDummyProperty;
|
|
protected
|
|
function GetStyleExtension: String; virtual; abstract;
|
|
// Dummy property for access to style editor dialog
|
|
property AssignStyle: TBCStyleDummyProperty read FAssignStyle;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
property StyleExtension: String read GetStyleExtension;
|
|
end;
|
|
|
|
{$IFDEF FPC}procedure Register;{$ENDIF}
|
|
|
|
implementation
|
|
|
|
//{$IFDEF INDEBUG} uses Graphics; {$ENDIF}
|
|
|
|
{$IFDEF FPC}
|
|
procedure Register;
|
|
begin
|
|
RegisterNoIcon([TBCCustomControl]);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{ TBCStyleCustomControl }
|
|
|
|
constructor TBCStyleCustomControl.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
|
|
FAssignStyle := TBCStyleDummyProperty.Create(Self);
|
|
end;
|
|
|
|
destructor TBCStyleCustomControl.Destroy;
|
|
begin
|
|
FAssignStyle.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TBCStyleGraphicControl }
|
|
|
|
constructor TBCStyleGraphicControl.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
|
|
FAssignStyle := TBCStyleDummyProperty.Create(Self);
|
|
end;
|
|
|
|
destructor TBCStyleGraphicControl.Destroy;
|
|
begin
|
|
FAssignStyle.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TBCCustomControl }
|
|
|
|
procedure TBCCustomControl.DoOnResize;
|
|
begin
|
|
inherited DoOnResize;
|
|
RenderControl;
|
|
end;
|
|
|
|
{$IFDEF INDEBUG}
|
|
function TBCCustomControl.GetDebugText: String;
|
|
begin
|
|
Result := EmptyStr;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TBCCustomControl.Paint;
|
|
begin
|
|
if (csCreating in ControlState) or IsUpdating then
|
|
Exit;
|
|
|
|
DrawControl;
|
|
{$IFDEF INDEBUG}
|
|
FPaintCount := FPaintCount +1;
|
|
Canvas.Brush.Style := bsSolid;
|
|
Canvas.Brush.Color := clBlack;
|
|
Canvas.Font.Color := clWhite;
|
|
Canvas.TextOut(1,1,'P: '+IntToStr(FPaintCount)+' '+GetDebugText);
|
|
{$ENDIF}
|
|
inherited Paint;
|
|
end;
|
|
|
|
procedure TBCCustomControl.DrawControl;
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TBCCustomControl.RenderControl;
|
|
begin
|
|
|
|
end;
|
|
|
|
constructor TBCCustomControl.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
{$IFDEF INDEBUG}
|
|
FPaintCount := 0;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TBCCustomControl.BeginUpdate;
|
|
begin
|
|
FUpdateCount := FUpdateCount +1;
|
|
end;
|
|
|
|
procedure TBCCustomControl.EndUpdate;
|
|
begin
|
|
if FUpdateCount > 0 then
|
|
begin
|
|
FUpdateCount := FUpdateCount -1;
|
|
if FUpdateCount=0 then
|
|
UpdateControl;
|
|
end;
|
|
end;
|
|
|
|
procedure TBCCustomControl.UpdateControl;
|
|
begin
|
|
Self.Invalidate;
|
|
end;
|
|
|
|
function TBCCustomControl.IsUpdating: Boolean;
|
|
begin
|
|
Result := FUpdateCount>0;
|
|
end;
|
|
|
|
{ TBCProperty }
|
|
|
|
procedure TBCProperty.Change(AData: PtrInt);
|
|
begin
|
|
if Assigned(FOnChange) then
|
|
FOnChange(Self,AData);
|
|
end;
|
|
|
|
constructor TBCProperty.Create(AControl: TControl);
|
|
begin
|
|
FControl := AControl;
|
|
|
|
inherited Create;
|
|
end;
|
|
|
|
{ TBCGraphicControl }
|
|
|
|
procedure TBCGraphicControl.DoOnResize;
|
|
begin
|
|
inherited DoOnResize;
|
|
RenderControl;
|
|
end;
|
|
|
|
{$IFDEF INDEBUG}
|
|
function TBCGraphicControl.GetDebugText: String;
|
|
begin
|
|
Result := EmptyStr;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TBCGraphicControl.Paint;
|
|
begin
|
|
//inherited Paint;
|
|
if (csCreating in ControlState) or IsUpdating then
|
|
Exit;
|
|
DrawControl;
|
|
{$IFDEF INDEBUG}
|
|
FPaintCount := FPaintCount +1;
|
|
Canvas.Brush.Style := bsSolid;
|
|
Canvas.Brush.Color := clBlack;
|
|
Canvas.Font.Color := clWhite;
|
|
Canvas.TextOut(1,1,'P: '+IntToStr(FPaintCount)+' '+GetDebugText);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TBCGraphicControl.DrawControl;
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TBCGraphicControl.RenderControl;
|
|
begin
|
|
|
|
end;
|
|
|
|
constructor TBCGraphicControl.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
{$IFDEF INDEBUG}
|
|
FPaintCount := 0;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TBCGraphicControl.BeginUpdate;
|
|
begin
|
|
FUpdateCount := FUpdateCount +1;
|
|
end;
|
|
|
|
procedure TBCGraphicControl.EndUpdate;
|
|
begin
|
|
if FUpdateCount > 0 then
|
|
begin
|
|
FUpdateCount := FUpdateCount -1;
|
|
if FUpdateCount=0 then
|
|
UpdateControl;
|
|
end;
|
|
end;
|
|
|
|
procedure TBCGraphicControl.UpdateControl;
|
|
begin
|
|
Invalidate;
|
|
end;
|
|
|
|
function TBCGraphicControl.IsUpdating: Boolean;
|
|
begin
|
|
Result := FUpdateCount>0;
|
|
end;
|
|
|
|
{ TBGRABitmapEx }
|
|
|
|
procedure TBGRABitmapEx.Init;
|
|
begin
|
|
inherited Init;
|
|
FNeedRender := True;
|
|
FCustomData := 0;
|
|
end;
|
|
|
|
procedure TBGRABitmapEx.Discard;
|
|
begin
|
|
FNeedRender := true;
|
|
SetSize(0,0);
|
|
end;
|
|
|
|
{$IFNDEF FPC}
|
|
constructor TBGRAGraphicCtrl.Create(TheOwner: TComponent);
|
|
begin
|
|
inherited Create(TheOwner);
|
|
FBorderSpacing := CreateControlBorderSpacing;
|
|
FOnChange := Font.OnChange;
|
|
Font.OnChange := FontChanged;
|
|
end;
|
|
|
|
function TBGRAGraphicCtrl.CreateControlBorderSpacing: TControlBorderSpacing;
|
|
begin
|
|
Result := TControlBorderSpacing.Create(Self);
|
|
end;
|
|
|
|
destructor TBGRAGraphicCtrl.Destroy;
|
|
begin
|
|
FreeAndNil(FBorderSpacing);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.DoBorderSpacingChange(Sender: TObject; InnerSpaceChanged: Boolean);
|
|
var
|
|
IParent : ILCLControl;
|
|
begin
|
|
if Parent <> nil then
|
|
if Supports(Parent, ILCLControl, IParent) then
|
|
IParent.InvalidatePreferredSize;
|
|
AdjustSize;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.DoOnResize;
|
|
begin
|
|
if Assigned(OnResize) then
|
|
OnResize(Self);
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.SetBorderSpacing(const AValue: TControlBorderSpacing);
|
|
begin
|
|
if FBorderSpacing=AValue then exit;
|
|
FBorderSpacing.Assign(AValue);
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.SetColor(Value: TColor);
|
|
begin
|
|
if inherited Color <> Value then
|
|
begin
|
|
inherited Color := Value;
|
|
ParentColor := False;
|
|
Perform(CM_COLORCHANGED, 0, 0);
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
function TBGRAGraphicCtrl.GetColor: TColor;
|
|
begin
|
|
Result := inherited Color;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.EnableAutoSizing;
|
|
begin
|
|
end;
|
|
|
|
class function TBGRAGraphicCtrl.GetControlClassDefaultSize: TSize;
|
|
begin
|
|
Result.CX := 75;
|
|
Result.CY := 50;
|
|
end;
|
|
|
|
function TBGRAGraphicCtrl.GetInstance: TObject;
|
|
begin
|
|
result := Self;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;{%H-}WithThemeSpace: boolean);
|
|
begin
|
|
PreferredWidth:=0;
|
|
PreferredHeight:=0;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.MouseEnter;
|
|
begin
|
|
if Assigned(OnMouseEnter) then
|
|
OnMouseEnter(Self);
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.MouseLeave;
|
|
begin
|
|
if Assigned(OnMouseLeave) then
|
|
OnMouseLeave(Self);
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.TextChanged;
|
|
begin
|
|
// overrided;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.FontChanged(Sender: TObject);
|
|
begin
|
|
ParentFont := False;
|
|
DesktopFont := False;
|
|
Invalidate;
|
|
Perform(CM_FONTCHANGED, 0, 0);
|
|
if AutoSize then
|
|
begin
|
|
InvalidatePreferredSize;
|
|
AdjustSize;
|
|
end;
|
|
if Assigned(FOnChange) then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
function TBGRAGraphicCtrl.RealGetText: TCaption;
|
|
begin
|
|
Result := Caption;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.RealSetText(const Value: TCaption);
|
|
begin
|
|
if RealGetText = Value then Exit;
|
|
Caption := Value;
|
|
Perform(CM_TEXTCHANGED, 0, 0);
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.InvalidatePreferredSize;
|
|
begin
|
|
// Invalidate;
|
|
end;
|
|
|
|
function TBGRAGraphicCtrl.IsInnerBorderStored: boolean;
|
|
begin
|
|
Result:=BorderSpacing.InnerBorder<>0;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.Resize;
|
|
begin
|
|
inherited;
|
|
Invalidate;
|
|
DoOnResize;
|
|
end;
|
|
|
|
function TBGRAGraphicCtrl.ColorIsStored: boolean;
|
|
begin
|
|
Result := not ParentColor;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer);
|
|
begin
|
|
{if (csLoading in ComponentState)
|
|
or ((Owner<>nil) and (csLoading in Owner.ComponentState)) then
|
|
exit;}
|
|
SetBounds(aLeft,aTop,aWidth,aHeight);
|
|
// DoOnResize;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.CMTextChanged(var Message: TMessage);
|
|
begin
|
|
inherited;
|
|
TextChanged;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.CMMouseEnter(var Message: TMessage);
|
|
begin
|
|
if FMouseInClient then
|
|
Exit;
|
|
|
|
FMouseInClient := True;
|
|
|
|
// broadcast to parents first
|
|
if Assigned(Parent) then
|
|
Parent.Perform(CM_MOUSEENTER, 0, LParam(Self));
|
|
|
|
// if it is not a child message then perform an event
|
|
if (Message.LParam = 0) then
|
|
MouseEnter;
|
|
end;
|
|
|
|
procedure TBGRAGraphicCtrl.CMMouseLeave(var Message: TMessage);
|
|
begin
|
|
if not FMouseInClient then
|
|
Exit;
|
|
|
|
FMouseInClient := False;
|
|
|
|
// broadcast to parents first
|
|
if Assigned(Parent) then
|
|
Parent.Perform(CM_MOUSELEAVE, 0, LParam(Self));
|
|
|
|
// if it is not a child message then perform an event
|
|
if (Message.LParam = 0) then
|
|
MouseLeave;
|
|
end;
|
|
|
|
{TBGRACustomCtrl}
|
|
|
|
constructor TBGRACustomCtrl.Create(TheOwner: TComponent);
|
|
begin
|
|
inherited Create(TheOwner);
|
|
FBorderSpacing := CreateControlBorderSpacing;
|
|
FChildSizing:=TControlChildSizing.Create(Self);
|
|
FChildSizing.OnChange := DoChildSizingChange;
|
|
FOnChange := Font.OnChange;
|
|
Font.OnChange := FontChanged;
|
|
end;
|
|
|
|
function TBGRACustomCtrl.CreateControlBorderSpacing: TControlBorderSpacing;
|
|
begin
|
|
Result := TControlBorderSpacing.Create(Self);
|
|
end;
|
|
|
|
destructor TBGRACustomCtrl.Destroy;
|
|
begin
|
|
FreeAndNil(FBorderSpacing);
|
|
FreeAndNil(FChildSizing);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.DoBorderSpacingChange(Sender: TObject; InnerSpaceChanged: Boolean);
|
|
var
|
|
IParent : ILCLControl;
|
|
begin
|
|
if Parent <> nil then
|
|
if Supports(Parent, ILCLControl, IParent) then
|
|
IParent.InvalidatePreferredSize;
|
|
AdjustSize;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.DoChildSizingChange(Sender: TObject);
|
|
begin
|
|
//debugln('TWinControl.DoChildSizingChange ',DbgSName(Self));
|
|
if ControlCount=0 then exit;
|
|
InvalidatePreferredSize;
|
|
ReAlign;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.DoOnResize;
|
|
begin
|
|
if Assigned(OnResize) then
|
|
OnResize(Self);
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;{%H-}WithThemeSpace: boolean);
|
|
begin
|
|
PreferredWidth:=0;
|
|
PreferredHeight:=0;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.MouseEnter;
|
|
begin
|
|
if Assigned(OnMouseEnter) then
|
|
OnMouseEnter(Self);
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.MouseLeave;
|
|
begin
|
|
if Assigned(OnMouseLeave) then
|
|
OnMouseLeave(Self);
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.TextChanged;
|
|
begin
|
|
// overrided;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.FontChanged(Sender: TObject);
|
|
begin
|
|
ParentFont := False;
|
|
DesktopFont := False;
|
|
Invalidate;
|
|
Perform(CM_FONTCHANGED, 0, 0);
|
|
if AutoSize then
|
|
begin
|
|
InvalidatePreferredSize;
|
|
AdjustSize;
|
|
end;
|
|
if Assigned(FOnChange) then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
function TBGRACustomCtrl.GetDefaultDockCaption: String;
|
|
begin
|
|
end;
|
|
|
|
function TBGRACustomCtrl.GetInstance: TObject;
|
|
begin
|
|
result := Self;
|
|
end;
|
|
|
|
function TBGRACustomCtrl.RealGetText: TCaption;
|
|
begin
|
|
Result := Caption;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.RealSetText(const Value: TCaption);
|
|
begin
|
|
if RealGetText = Value then Exit;
|
|
Caption := Value;
|
|
Perform(CM_TEXTCHANGED, 0, 0);
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.EnabledChanged;
|
|
begin
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.InvalidatePreferredSize;
|
|
begin
|
|
// Invalidate;
|
|
end;
|
|
|
|
function TBGRACustomCtrl.IsInnerBorderStored: boolean;
|
|
begin
|
|
Result:=BorderSpacing.InnerBorder<>0;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.Resize;
|
|
begin
|
|
inherited;
|
|
Invalidate;
|
|
DoOnResize;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.SetBorderSpacing(const AValue: TControlBorderSpacing);
|
|
begin
|
|
if FBorderSpacing=AValue then exit;
|
|
FBorderSpacing.Assign(AValue);
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.SetChildSizing(const AValue: TControlChildSizing);
|
|
begin
|
|
if (FChildSizing=AValue) then exit;
|
|
FChildSizing.Assign(AValue);
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.SetColor(Value: TColor);
|
|
begin
|
|
if inherited Color <> Value then
|
|
begin
|
|
inherited Color := Value;
|
|
ParentColor := False;
|
|
Perform(CM_COLORCHANGED, 0, 0);
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
function TBGRACustomCtrl.GetColor : TColor;
|
|
begin
|
|
Result := inherited Color;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF});
|
|
begin
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.EnableAutoSizing;
|
|
begin
|
|
end;
|
|
|
|
function TBGRACustomCtrl.ColorIsStored: boolean;
|
|
begin
|
|
Result := not ParentColor;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer);
|
|
begin
|
|
{if (csLoading in ComponentState)
|
|
or ((Owner<>nil) and (csLoading in Owner.ComponentState)) then
|
|
exit;}
|
|
SetBounds(aLeft,aTop,aWidth,aHeight);
|
|
// DoOnResize;
|
|
end;
|
|
|
|
class function TBGRACustomCtrl.GetControlClassDefaultSize: TSize;
|
|
begin
|
|
Result.CX := 75;
|
|
Result.CY := 50;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.CMTextChanged(var Message: TMessage);
|
|
begin
|
|
TextChanged;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.CMMouseEnter(var Message: TMessage);
|
|
begin
|
|
if FMouseInClient then
|
|
Exit;
|
|
|
|
FMouseInClient := True;
|
|
|
|
// broadcast to parents first
|
|
if Assigned(Parent) then
|
|
Parent.Perform(CM_MOUSEENTER, 0, LParam(Self));
|
|
|
|
// if it is not a child message then perform an event
|
|
if (Message.LParam = 0) then
|
|
MouseEnter;
|
|
end;
|
|
|
|
procedure TBGRACustomCtrl.CMMouseLeave(var Message: TMessage);
|
|
begin
|
|
if not FMouseInClient then
|
|
Exit;
|
|
|
|
FMouseInClient := False;
|
|
|
|
// broadcast to parents first
|
|
if Assigned(Parent) then
|
|
Parent.Perform(CM_MOUSELEAVE, 0, LParam(Self));
|
|
|
|
// if it is not a child message then perform an event
|
|
if (Message.LParam = 0) then
|
|
MouseLeave;
|
|
end;
|
|
|
|
{TBGRACustomPanel}
|
|
|
|
constructor TBGRACustomPanel.Create(TheOwner: TComponent);
|
|
begin
|
|
inherited Create(TheOwner);
|
|
FBorderSpacing := CreateControlBorderSpacing;
|
|
FChildSizing:=TControlChildSizing.Create(Self);
|
|
FChildSizing.OnChange := DoChildSizingChange;
|
|
FOnChange := Font.OnChange;
|
|
Font.OnChange := FontChanged;
|
|
end;
|
|
|
|
function TBGRACustomPanel.CreateControlBorderSpacing: TControlBorderSpacing;
|
|
begin
|
|
Result := TControlBorderSpacing.Create(Self);
|
|
end;
|
|
|
|
destructor TBGRACustomPanel.Destroy;
|
|
begin
|
|
FreeAndNil(FBorderSpacing);
|
|
FreeAndNil(FChildSizing);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.DoBorderSpacingChange(Sender: TObject; InnerSpaceChanged: Boolean);
|
|
var
|
|
IParent : ILCLControl;
|
|
begin
|
|
if Parent <> nil then
|
|
if Supports(Parent, ILCLControl, IParent) then
|
|
IParent.InvalidatePreferredSize;
|
|
AdjustSize;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.DoChildSizingChange(Sender: TObject);
|
|
begin
|
|
//debugln('TWinControl.DoChildSizingChange ',DbgSName(Self));
|
|
if ControlCount=0 then exit;
|
|
InvalidatePreferredSize;
|
|
ReAlign;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.DoOnResize;
|
|
begin
|
|
if Assigned(OnResize) then
|
|
OnResize(Self);
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;{%H-}WithThemeSpace: boolean);
|
|
begin
|
|
PreferredWidth:=0;
|
|
PreferredHeight:=0;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.MouseEnter;
|
|
begin
|
|
if Assigned(OnMouseEnter) then
|
|
OnMouseEnter(Self);
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.MouseLeave;
|
|
begin
|
|
if Assigned(OnMouseLeave) then
|
|
OnMouseLeave(Self);
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.TextChanged;
|
|
begin
|
|
// overrided;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.FontChanged(Sender: TObject);
|
|
begin
|
|
ParentFont := False;
|
|
DesktopFont := False;
|
|
Invalidate;
|
|
Perform(CM_FONTCHANGED, 0, 0);
|
|
if AutoSize then
|
|
begin
|
|
InvalidatePreferredSize;
|
|
AdjustSize;
|
|
end;
|
|
if Assigned(FOnChange) then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
function TBGRACustomPanel.GetDefaultDockCaption: String;
|
|
begin
|
|
end;
|
|
|
|
function TBGRACustomPanel.GetInstance: TObject;
|
|
begin
|
|
result := Self;
|
|
end;
|
|
|
|
function TBGRACustomPanel.RealGetText: TCaption;
|
|
begin
|
|
Result := Caption;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.RealSetText(const Value: TCaption);
|
|
begin
|
|
if RealGetText = Value then Exit;
|
|
Caption := Value;
|
|
Perform(CM_TEXTCHANGED, 0, 0);
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.EnabledChanged;
|
|
begin
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.InvalidatePreferredSize;
|
|
begin
|
|
// Invalidate;
|
|
end;
|
|
|
|
function TBGRACustomPanel.IsInnerBorderStored: boolean;
|
|
begin
|
|
Result:=BorderSpacing.InnerBorder<>0;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.Resize;
|
|
begin
|
|
inherited;
|
|
Invalidate;
|
|
DoOnResize;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.SetBorderSpacing(const AValue: TControlBorderSpacing);
|
|
begin
|
|
if FBorderSpacing=AValue then exit;
|
|
FBorderSpacing.Assign(AValue);
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.SetChildSizing(const AValue: TControlChildSizing);
|
|
begin
|
|
if (FChildSizing=AValue) then exit;
|
|
FChildSizing.Assign(AValue);
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.SetColor(Value: TColor);
|
|
begin
|
|
if inherited Color <> Value then
|
|
begin
|
|
inherited Color := Value;
|
|
ParentColor := False;
|
|
Perform(CM_COLORCHANGED, 0, 0);
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
function TBGRACustomPanel.GetColor : TColor;
|
|
begin
|
|
Result := inherited Color;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF});
|
|
begin
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.EnableAutoSizing;
|
|
begin
|
|
end;
|
|
|
|
function TBGRACustomPanel.ColorIsStored: boolean;
|
|
begin
|
|
Result := not ParentColor;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer);
|
|
begin
|
|
{if (csLoading in ComponentState)
|
|
or ((Owner<>nil) and (csLoading in Owner.ComponentState)) then
|
|
exit;}
|
|
SetBounds(aLeft,aTop,aWidth,aHeight);
|
|
// DoOnResize;
|
|
end;
|
|
|
|
class function TBGRACustomPanel.GetControlClassDefaultSize: TSize;
|
|
begin
|
|
Result.CX := 75;
|
|
Result.CY := 50;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.CMTextChanged(var Message: TMessage);
|
|
begin
|
|
TextChanged;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.CMMouseEnter(var Message: TMessage);
|
|
begin
|
|
if FMouseInClient then
|
|
Exit;
|
|
|
|
FMouseInClient := True;
|
|
|
|
// broadcast to parents first
|
|
if Assigned(Parent) then
|
|
Parent.Perform(CM_MOUSEENTER, 0, LParam(Self));
|
|
|
|
// if it is not a child message then perform an event
|
|
if (Message.LParam = 0) then
|
|
MouseEnter;
|
|
end;
|
|
|
|
procedure TBGRACustomPanel.CMMouseLeave(var Message: TMessage);
|
|
begin
|
|
if not FMouseInClient then
|
|
Exit;
|
|
|
|
FMouseInClient := False;
|
|
|
|
// broadcast to parents first
|
|
if Assigned(Parent) then
|
|
Parent.Perform(CM_MOUSELEAVE, 0, LParam(Self));
|
|
|
|
// if it is not a child message then perform an event
|
|
if (Message.LParam = 0) then
|
|
MouseLeave;
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF FPC}
|
|
|
|
{ TControlBorderSpacing }
|
|
|
|
procedure TControlBorderSpacing.SetAround(const AValue: TSpacingSize);
|
|
begin
|
|
if FAround=AValue then exit;
|
|
FAround:=AValue;
|
|
Change(false);
|
|
end;
|
|
|
|
function TControlBorderSpacing.IsAroundStored: boolean;
|
|
begin
|
|
if FDefault = nil
|
|
then Result := FAround <> 0
|
|
else Result := FAround <> FDefault^.Around;
|
|
end;
|
|
|
|
function TControlBorderSpacing.IsBottomStored: boolean;
|
|
begin
|
|
if FDefault = nil
|
|
then Result := FBottom <> 0
|
|
else Result := FBottom <> FDefault^.Bottom;
|
|
end;
|
|
|
|
function TControlBorderSpacing.IsInnerBorderStored: boolean;
|
|
begin
|
|
if Control <> nil then
|
|
Result:=Control.IsInnerBorderStored
|
|
else
|
|
Result:=True;
|
|
end;
|
|
|
|
function TControlBorderSpacing.IsLeftStored: boolean;
|
|
begin
|
|
if FDefault = nil
|
|
then Result := FLeft <> 0
|
|
else Result := FLeft <> FDefault^.Left;
|
|
end;
|
|
|
|
function TControlBorderSpacing.IsRightStored: boolean;
|
|
begin
|
|
if FDefault = nil
|
|
then Result := FRight <> 0
|
|
else Result := FRight <> FDefault^.Right;
|
|
end;
|
|
|
|
function TControlBorderSpacing.IsTopStored: boolean;
|
|
begin
|
|
if FDefault = nil
|
|
then Result := FTop <> 0
|
|
else Result := FTop <> FDefault^.Top;
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.SetBottom(const AValue: TSpacingSize);
|
|
begin
|
|
if FBottom=AValue then exit;
|
|
FBottom:=AValue;
|
|
Change(false);
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.SetCellAlignHorizontal(
|
|
const AValue: TControlCellAlign);
|
|
begin
|
|
if FCellAlignHorizontal=AValue then exit;
|
|
FCellAlignHorizontal:=AValue;
|
|
Change(false);
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.SetCellAlignVertical(
|
|
const AValue: TControlCellAlign);
|
|
begin
|
|
if FCellAlignVertical=AValue then exit;
|
|
FCellAlignVertical:=AValue;
|
|
Change(false);
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.SetInnerBorder(const AValue: Integer);
|
|
begin
|
|
if FInnerBorder=AValue then exit;
|
|
FInnerBorder:=AValue;
|
|
if Control<>nil then Control.InvalidatePreferredSize;
|
|
Change(true);
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.SetLeft(const AValue: TSpacingSize);
|
|
begin
|
|
if FLeft=AValue then exit;
|
|
FLeft:=AValue;
|
|
Change(false);
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.SetRight(const AValue: TSpacingSize);
|
|
begin
|
|
if FRight=AValue then exit;
|
|
FRight:=AValue;
|
|
Change(false);
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.SetSpace(Kind: TAnchorKind;
|
|
const AValue: integer);
|
|
begin
|
|
case Kind of
|
|
akLeft: Left:=AValue;
|
|
akTop: Top:=AValue;
|
|
akBottom: Bottom:=AValue;
|
|
akRight: Right:=AValue;
|
|
end;
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.SetTop(const AValue: TSpacingSize);
|
|
begin
|
|
if FTop=AValue then exit;
|
|
FTop:=AValue;
|
|
Change(false);
|
|
end;
|
|
|
|
constructor TControlBorderSpacing.Create(OwnerControl: ILCLControl; ADefault: PControlBorderSpacingDefault);
|
|
begin
|
|
FControl := OwnerControl;
|
|
FDefault := ADefault;
|
|
if ADefault <> nil then
|
|
begin
|
|
FLeft := ADefault^.Left;
|
|
FRight := ADefault^.Right;
|
|
FTop := ADefault^.Top;
|
|
FBottom := ADefault^.Bottom;
|
|
FAround := ADefault^.Around;
|
|
end;
|
|
FCellAlignHorizontal := ccaFill;
|
|
FCellAlignVertical := ccaFill;
|
|
inherited Create;
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.Assign(Source: TPersistent);
|
|
var
|
|
SrcSpacing: TControlBorderSpacing;
|
|
begin
|
|
if Source is TControlBorderSpacing then begin
|
|
SrcSpacing:=TControlBorderSpacing(Source);
|
|
if IsEqual(SrcSpacing) then exit;
|
|
|
|
FAround:=SrcSpacing.Around;
|
|
FBottom:=SrcSpacing.Bottom;
|
|
FLeft:=SrcSpacing.Left;
|
|
FRight:=SrcSpacing.Right;
|
|
FTop:=SrcSpacing.Top;
|
|
FInnerBorder:=SrcSpacing.InnerBorder;
|
|
FCellAlignHorizontal:=SrcSpacing.CellAlignHorizontal;
|
|
FCellAlignVertical:=SrcSpacing.CellAlignVertical;
|
|
|
|
Change(false);
|
|
end else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.AssignTo(Dest: TPersistent);
|
|
begin
|
|
Dest.Assign(Self);
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.AutoAdjustLayout(const AXProportion,
|
|
AYProportion: Double);
|
|
|
|
procedure Scale(var Value: Integer; const Proportion: Double; var Changed: Boolean);
|
|
begin
|
|
if Value<>0 then
|
|
begin
|
|
Value := Round(Value * Proportion);
|
|
Changed := True;
|
|
end;
|
|
end;
|
|
var
|
|
InnerChanged, OuterChanged: Boolean;
|
|
begin
|
|
InnerChanged := False;
|
|
OuterChanged := False;
|
|
|
|
Scale(FAround, AXProportion, OuterChanged);
|
|
Scale(FInnerBorder, AXProportion, InnerChanged);
|
|
Scale(FLeft, AXProportion, OuterChanged);
|
|
Scale(FTop, AYProportion, OuterChanged);
|
|
Scale(FRight, AXProportion, OuterChanged);
|
|
Scale(FBottom, AYProportion, OuterChanged);
|
|
|
|
if OuterChanged or InnerChanged then
|
|
begin
|
|
if Control<>nil then Control.InvalidatePreferredSize;
|
|
Change(InnerChanged);
|
|
end;
|
|
end;
|
|
|
|
function TControlBorderSpacing.IsEqual(Spacing: TControlBorderSpacing
|
|
): boolean;
|
|
begin
|
|
Result:=(FAround=Spacing.Around)
|
|
and (FBottom=Spacing.Bottom)
|
|
and (FLeft=Spacing.Left)
|
|
and (FRight=Spacing.Right)
|
|
and (FTop=Spacing.Top);
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.GetSpaceAround(var SpaceAround: TRect);
|
|
begin
|
|
SpaceAround.Left:=Left+Around;
|
|
SpaceAround.Top:=Top+Around;
|
|
SpaceAround.Right:=Right+Around;
|
|
SpaceAround.Bottom:=Bottom+Around;
|
|
end;
|
|
|
|
|
|
function TControlBorderSpacing.GetSideSpace(Kind: TAnchorKind): Integer;
|
|
begin
|
|
Result:=Around+GetSpace(Kind);
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetSpace(Kind: TAnchorKind): Integer;
|
|
begin
|
|
case Kind of
|
|
akLeft: Result:=Left;
|
|
akTop: Result:=Top;
|
|
akRight: Result:=Right;
|
|
akBottom: Result:=Bottom;
|
|
end;
|
|
end;
|
|
|
|
procedure TControlBorderSpacing.Change(InnerSpaceChanged: Boolean);
|
|
begin
|
|
if FControl <> nil then
|
|
FControl.DoBorderSpacingChange(Self,InnerSpaceChanged);
|
|
if Assigned(OnChange) then OnChange(Self);
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetAroundBottom: Integer;
|
|
begin
|
|
Result := Around+Bottom;
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetAroundLeft: Integer;
|
|
begin
|
|
Result := Around+Left;
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetAroundRight: Integer;
|
|
begin
|
|
Result := Around+Right;
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetAroundTop: Integer;
|
|
begin
|
|
Result := Around+Top;
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetControlBottom: Integer;
|
|
begin
|
|
if (FControl<>nil) and (FControl.GetInstance<>nil) and FControl.GetInstance.InheritsFrom(TControl) then
|
|
Result := TControl(FControl.GetInstance).Top +TControl(FControl.GetInstance).Height +Around+Bottom
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetControlHeight: Integer;
|
|
begin
|
|
if (FControl<>nil) and (FControl.GetInstance<>nil) and FControl.GetInstance.InheritsFrom(TControl) then
|
|
Result := TControl(FControl.GetInstance).Height+Around*2+Top+Bottom
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetControlLeft: Integer;
|
|
begin
|
|
if (FControl<>nil) and (FControl.GetInstance<>nil) and FControl.GetInstance.InheritsFrom(TControl) then
|
|
Result := TControl(FControl.GetInstance).Left-Around-Left
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetControlRight: Integer;
|
|
begin
|
|
if (FControl<>nil) and (FControl.GetInstance<>nil) and FControl.GetInstance.InheritsFrom(TControl) then
|
|
Result := TControl(FControl.GetInstance).Left+TControl(FControl.GetInstance).Width+Around+Right
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetControlTop: Integer;
|
|
begin
|
|
if (FControl<>nil) and (FControl.GetInstance<>nil) and FControl.GetInstance.InheritsFrom(TControl) then
|
|
Result := TControl(FControl.GetInstance).Top-Around-Top
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TControlBorderSpacing.GetControlWidth: Integer;
|
|
begin
|
|
if (FControl<>nil) and (FControl.GetInstance<>nil) and FControl.GetInstance.InheritsFrom(TControl) then
|
|
Result := TControl(FControl.GetInstance).Width+Around*2+Left+Right
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{ TControlChildSizing }
|
|
|
|
procedure TControlChildSizing.SetEnlargeHorizontal(
|
|
const AValue: TChildControlResizeStyle);
|
|
begin
|
|
if FEnlargeHorizontal=AValue then exit;
|
|
FEnlargeHorizontal:=AValue;
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetControlsPerLine(const AValue: integer);
|
|
begin
|
|
if FControlsPerLine=AValue then exit;
|
|
FControlsPerLine:=AValue;
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetEnlargeVertical(
|
|
const AValue: TChildControlResizeStyle);
|
|
begin
|
|
if FEnlargeVertical=AValue then exit;
|
|
FEnlargeVertical:=AValue;
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetHorizontalSpacing(const AValue: integer);
|
|
begin
|
|
if FHorizontalSpacing=AValue then exit;
|
|
FHorizontalSpacing:=AValue;
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetLayout(const AValue: TControlChildrenLayout);
|
|
begin
|
|
if FLayout=AValue then exit;
|
|
FLayout:=AValue;
|
|
//debugln('TControlChildSizing.SetLayout ',DbgSName(Control));
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetLeftRightSpacing(const AValue: integer);
|
|
begin
|
|
if FLeftRightSpacing=AValue then exit;
|
|
FLeftRightSpacing:=AValue;
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetShrinkHorizontal(
|
|
const AValue: TChildControlResizeStyle);
|
|
begin
|
|
if FShrinkHorizontal=AValue then exit;
|
|
FShrinkHorizontal:=AValue;
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetShrinkVertical(
|
|
const AValue: TChildControlResizeStyle);
|
|
begin
|
|
if FShrinkVertical=AValue then exit;
|
|
FShrinkVertical:=AValue;
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetTopBottomSpacing(const AValue: integer);
|
|
begin
|
|
if FTopBottomSpacing=AValue then exit;
|
|
FTopBottomSpacing:=AValue;
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetVerticalSpacing(const AValue: integer);
|
|
begin
|
|
if FVerticalSpacing=AValue then exit;
|
|
FVerticalSpacing:=AValue;
|
|
Change;
|
|
end;
|
|
|
|
constructor TControlChildSizing.Create(OwnerControl: ILCLControl);
|
|
begin
|
|
inherited Create;
|
|
FControl := OwnerControl;
|
|
FLayout := cclNone;
|
|
FEnlargeHorizontal :=crsAnchorAligning;
|
|
FEnlargeVertical := crsAnchorAligning;
|
|
FShrinkHorizontal := crsAnchorAligning;
|
|
FShrinkVertical := crsAnchorAligning;
|
|
end;
|
|
|
|
procedure TControlChildSizing.Assign(Source: TPersistent);
|
|
var
|
|
SrcSizing: TControlChildSizing;
|
|
begin
|
|
if Source is TControlChildSizing then begin
|
|
SrcSizing:=TControlChildSizing(Source);
|
|
if IsEqual(SrcSizing) then exit;
|
|
|
|
FEnlargeHorizontal:=SrcSizing.EnlargeHorizontal;
|
|
FEnlargeVertical:=SrcSizing.EnlargeVertical;
|
|
FShrinkHorizontal:=SrcSizing.ShrinkHorizontal;
|
|
FShrinkVertical:=SrcSizing.ShrinkVertical;
|
|
FEnlargeHorizontal:=SrcSizing.EnlargeHorizontal;
|
|
FEnlargeVertical:=SrcSizing.EnlargeVertical;
|
|
FShrinkHorizontal:=SrcSizing.ShrinkHorizontal;
|
|
FShrinkVertical:=SrcSizing.ShrinkVertical;
|
|
FControlsPerLine:=SrcSizing.ControlsPerLine;
|
|
FLayout:=SrcSizing.Layout;
|
|
FLeftRightSpacing:=SrcSizing.LeftRightSpacing;
|
|
FTopBottomSpacing:=SrcSizing.TopBottomSpacing;
|
|
FHorizontalSpacing:=SrcSizing.HorizontalSpacing;
|
|
FVerticalSpacing:=SrcSizing.VerticalSpacing;
|
|
|
|
Change;
|
|
end else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
procedure TControlChildSizing.AssignTo(Dest: TPersistent);
|
|
begin
|
|
Dest.Assign(Self);
|
|
end;
|
|
|
|
function TControlChildSizing.IsEqual(Sizing: TControlChildSizing): boolean;
|
|
begin
|
|
Result:=(FEnlargeHorizontal=Sizing.EnlargeHorizontal)
|
|
and (FEnlargeVertical=Sizing.EnlargeVertical)
|
|
and (FShrinkHorizontal=Sizing.ShrinkHorizontal)
|
|
and (FShrinkVertical=Sizing.ShrinkVertical)
|
|
and (FEnlargeHorizontal=Sizing.EnlargeHorizontal)
|
|
and (FEnlargeVertical=Sizing.EnlargeVertical)
|
|
and (FShrinkHorizontal=Sizing.ShrinkHorizontal)
|
|
and (FShrinkVertical=Sizing.ShrinkVertical)
|
|
and (FControlsPerLine=Sizing.ControlsPerLine)
|
|
and (FLayout=Sizing.Layout)
|
|
and (FLeftRightSpacing=Sizing.LeftRightSpacing)
|
|
and (FTopBottomSpacing=Sizing.TopBottomSpacing)
|
|
and (FHorizontalSpacing=Sizing.HorizontalSpacing)
|
|
and (FVerticalSpacing=Sizing.VerticalSpacing);
|
|
end;
|
|
|
|
procedure TControlChildSizing.SetGridSpacing(Spacing: integer);
|
|
begin
|
|
if (LeftRightSpacing=Spacing)
|
|
and (TopBottomSpacing=Spacing)
|
|
and (HorizontalSpacing=Spacing)
|
|
and (VerticalSpacing=Spacing) then exit;
|
|
fLeftRightSpacing:=Spacing;
|
|
fTopBottomSpacing:=Spacing;
|
|
fHorizontalSpacing:=Spacing;
|
|
fVerticalSpacing:=Spacing;
|
|
Change;
|
|
end;
|
|
|
|
procedure TControlChildSizing.Change;
|
|
begin
|
|
if (FControl<>nil) and (FControl.GetInstance<>nil) and FControl.GetInstance.InheritsFrom(TBGRACustomCtrl) then
|
|
TBGRACustomCtrl(FControl.GetInstance).DoChildSizingChange(Self);
|
|
if Assigned(FOnChange) then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
end.
|
|
|