unit UxPanel;
{$WARN SYMBOL_PLATFORM OFF}
{$WARN DUPLICATE_CTOR_DTOR OFF}
interface
uses
Windows, Messages, SysUtils, Types, Classes, Controls, Graphics, Forms,
AppEvnts, UITypes, StdCtrls, ExtCtrls, Rux, ActnList, Dialogs, dlgmod,
Generics.Defaults, Generics.Collections, Menus, ActiveX, ComObj, ShlObj,
ComCtrls, ListViewEx, HueSelector, SVColorMap, TextEditor, ReplaceWin,
Variants, ImageViewer, ClockCtl;
const
GDefaultColor = $9FA2B2;
GDefCaptionSize = 24;
GDefBorderWidth = 3;
GDefTextHeight = 18;
GIndentSize = 6;
var
GThemedBorders: Boolean = True;
const
STARTMENU_TAG = 17926;
var
CF_ASPANEL: TClipFormat;
const
CFSTR_ASPANEL = 'RejbrandAlgosimPanel';
var
FORMATETC_ASPANEL: TFormatEtc =
(
cfFormat: 0;
ptd: nil;
dwAspect: DVASPECT_CONTENT;
lindex: -1;
tymed: TYMED_HGLOBAL
);
FORMATETC_UNICODETEXT: TFormatEtc =
(
cfFormat: CF_UNICODETEXT;
ptd: nil;
dwAspect: DVASPECT_CONTENT;
lindex: -1;
tymed: TYMED_HGLOBAL
);
FORMATETC_HDROP: TFormatEtc =
(
cfFormat: CF_HDROP;
ptd: nil;
dwAspect: DVASPECT_CONTENT;
lindex: -1;
tymed: TYMED_HGLOBAL
);
const
PanelOleHeader: UInt64 = $415350414E454C00;
type
TUxDockable = class;
TUxPanel = class;
TUxContainer = class;
TUxButton = class;
TUxClient = class;
TUxLayoutPanel = class;
TUxContainerOrientation = (uxoHorizontal, uxoVertical);
TUxLayoutItem = class
protected
procedure AddPanels(L: TList<TUxLayoutPanel>); virtual;
public
Title: string;
Size: Double;
Default: Boolean;
function Panels: TArray<TUxLayoutPanel>;
end;
TUxLayoutPanel = class(TUxLayoutItem)
protected
procedure AddPanels(L: TList<TUxLayoutPanel>); override;
public
PanelClassName: string;
Instance: TUxPanel;
constructor Create(const APanelClassName: string);
end;
TUxLayoutStack = class(TUxLayoutItem)
protected
procedure AddPanels(L: TList<TUxLayoutPanel>); override;
public
Orientation: TUxContainerOrientation;
Items: TObjectList<TUxLayoutItem>;
constructor Create(AOrientation: TUxContainerOrientation);
destructor Destroy; override;
end;
TUxEmptyLayout = class(TUxLayoutItem)
end;
TUxLayout = TUxLayoutItem;
TPanelRec = record
ID: TGUID;
Name,
&Type: string;
end;
TPopupMenu2 = class(Menus.TPopupMenu)
public
procedure Popup(X, Y: Integer); override;
end;
TPopupMenuHelper = class helper for Menus.TPopupMenu
procedure DoPrePopupWork(X, Y: Integer);
end;
TMenuItemHelper = class helper for Menus.TMenuItem
procedure DoPrePopupWork;
end;
IHelpfulControl = interface
['{E211A46E-911D-4125-BD2F-E226BA33D9E1}']
function ContextHelp: Boolean;
end;
PanelAttribute = class(TCustomAttribute)
strict private
FName: string;
FExts: TArray<string>;
public
constructor Create(const AName: string); overload;
constructor Create(const AName: string; const AExts: string); overload;
property Name: string read FName;
property Exts: TArray<string> read FExts;
end;
IUxDockSite = interface
['{275A1442-91E9-42E2-994F-E6A9A1CABB31}']
function FindInsertionPoint(const APoint: TPoint): Integer;
procedure MovePanel(APanel: TUxDockable; AIndex: Integer);
procedure InsertPanel(APanel: TUxDockable; AIndex: Integer);
end;
TUxDockSite = class(TComponent, IDropTarget)
protected
FOwnerCtl: TWinControl;
FDockSite: IUxDockSite;
FDragDataObject: IDataObject;
FInsertionPoint: Integer;
FDropList: TArray<string>;
FDropListTimer: TTimer;
FInsertionPointAnimator: TTimer;
FInsertionPointAnimationStep: Boolean;
function GetDropEffect: Integer;
procedure DropListTimerTimer(Sender: TObject);
procedure InsertionPointAnimatorTimer(Sender: TObject);
function DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HRESULT; stdcall;
function DragLeave: HRESULT; stdcall;
function DragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HRESULT; reintroduce; stdcall;
function Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HRESULT; stdcall;
public
constructor Create(AOwner: TComponent); override;
end;
TUxForm = class(TForm, IDropTarget, IUxDockSite)
public const
FHT_APPBUTTON = 1;
private
var FMouseDownHitTest, FHitTest: Integer;
var FAppButtonDown: Boolean;
var FAppMenuTickCount: UInt64;
var FAppMenuToRemainClosed: Boolean;
var FHasShown: Boolean;
class var FApplyingLayout: Boolean;
class var FAppMenu: TPopupMenu;
class var FAppMenuCaption: string;
class var FAppBarStatus: string;
class var FCleanupTimer: TTimer;
var FUxDockSite: TUxDockSite;
var FConstraintsTimer: TTimer;
var FLayoutApplicationTimer: TTimer;
var AppliedLayoutName: string;
function FindInsertionPoint(const APoint: TPoint): Integer;
class var FAppEvents: TApplicationEvents;
class var FInstances: TList<TUxForm>;
class procedure CleanupTimerTimer(Sender: TObject);
class constructor ClassCreate;
class destructor ClassDestroy;
class procedure RequestCleanup;
class procedure Cleanup;
function IsSuperfluous: Boolean;
class procedure UxThemeUpdate; static;
class procedure UpdateTitleBars(Sender: TObject);
class procedure AppHint(Sender: TObject);
class procedure AppModalBegin(Sender: TObject);
class procedure AppModalEnd(Sender: TObject);
class procedure SetAppMenuCaption(const Value: string); static;
class procedure SetAppBarStatus(const Value: string); static;
function AppBarHeight: Integer;
function AppBarRect: TRect;
function AppButtonRect: TRect;
function SizeGripRect: TRect;
function ChildRect: TRect;
procedure UpdateStatusBar;
procedure ConstraintsTimerTimer(Sender: TObject);
procedure LayoutApplicationTimerTimer(Sender: TObject);
protected
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMWindowPosChanged(var Message: TWMWindowPosChanged);
message WM_WINDOWPOSCHANGED;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
procedure CreateWnd; override;
procedure Paint; override;
procedure DoClose(var Action: TCloseAction); override;
procedure Activate; override;
procedure Deactivate; override;
procedure DoShow; override;
procedure Resize; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure Click; override;
property UxDockSite: TUxDockSite read FUxDockSite implements IDropTarget;
procedure ThemeUpdate; virtual;
procedure UpdateDwmColors;
public
constructor Create(AOwner: TComponent); override;
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
destructor Destroy; override;
procedure RequestClientSize(AWidth, AHeight: Integer); overload; virtual;
procedure RequestClientSize(const ASize: TSize); overload;
function HitTest(const X, Y: Integer): Integer; overload;
function HitTest(const P: TPoint): Integer; overload;
procedure MovePanel(APanel: TUxDockable; AIndex: Integer);
procedure InsertPanel(APanel: TUxDockable; AIndex: Integer);
procedure ShowAppMenu;
procedure ApplyLayout(const ALayout: TUxLayout; ATakeOwnership: Boolean);
procedure RethinkConstraints;
procedure FocusSomething;
class property Instances: TList<TUxForm> read FInstances;
class property AppMenuCaption: string read FAppMenuCaption write SetAppMenuCaption;
class property AppBarStatus: string read FAppBarStatus write SetAppBarStatus;
class property AppMenu: TPopupMenu read FAppMenu write FAppMenu;
class procedure UpdateAppBars; static;
class procedure Relayout(ALayoutMode: Boolean);
class procedure CreateNewForm; overload;
class function CreateNewForm<T: TCustomForm>(AAdoptee: TControl = nil): T; overload;
class function CreateNewForm(AClass: TCustomFormClass): TCustomForm; overload;
end;
PPanelOleRec = ^TPanelOleRec;
TPanelOleRec = record
Sign: UInt64;
PID: DWORD;
Wnd: HWND;
Obj: TUxPanel;
end;
TUxContainerMenu = class(TPopupMenu)
strict private class var
FSource: TUxContainer;
FmiAutoSizeAll: TMenuItem;
FmiAddPanel: TMenuItem;
private
class procedure mnuAutoSizeAllClick(Sender: TObject);
class procedure mnuAddPanelClick(Sender: TObject);
public
procedure UxPopup(ASource: TUxContainer; X: Integer; Y: Integer);
procedure Popup(X: Integer; Y: Integer); override;
constructor Create(AOwner: TComponent); override;
end;
TUxPanelMenu = class(TPopupMenu)
strict private class var
FSource: TUxPanel;
FmiClose: TMenuItem;
FmiAutoSizeAll: TMenuItem;
FmiDetach: TMenuItem;
FmiSplitHorizontally: TMenuItem;
FmiSplitVertically: TMenuItem;
FmiCopyStatusText: TMenuItem;
FmiNewWindow: TMenuItem;
private
class procedure mnuCloseClick(Sender: TObject);
class procedure mnuAutoSizeAllClick(Sender: TObject);
class procedure mnuDetachClick(Sender: TObject);
class procedure mnuSplitHorizontallyClick(Sender: TObject);
class procedure mnuSplitVerticallyClick(Sender: TObject);
class procedure mnuNewWindowClick(Sender: TObject);
class procedure mnuCopyStatusBarText(Sender: TObject);
public
procedure UxPopup(ASource: TUxPanel; X: Integer; Y: Integer);
procedure Popup(X: Integer; Y: Integer); override;
constructor Create(AOwner: TComponent); override;
end;
TUxDockable = class(TCustomControl)
private class var
FContainerMenu: TUxContainerMenu;
FPanelMenu: TUxPanelMenu;
private const
FMT_ASPANEL = 0;
private class var
Formats: TFormatEtcArray;
protected type
TEnumFormatEtc = class(TInterfacedObject, IEnumFORMATETC)
strict private
FIndex: Integer;
public
function Next(celt: Longint; out elt;
pceltFetched: PLongint): HResult; stdcall;
function Skip(celt: Longint): HResult; stdcall;
function Reset: HResult; stdcall;
function Clone(out Enum: IEnumFormatEtc): HResult; stdcall;
end;
procedure WMWindowPosChanged(var Message: TWMWindowPosChanged);
message WM_WINDOWPOSCHANGED;
private
FLegacy: Boolean;
SectionSize: Double;
Replacing: Boolean;
LayoutOrder: Integer;
procedure ScreenCoordsChanged; virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Legacy: Boolean read FLegacy write FLegacy;
class constructor ClassCreate;
class destructor ClassDestroy;
function OnlyChild: Boolean;
function Floating: Boolean; reintroduce;
procedure FocusContent; virtual;
end;
TPanelClassRec = record
Name: string;
Exts: TArray<string>;
FormClass: TCustomFormClass;
ClassLevel: Integer;
constructor Create(const AName: string;
const AExts: TArray<string>; const AFormClass: TCustomFormClass;
const AClassLevel: Integer);
end;
TUxPanel = class(TUxDockable, IDropSource, IDataObject)
strict private
var
FGUID: TGUID;
FCaptionSize: Integer;
FCaptionColor: TColor;
FInactiveCaptionColor: TColor;
FWindowedColor: TColor;
FAlignment: TAlignment;
FCaptionRect, FEllipsisRect, FTextRect, FFreeArea, FStatusRect: TRect;
FBorderWidth: Integer;
FStatusHints: Boolean;
private
FActivePanel: Boolean;
FIntrinsicSize: TSize;
strict private
FCaptionFont: TFont;
FMouseDownPoint: TPoint;
FDragDetect: Boolean;
FClassCombo: TComboBox;
FOkButton: TUxButton;
FCreatedWith: Boolean;
FStatusBar: Boolean;
FLeftStatusClick,
FRightStatusClick: Boolean;
FStatusText: string;
FToolMenu: TPopupMenu;
FToolButtonDown: Boolean;
FHighlightLevel: Integer;
FModalCover: TUxClient;
FHighlightTimer: TTimer;
FFlashTimer: TTimer;
FFreeElf: Boolean;
FLeftStatusTextRect,
FRightStatusTextRect: TRect;
private
const
ITEM_ELLIPSIS = 1;
ITEM_STATUSLEFT = 2;
ITEM_STATUSRIGHT = 3;
strict private
var
FHotItem: Integer;
FMouseDownItem: Integer;
function GetDisplayCaption: string; inline;
procedure SetCaptionSize(ACaptionSize: Integer);
procedure SetCaptionColor(ACaptionColor: TColor);
procedure SetInactiveCaptionColor(AInactiveCaptionColor: TColor);
procedure SetAlignment(AAlignment: TAlignment);
procedure SetBorderWidth(ABorderWidth: Integer);
procedure SetToolMenu(AToolMenu: TPopupMenu);
procedure UpdateMetrics;
procedure NeedMetrics;
procedure CaptionFontChange(Sender: TObject);
procedure AlignClassCtrls;
procedure OkButtonClick(Sender: TObject);
procedure ClassComboEnter(Sender: TObject);
procedure ClassComboExit(Sender: TObject);
procedure SetStatusBar(const Value: Boolean);
procedure SetStatusText(const Value: string);
strict private
class var FInstances: TList<TUxPanel>;
class var FCurrentPanel: TUxPanel;
class var FAppEvents: TApplicationEvents;
class procedure AppActivate(Sender: TObject);
class procedure AppDeactivate(Sender: TObject);
class procedure AppShortCut(var Msg: TWMKey; var Handled: Boolean);
class procedure AppModalBegin(Sender: TObject);
class procedure AppModalEnd(Sender: TObject);
class procedure AppHint(Sender: TObject);
class procedure SetActivePanel(ANewPanel: TUxPanel);
class constructor ClassCreate;
class destructor ClassDestroy;
class procedure ActiveFormChange;
class var FChangeNotifications: TList<TProc>;
class var FChangeNotificationTimer: TTimer;
class procedure ChangeNotificationTimer(Sender: TObject);
class var FActivePanelNotifications: TList<TProc>;
class var FActivePanelNotificationTimer: TTimer;
class procedure ActivePanelNotificationTimer(Sender: TObject);
function GetPanelClassRec: TPanelClassRec;
procedure HighlightTimerTimer(Sender: TObject);
procedure FlashTimerTimer(Sender: TObject);
private
class procedure ApplyLayoutOrder;
class procedure Cleanup;
class var FPanelClasses: TDictionary<string, TPanelClassRec>;
class var FSortedPanelClasses: TList<TPanelClassRec>;
class procedure DoChangeNotification; static;
class procedure DoActivePanelNotification; static;
procedure ScreenCoordsChanged; override;
protected
procedure Paint; override;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure WMKillFocus(var Message: TMessage); message WM_KillFOCUS;
procedure ChangeScale(M, D: Integer; isDpiChange: Boolean); override;
procedure Loaded; override;
procedure Resize; override;
procedure DoEnter; override;
procedure DoExit; override;
procedure DoPanelMenuPopup; virtual;
procedure DoToolMenuPopup; virtual;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure PanelShortCut(var Msg: TWMKey; var Handled: Boolean); virtual;
procedure BeginActive; virtual;
procedure EndActive; virtual;
function CanClose: Boolean; virtual;
procedure ValidateInsert(AComponent: TComponent); override;
procedure ModalBegin; virtual;
procedure ModalEnd; virtual;
procedure UpdateStatusBar; virtual;
procedure SetParent(AParent: TWinControl); override;
function GiveFeedback(dwEffect: Longint): HRESULT; stdcall;
function QueryContinueDrag(fEscapePRessed: BOOL; grfKeyState: Longint): HRESULT;
stdcall;
function GetMatchingFormatIdx(const AFormatEtc: TFormatEtc): Integer;
function DAdvise(const formatetc: tagFORMATETC; advf: Integer;
const advSink: IAdviseSink; out dwConnection: Integer): HRESULT; stdcall;
function DUnadvise(dwConnection: Integer): HRESULT; stdcall;
function EnumDAdvise(out enumAdvise: IEnumSTATDATA): HRESULT; stdcall;
function EnumFormatEtc(dwDirection: Integer;
out enumFormatEtc: IEnumFORMATETC): HRESULT; stdcall;
function GetCanonicalFormatEtc(const formatetc: tagFORMATETC;
out formatetcOut: tagFORMATETC): HRESULT; stdcall;
function GetData(const formatetcIn: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT; stdcall;
function GetDataHere(const formatetc: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT; stdcall;
function QueryGetData(const formatetc: tagFORMATETC): HRESULT; stdcall;
function SetData(const formatetc: tagFORMATETC; var medium: tagSTGMEDIUM;
fRelease: LongBool): HRESULT; stdcall;
public
constructor Create(AOwner: TComponent); override;
constructor CreateWith(AForm: TCustomForm); overload;
constructor CreateWith(AForm: TCustomFormClass; AAdoptee: TControl = nil); overload;
constructor CreateWith(const APanelClass: string); overload;
destructor Destroy; override;
procedure AfterConstruction; override;
function PanelRec: TPanelRec;
function HitTest(const P: TPoint): Integer;
class function PanelRecArr: TArray<TPanelRec>;
function TryGetMainChild<T: TCustomForm>(out AChild: T): Boolean;
procedure RequestClientSize(AWidth, AHeight: Integer); overload; virtual;
procedure RequestClientSize(const ASize: TSize); overload;
procedure BeginHighlight; virtual;
procedure EndHighlight; virtual;
procedure Flash;
property CaptionRect: TRect read FCaptionRect;
property TextRect: TRect read FTextRect;
property DisplayCaption: string read GetDisplayCaption;
class procedure UxThemeUpdate; static;
procedure ThemeUpdate; virtual;
property GUID: TGUID read FGUID;
property CaptionColor: TColor read FCaptionColor write SetCaptionColor;
property InactiveCaptionColor: TColor read FInactiveCaptionColor write SetInactiveCaptionColor;
property WindowedColor: TColor read FWindowedColor;
property StatusBar: Boolean read FStatusBar write SetStatusBar;
property LeftStatusClick: Boolean read FLeftStatusClick write FLeftStatusClick;
property RightStatusClick: Boolean read FRightStatusClick write FRightStatusClick;
property StatusText: string read FStatusText write SetStatusText;
property StatusRect: TRect read FStatusRect;
property FreeArea: TRect read FFreeArea;
procedure SplitHorizontally;
procedure SplitVertically;
procedure Detach;
procedure Close;
procedure MakeFree;
class function PanelClassFromName(const AName: string; ADefault: TCustomFormClass = nil): TCustomFormClass;
class procedure RegisterChangeNotification(const AProc: TProc);
class procedure RegisterActivePanelNotification(const AProc: TProc);
class property Instances: TList<TUxPanel> read FInstances;
class property ActivePanel: TUxPanel read FCurrentPanel;
function IsDisposable: Boolean;
function IsVolatile: Boolean;
procedure FocusContent; override;
published
property Align;
property Alignment: TAlignment read FAlignment write SetAlignment
default taLeftJustify;
property Anchors;
property BorderWidth: Integer read FBorderWidth write SetBorderWidth;
property PanelClass: TPanelClassRec read GetPanelClassRec;
property Caption;
property CaptionSize: Integer read FCaptionSize write SetCaptionSize;
property Color;
property Constraints;
property Ctl3D;
property DockSite;
property DoubleBuffered;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ToolMenu: TPopupMenu read FToolMenu write SetToolMenu;
property ParentBiDiMode;
property ParentBackground;
property ParentColor;
property ParentCtl3D;
property ParentDoubleBuffered;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Touch;
property Visible;
property StyleElements;
property OnAlignInsertBefore;
property OnAlignPosition;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGesture;
property OnGetSiteInfo;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
TUxContainer = class(TUxDockable, IDropTarget, IUxDockSite)
strict private
type
TSplitterRec = record
Region: TRect;
A, B: TUxDockable;
end;
var
FOrientation: TUxContainerOrientation;
FSplitters: TList<TSplitterRec>;
FDragSplitter: TSplitterRec;
FDragPos: TPoint;
class var
FAppEvents: TApplicationEvents;
FResizeCtl: TUxContainer;
private
const
BorderPaddingInvariant1 = 0;
InternalPaddingInvariant1 = 6;
BorderPaddingInvariant2 = 5;
InternalPaddingInvariant2 = 10;
var
FSections: TList<TUxDockable>;
procedure SetOrientation(const Value: TUxContainerOrientation);
function PanelArray: TArray<TUxDockable>;
function SplitterHitTest(const P: TPoint): TSplitterRec;
function GetSize(const ARect: TRect): Integer; overload;
function GetSize(AControl: TUxDockable): Integer; overload;
procedure SetSize(AControl: TUxDockable; ASize: Integer); overload;
procedure IncSize(AControl: TUxDockable; D: Integer);
function GetPos(const P: TPoint): Integer; overload;
function GetPos(ARect: TRect): Integer; overload;
function GetPos(AControl: TUxDockable): Integer; overload;
procedure ExpandBackwards(AControl: TUxDockable; D: Integer);
procedure PointDelta1D(var P: TPoint; const ANewPoint: TPoint; out D: Integer);
function ValidateSplitter(var ASplitter: TSplitterRec): Boolean;
function ValidateControl(AControl: TControl): Boolean;
function Shrink1D(const R: TRect): TRect;
procedure BeginPopup;
procedure EndPopup;
class procedure BeginLayout;
class procedure EndLayout;
class procedure BeginLayout_Internal;
class procedure EndLayout_Internal;
class function BorderPaddingInvariant: Integer;
class function InternalPaddingInvariant: Integer;
class procedure Relayout;
class procedure Cleanup;
strict private
FCancelResize: Boolean;
FCtxPopup: Boolean;
FNoCtxPopup: Boolean;
FUxDockSite: TUxDockSite;
class var FDebugMode: Boolean;
class var FLayoutMode_External: Boolean;
class var FLayoutMode_Internal: Boolean;
class var FLayoutModeTimer: TTimer;
class procedure LayoutModeTimerTimer(Sender: TObject);
class var FInstances: TList<TUxContainer>;
class constructor ClassCreate;
class destructor ClassDestroy;
class procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
procedure CancelResize;
function FirstBorderPaddingRect: TRect;
function LastBorderPaddingRect: TRect;
function IsStronglySuperfluous: Boolean;
function IsWeaklySuperfluous: Boolean;
procedure FormRethinkConstraints;
class procedure SetDebugMode(const Value: Boolean); static;
private
function FindInsertionPoint(const APoint: TPoint): Integer;
procedure ScreenCoordsChanged; override;
protected
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure CreateWnd; override;
procedure DestroyWnd; override;
procedure Paint; override;
property UxDockSite: TUxDockSite read FUxDockSite implements IDropTarget;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
class procedure UxThemeUpdate; static;
procedure ArrangeAll;
procedure MovePanel(APanel: TUxDockable; AIndex: Integer);
procedure RemovePanel(APanel: TUxDockable);
procedure InsertPanel(APanel: TUxDockable; AIndex: Integer);
class property DebugMode: Boolean read FDebugMode write SetDebugMode;
class function LayoutMode: Boolean;
class property Instances: TList<TUxContainer> read FInstances;
published
property Align;
property Anchors;
property Caption;
property Color;
property Constraints;
property Ctl3D;
property DockSite;
property DoubleBuffered;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property Orientation: TUxContainerOrientation read FOrientation write SetOrientation;
property ParentBiDiMode;
property ParentBackground;
property ParentColor;
property ParentCtl3D;
property ParentDoubleBuffered;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Touch;
property Visible;
property StyleElements;
property OnAlignInsertBefore;
property OnAlignPosition;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGesture;
property OnGetSiteInfo;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
TUxSplitter = class(ExtCtrls.TSplitter)
strict private
class var FInstances: TList<TUxSplitter>;
class constructor ClassCreate;
class destructor ClassDestroy;
protected
procedure Loaded; override;
procedure RequestAlign; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
class procedure UxThemeUpdate; static;
property Align;
property AutoSnap;
property Beveled;
property Cursor;
property Color;
property Constraints;
property MinSize;
property ParentColor;
property PopupMenu;
property ResizeStyle;
property Visible;
property Width;
property StyleElements;
property OnCanResize;
property OnMoved;
property OnPaint;
end;
TUxClient = class(TCustomControl)
strict private
FMousePassthrough: Boolean;
FSizeGrip: Boolean;
FSizeGripSize: Integer;
FWindowedColor: Boolean;
class var FInstances: TList<TUxClient>;
class constructor ClassCreate;
class destructor ClassDestroy;
procedure SetSizeGrip(const Value: Boolean);
procedure SetWindowedColor(const Value: Boolean);
protected
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
class procedure UxThemeUpdate; static;
property SizeGripSize: Integer read FSizeGripSize;
published
property Align;
property Anchors;
property Caption;
property Constraints;
property Ctl3D;
property DockSite;
property DoubleBuffered;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property MousePassthrough: Boolean read FMousePassthrough write FMousePassthrough default False;
property ParentBiDiMode;
property ParentBackground;
property ParentColor;
property ParentCtl3D;
property ParentDoubleBuffered;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property SizeGrip: Boolean read FSizeGrip write SetSizeGrip default False;
property TabOrder;
property TabStop;
property Touch;
property Visible;
property StyleElements;
property WindowedColor: Boolean read FWindowedColor write SetWindowedColor;
property OnAlignInsertBefore;
property OnAlignPosition;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGesture;
property OnGetSiteInfo;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
TUxClientLayer = class(TUxClient)
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
end;
TUxLabel = class(TLabel)
protected
procedure Paint; override;
end;
TUxButtonActionLink = class(TWinControlActionLink)
protected
FClient: TUxButton;
procedure AssignClient(AClient: TObject); override;
function IsCheckedLinked: Boolean; override;
procedure SetChecked(Value: Boolean); override;
end;
TUxButton = class(TCustomControl)
strict private
class var FInstances: TList<TUxButton>;
class constructor ClassCreate;
class destructor ClassDestroy;
private
FActive: Boolean;
FHot: Boolean;
FDown: Boolean;
FModalResult: TModalResult;
FCancel: Boolean;
FDefault: Boolean;
FShorterCaptions: TArray<string>;
procedure SetDefault(const Value: Boolean);
procedure SetDown(const Value: Boolean);
function IsDownStored: Boolean;
protected
procedure Paint; override;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
procedure WMKillFocus(var Message: TMessage); message WM_KillFOCUS;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure Click; override;
procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
function GetActionLinkClass: TControlActionLinkClass; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
class procedure UxThemeUpdate; static;
property ShorterCaptions: TArray<string> read FShorterCaptions write FShorterCaptions;
published
property Action;
property Align;
property Anchors;
property Cancel: Boolean read FCancel write FCancel default False;
property Caption;
property Constraints;
property Ctl3D;
property Default: Boolean read FDefault write SetDefault default False;
property DockSite;
property DoubleBuffered;
property Down: Boolean read FDown write SetDown stored IsDownStored default False;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ModalResult: TModalResult read FModalResult write FModalResult default 0;
property ParentBiDiMode;
property ParentBackground;
property ParentColor;
property ParentCtl3D;
property ParentDoubleBuffered;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop default True;
property Touch;
property Visible;
property StyleElements;
property OnAlignInsertBefore;
property OnAlignPosition;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGesture;
property OnGetSiteInfo;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
TSimpleMenuEvent = procedure(Sender: TObject; AID: Integer) of object;
TSimpleMenuGetStateEvent = procedure(Sender: TObject; AID: Integer;
var AVisible, AEnabled, AChecked: Boolean) of object;
TSimpleMenuItem = class(TMenuItem)
public
CmdID: Integer;
end;
TMenuItemRec = record
Caption,
Hint: string;
Enabled,
Checked,
RadioItem: Boolean;
CmdID: Integer;
ObjRef: NativeInt;
GUID: TGUID;
end;
TCustomSubmenu = class;
TCustomMenuItemClick = reference to procedure(Sender: TCustomSubmenu; CmdID: Integer;
AObj: NativeInt; const AGUID: TGUID);
TCustomSubmenuCtor = TFunc<TArray<TMenuItemRec>>;
TCustomSubmenu = class(TMenuItem)
public
Handler: TCustomMenuItemClick;
Ctor: TCustomSubmenuCtor;
procedure Click; override;
end;
TCustomSubmenuItem = class(TMenuItem)
strict private
procedure DummyClick(Sender: TObject);
public
CmdID: Integer;
ObjRef: NativeInt;
GUID: TGUID;
constructor CreateAndInit(AOwner: TComponent; const AData: TMenuItemRec);
procedure Click; override;
end;
TSimpleMenu = class(TPopupMenu)
strict private
FOnExecute: TSimpleMenuEvent;
FOnGetState: TSimpleMenuGetStateEvent;
FSubmenus: TArray<TMenuItem>;
FEnabled: Boolean;
procedure CmdInvoked(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
function AddSubmenu(const AText, AHint: string): Integer;
procedure AddCustomSubmenu(const AText, AHint: string; ACtor: TCustomSubmenuCtor;
AHandler: TCustomMenuItemClick);
procedure AddCommand(AID: Integer; const AText, AHint: string;
ARadio: Boolean = False); overload;
procedure AddCommand(AID, ASubmenuIndex: Integer; const AText, AHint: string;
ARadio: Boolean = False); overload;
procedure Popup(X: Integer; Y: Integer); override;
property Enabled: Boolean read FEnabled write FEnabled;
published
property OnCmdExec: TSimpleMenuEvent read FOnExecute write FOnExecute;
property OnGetState: TSimpleMenuGetStateEvent read FOnGetState write FOnGetState;
end;
TPanelFormClass = class of TPanelForm;
TPanelForm = class(TForm)
public const
PAN_SHOWTOOLBAR = -101;
strict private
FGUID: TGUID;
private
function GetStatusBar: Boolean;
function GetStatusText: string;
procedure SetStatusBar(const Value: Boolean);
procedure SetStatusText(const Value: string);
function GetToolMenu: TPopupMenu;
procedure SetToolMenu(const Value: TPopupMenu);
procedure MenuCmdExec(Sender: TObject; AID: Integer);
procedure MenuGetState(Sender: TObject; AID: Integer;
var AVisible, AEnabled, AChecked: Boolean);
function GetShowToolbar: Boolean;
procedure SetShowToolbar(const Value: Boolean);
procedure RequireToolbar;
procedure ToolbarTimerTimer(Sender: TObject);
function GetLeftStatusClick: Boolean;
function GetRightStatusClick: Boolean;
procedure SetLeftStatusClick(const Value: Boolean);
procedure SetRightStatusClick(const Value: Boolean);
protected
FStatusBar: Boolean;
FLeftStatusClick, FRightStatusClick: Boolean;
FStatusText: string;
FToolMenu: TPopupMenu;
FToolBar: TUxClient;
FToolBarControls: TArray<TControl>;
FToolbarDirty: Boolean;
FToolbarTimer: TTimer;
FToolbarCaptions: TDictionary<TUxButton, string>;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure SetParent(AParent: TWinControl); override;
procedure ThemeUpdate; virtual;
procedure PanelShortCut(var Msg: TWMKey; var Handled: Boolean); virtual;
procedure BeginActive; virtual;
procedure EndActive; virtual;
function CanClose: Boolean; virtual;
procedure BeginHighlight;
procedure EndHighlight;
procedure FocusSender(Sender: TObject); virtual;
procedure CmdExec(AID: Integer); virtual;
procedure CmdGetState(AID: Integer; var AVisible, AEnabled, AChecked: Boolean); virtual;
procedure ChangeScale(M: Integer; D: Integer; isDpiChange: Boolean); override;
procedure UpdateToolbar; virtual;
procedure LoadFromFile(const AFileName: string); virtual;
procedure ScreenCoordsChanged; virtual;
procedure SetupToolMenu; virtual;
procedure SetupToolbar; virtual;
procedure LoadSettings; virtual;
procedure FirstShow; virtual;
procedure Resize; override;
procedure PanelEvent(AEventID: Integer); virtual;
procedure FontFix;
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
constructor CreateNewWith(AOwner: TComponent; AAdoptee: TControl); virtual;
destructor Destroy; override;
procedure RequestClientSize(AWidth, AHeight: Integer); overload; virtual;
procedure RequestClientSize(const ASize: TSize); overload;
function Panel: TUxPanel;
procedure CreateToolMenu;
function AddToolbarControl<T: TControl>(ASubclass: TControlClass = nil): T;
procedure AfterConstruction; override;
procedure ScaleForPPI(NewPPI: Integer); override;
property GUID: TGUID read FGUID;
property StatusBar: Boolean read GetStatusBar write SetStatusBar;
property StatusText: string read GetStatusText write SetStatusText;
property LeftStatusClick: Boolean read GetLeftStatusClick write SetLeftStatusClick;
property RightStatusClick: Boolean read GetRightStatusClick write SetRightStatusClick;
property ToolMenu: TPopupMenu read GetToolMenu write SetToolMenu;
function SimpleMenu: TSimpleMenu;
property ShowToolBar: Boolean read GetShowToolbar write SetShowToolbar;
class function IsDisposable: Boolean; virtual;
function IsVolatile: Boolean; virtual;
end;
TListForm = class(TPanelForm)
private
const
TLF_REFRESH = 1;
var
FListView: TListViewEx;
FPopupMenu: TPopupMenu;
FRefresher: TTimer;
procedure BuildContextMenu;
procedure RefreshClick(Sender: TObject);
procedure CopyRowsClick(Sender: TObject);
procedure SelectAllClick(Sender: TObject);
protected
var
FmiDefault: TMenuItem;
FmiDelete: TMenuItem;
FmiRefresh: TMenuItem;
FmiCopyRows: TMenuItem;
FmiSelectAll: TMenuItem;
type
TRowIdentity = (riNone, riCaption, riData);
TRowIdentityRec = record
Mode: TRowIdentity;
Caption: string;
Data: Pointer;
class operator Equal(const Left, Right: TRowIdentityRec): Boolean; static;
function Matches(AItem: TListItem): Boolean;
constructor Create(AMode: TRowIdentity; AItem: TListItem); overload;
constructor Create(const ACaption: string); overload;
constructor Create(AData: Pointer); overload;
end;
TColumnRec = record
Caption: string;
Width: Integer;
SortMethod: TColumnSortMethod;
end;
TDataRow = record
Columns: TArray<Variant>;
Data: NativeUInt;
end;
class function CR(const ACaption: string; AWidth: Integer;
ASortMethod: TColumnSortMethod): TColumnRec; static;
class function GetColumns: TArray<TColumnRec>; virtual;
class function GetData: TArray<TDataRow>; virtual;
class function DataRow(const AValues: array of Variant;
AData: NativeUInt = 0): TDataRow; static;
procedure LVKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); virtual;
procedure LVSelCntChange(Sender: TObject);
procedure UpdateStatusBar; virtual;
procedure PopupMenuPopup(Sender: TObject); virtual;
procedure DefaultClick(Sender: TObject); virtual;
procedure DeleteClick(Sender: TObject); virtual;
procedure RefresherTimer(Sender: TObject);
protected
procedure FirstShow; override;
property ListView: TListViewEx read FListView;
property PopupMenu: TPopupMenu read FPopupMenu;
procedure CmdExec(AID: Integer); override;
procedure SetupToolMenu; override;
function RowIdentity: TRowIdentity; virtual;
public
constructor Create(AOwner: TComponent); override;
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
procedure Refresh; virtual;
class function IsDisposable: Boolean; override;
end;
[Panel('Window manager')]
TWndMgrForm = class(TListForm, IHelpfulControl)
strict private
class var FInstances: TList<TWndMgrForm>;
class constructor ClassCreate;
class destructor ClassDestroy;
class var FHasReg: Boolean;
var FActivePanel: TUxPanel;
FmiNewPanel: TMenuItem;
FmiMoveUp: TMenuItem;
FmiMoveDown: TMenuItem;
private const
WMF_NEWWIN = 10;
protected
class function GetColumns: TArray<TListForm.TColumnRec>; override;
class function GetData: TArray<TListForm.TDataRow>; override;
procedure DefaultClick(Sender: TObject); override;
procedure DeleteClick(Sender: TObject); override;
procedure PopupMenuPopup(Sender: TObject); override;
procedure UpdateActive;
procedure LvCustomDrawItem(Sender: TCustomListView; Item: TListItem;
State: TCustomDrawState; var DefaultDraw: Boolean);
procedure mnuNewPanelClick(Sender: TObject);
procedure mnuMovePanelUpClick(Sender: TObject);
procedure mnuMovePanelDownClick(Sender: TObject);
procedure CmdExec(AID: Integer); override;
procedure LVKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); override;
procedure SetupToolMenu; override;
function RowIdentity: TListForm.TRowIdentity; override;
public
class procedure WndChNot; static;
class procedure ActChNot; static;
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
destructor Destroy; override;
function ContextHelp: Boolean;
end;
[Panel('UX colour selector')]
TUxColorForm = class(TPanelForm, IHelpfulControl)
strict private
const
UCF_ADVPICK = 1;
UCF_RESTORE = 2;
var
FHueCtl: THueSelector;
FSVCtl: TSVColorMap;
protected
procedure HueChanged(Sender: TObject); virtual;
procedure SatValChanged(Sender: TObject); virtual;
procedure UpdateStatusText; virtual;
procedure ThemeChanged;
procedure RestoreDefaultColor(Sender: TObject);
procedure ShowAdvancedPicker(Sender: TObject);
procedure CmdExec(AID: Integer); override;
procedure SetupToolMenu; override;
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
function CurrentColor: TColor;
function ContextHelp: Boolean;
class function IsDisposable: Boolean; override;
end;
TTextEditorFormClass = class of TTextEditorForm;
[Panel('Text editor')]
TTextEditorForm = class(TPanelForm)
protected
const
TEF_NEW = 1;
TEF_OPEN = 2;
TEF_SAVE = 3;
TEF_SAVEAS = 4;
TEF_RELOAD = 5;
TEF_DUPBUF = 6;
TEF_DUPSEL = 7;
TEF_OPENFOLDER = 8;
TEF_COPYFILENAME = 9;
TEF_PRINT = 10;
TEF_TOXHTML = 11;
TEF_NEWWIN = 12;
TEF_EXPORT = 13;
TEF_IMPORT = 14;
TEF_RULER = 101;
TEF_CBEYOND = 102;
TEF_SHOWHIDDEN = 103;
TEF_AUTOREPLACE = 104;
TEF_LINEHIGHL = 105;
TEF_FONT = 106;
TEF_CUSTZOOM = 107;
TEF_HISTORY = 201;
TEF_FILLCHAR = 202;
TEF_SORT = 203;
TEF_MAKEUNIQUE = 204;
TEF_TRUNCLINE = 205;
TEF_FILTERLINES = 206;
TEF_TRIMRIGHT = 207;
TEF_FIND = 301;
TEF_FINDNEXT = 302;
TEF_FINDPREV = 303;
TEF_FINDSYMB = 304;
TEF_FINDCHR = 305;
TEF_REPLACE = 306;
TEF_GOTO = 307;
TEF_DATETIME = 401;
TEF_CDATETIME = 402;
TEF_LOREM = 403;
TEF_INSCOLOR = 404;
TEF_DOC = 501;
TEF_ARL = 502;
TEF_STATS = 601;
SYN_LOW = 1000;
SYN_NONE = 1000;
SYN_XML = 1001;
SYN_HTML = 1002;
SYN_CSS = 1003;
SYN_MW = 1004;
SYN_PAS = 1005;
SYN_AS = 1006;
SYN_ASML = 1007;
SYN_INI = 1008;
SYN_HIGH = SYN_INI;
strict private
const
EditingCommands:
array[0..12] of Integer
=
(TEF_FILLCHAR, TEF_SORT, TEF_MAKEUNIQUE, TEF_TRUNCLINE, TEF_FILTERLINES, TEF_TRIMRIGHT, TEF_REPLACE, TEF_DATETIME, TEF_CDATETIME, TEF_LOREM, TEF_INSCOLOR, TEF_IMPORT, TEF_AUTOREPLACE);
strict private
const
FPs: array[SYN_LOW .. SYN_HIGH] of TFormattingProcessorClass =
(
nil,
TXMLFormattingProcessor,
THTMLFormattingProcessor,
TCSSFormattingProcessor,
TMediaWikiFormattingProcessor,
TPascalFormattingProcessor,
TAlgosim3FormattingProcessor,
TASRefFormattingProcessor,
TINIFormattingProcessor
);
strict private
var
FEditor: TTextEditor;
eFindText: TTextEditor;
btnMatchCase,
btnWholeWords,
btnCRLF: TUxButton;
lblCount: TLabel;
btnNext,
btnPrev: TUxButton;
FReplaceFrm: TReplaceFrm;
FEditorNotificationText: string;
FPrintProgressForm: TUxClient;
FDoAbortPrint: Boolean;
procedure FindTextChange(Sender: TObject);
procedure FindTextKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure DoInstantSearch(Sender: TObject = nil);
protected
var
FmnuFile,
FmnuEdit,
FmnuFind,
FmnuView,
FmnuInsert,
FmnuOptions,
FmnuTools,
FmnuSyntax,
FmnuHelp
: Integer;
function GetEditorSubclass: TTextEditorClass; virtual;
function DoSave: Boolean; virtual;
function DoSaveAs(AExport: Boolean = False): Boolean; virtual;
procedure SaveAsDialogExecute(Sender: TObject); virtual;
procedure SaveAsDialogOnOKClick(Sender: TObject; var CanClise: Boolean); virtual;
function CheckModified: Boolean; virtual;
procedure EditorSelChange(Sender: TObject); virtual;
procedure EditorZoomChange(Sender: TObject); virtual;
procedure EditorChanged(Sender: TObject); virtual;
procedure EditorModified(Sender: TObject); virtual;
procedure EditorSimpleNotification(Sender: TObject; MsgID: Cardinal; const AMsg: string);
procedure EditorPrintBegin(Sender: TObject; NumSteps: Integer);
function EditorPrintProgress(Sender: TObject; CurStep, NumSteps: Integer): Boolean;
procedure EditorPrintEnd(Sender: TObject);
procedure EditorAbortPrint(Sender: TObject);
procedure EditorPrintProgressFormResize(Sender: TObject);
procedure UpdateCaption; virtual;
procedure ApplyFP; virtual;
procedure Find(const AText: string = ''); virtual;
procedure FindNext(Sender: TObject = nil); virtual;
procedure FindPrev(Sender: TObject = nil); virtual;
procedure FindSymbol; virtual;
procedure PanelShortCut(var Msg: TWMKey; var Handled: Boolean); override;
procedure BeginActive; override;
procedure EndActive; override;
function CanClose: Boolean; override;
procedure FontDialogApply(Sender: TObject; Wnd: HWND);
procedure UpdateStatusBar; virtual;
function GetFilters: TArray<TPair<string, string>>; virtual;
procedure CmdExec(AID: Integer); override;
procedure CmdGetState(AID: Integer; var AVisible, AEnabled, AChecked: Boolean); override;
procedure LoadFromFile(const AFileName: string); override;
procedure SetupToolMenu; override;
procedure SetupToolbar; override;
procedure SetupFileNaming; virtual;
procedure FirstShow; override;
procedure PanelEvent(AEventID: Integer); override;
procedure SetupFileMasks(AItems: TFileTypeItems;
var ADefExtSansPeriod: string); virtual;
function GetClientGUID: TGUID; virtual;
public
procedure UpdatePanelCaption;
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
function IsVolatile: Boolean; override;
property Editor: TTextEditor read FEditor;
end;
[Panel('Image viewer', 'bmp,png,jpg,jpeg,tif,tiff,gif')]
TImageViewerForm = class(TPanelForm, IHelpfulControl)
strict private
var
FImageViewer: TImageViewer;
procedure SetBitmap(const Value: TBitmap);
procedure ImageViewerCaptionChange(Sender: TObject);
procedure ImageViewerBitmapChanged(Sender: TObject);
procedure ImageViewerZoomChange(Sender: TObject);
procedure ImageViewerNewWindowReq(Sender: TObject);
procedure UpdateStatusBar;
protected
procedure LoadFromFile(const AFileName: string); override;
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
function ContextHelp: Boolean;
property Bitmap: TBitmap write SetBitmap;
end;
TCharacterListView = class(TListViewEx, IDropSource, IDataObject)
private const
FMT_UNICODETEXT = 0;
class var
Formats: TFormatEtcArray;
class constructor ClassCreate;
type
TEnumFormatEtc = class(TInterfacedObject, IEnumFORMATETC)
strict private
FIndex: Integer;
public
function Next(celt: Longint; out elt;
pceltFetched: PLongint): HResult; stdcall;
function Skip(celt: Longint): HResult; stdcall;
function Reset: HResult; stdcall;
function Clone(out Enum: IEnumFormatEtc): HResult; stdcall;
end;
function GiveFeedback(dwEffect: Longint): HRESULT; stdcall;
function QueryContinueDrag(fEscapePRessed: BOOL; grfKeyState: Longint): HRESULT;
stdcall;
function GetMatchingFormatIdx(const AFormatEtc: TFormatEtc): Integer;
function DAdvise(const formatetc: tagFORMATETC; advf: Integer;
const advSink: IAdviseSink; out dwConnection: Integer): HRESULT; stdcall;
function DUnadvise(dwConnection: Integer): HRESULT; stdcall;
function EnumDAdvise(out enumAdvise: IEnumSTATDATA): HRESULT; stdcall;
function EnumFormatEtc(dwDirection: Integer;
out enumFormatEtc: IEnumFORMATETC): HRESULT; stdcall;
function GetCanonicalFormatEtc(const formatetc: tagFORMATETC;
out formatetcOut: tagFORMATETC): HRESULT; stdcall;
function GetData(const formatetcIn: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT; stdcall;
function GetDataHere(const formatetc: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT; stdcall;
function QueryGetData(const formatetc: tagFORMATETC): HRESULT; stdcall;
function SetData(const formatetc: tagFORMATETC; var medium: tagSTGMEDIUM;
fRelease: LongBool): HRESULT; stdcall;
strict private
FMouseDownPoint: TPoint;
FDragDetect: Boolean;
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
end;
[Panel('Character browser')]
TCharacterBrowser = class(TPanelForm, IHelpfulControl)
strict private
const
BRW_COPYCHAR = 1;
BRW_COPYDESC = 2;
BRW_COPYGROUP = 3;
BRW_COPYCP = 4;
CBF_ZOOMIN = 1;
CBF_ZOOMOUT = 2;
CBF_ZOOMDEF = 3;
CBF_FIND = 11;
CBF_FONT = 21;
var
FImages: TImageList;
FBrowser: TCharacterListView;
FBrowserPopup: TPopupMenu;
eFindText: TTextEditor;
FSearchMatch: Boolean;
FMatches: TArray<Integer>;
FFindTextTimer: TTimer;
FBlockLabel: TLabel;
FBlockMenu: TPopupMenu;
procedure FindTextChange(Sender: TObject);
procedure FindTextKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure BrowserData(Sender: TObject; Item: TListItem);
procedure BrowserCustomDrawItem(Sender: TCustomListView; Item: TListItem;
State: TCustomDrawState; var DefaultDraw: Boolean);
procedure BrowserKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure BrowserKeyPress(Sender: TObject; var Key: Char);
procedure BrowserSelCntChange(Sender: TObject);
procedure BrowserMenuItemClick(Sender: TObject);
procedure BrowserMenuPopup(Sender: TObject);
procedure UpdateStatusBar;
procedure FindTextTimerTimer(Sender: TObject);
procedure BlockLabelClick(Sender: TObject);
procedure BlockItemClick(Sender: TObject);
procedure BlockMenuPopup(Sender: TObject);
procedure FontDialogApply(Sender: TObject; Wnd: HWND);
protected
procedure PanelShortCut(var Msg: TWMKey; var Handled: Boolean); override;
procedure CmdExec(AID: Integer); override;
procedure SetupToolMenu; override;
procedure SetupToolbar; override;
procedure FirstShow; override;
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
function ContextHelp: Boolean;
class function IsDisposable: Boolean; override;
end;
TDebugLogItem = record
Time: TDateTime;
Text: string;
end;
[Panel('Debug log')]
TDbgLogForm = class(TPanelForm)
strict private
const
DLF_CLEAR = 1;
DLF_COPYALL = 2;
DLF_TOEDITOR = 3;
class var FDebugLog: TList<TDebugLogItem>;
class var FInstances: TList<TDbgLogForm>;
class var FAppEvents: TApplicationEvents;
class constructor ClassCreate;
class destructor ClassDestroy;
class procedure AppEventsException(Sender: TObject; E: Exception);
class procedure DebugLogAppended;
strict private
FListView: TListViewEx;
procedure RefreshLogView;
procedure ListViewData(Sender: TObject; Item: TListItem);
procedure ListViewSelCntChange(Sender: TObject);
procedure UpdateStatusBar;
protected
procedure CmdExec(AID: Integer); override;
procedure CmdGetState(AID: Integer; var AVisible, AEnabled, AChecked: Boolean); override;
procedure SetupToolMenu; override;
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
destructor Destroy; override;
class procedure DoLog(const AItem: TDebugLogItem); overload; static;
class procedure DoLog(const S: string); overload; static;
class procedure DoLog(const S: string; E: Exception); overload; static;
class procedure DoLog(E: Exception); overload; static;
class procedure ClearLog; static;
class function GetLog: TArray<string>; static;
class function IsDisposable: Boolean; override;
end;
[Panel('Clock')]
TClockForm = class(TPanelForm)
strict private
const
CLF_SHOWSECONDS = 1;
var
FClock: TClockCtl;
procedure ClockNewSec(Sender: TObject);
protected
procedure CmdExec(AID: Integer); override;
procedure CmdGetState(AID: Integer; var AVisible, AEnabled, AChecked: Boolean); override;
procedure SetupToolMenu; override;
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
destructor Destroy; override;
class function IsDisposable: Boolean; override;
end;
[Panel('Scale monitor')]
TScaleMonitor = class(TPanelForm)
strict private
FLabel: TLabel;
FTimer: TTimer;
procedure ScaleTimerTimer(Sender: TObject);
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
class function IsDisposable: Boolean; override;
end;
[Panel('Object browser')]
TObjBrowser = class(TListForm)
protected
class function GetData: TArray<TListForm.TDataRow>; override;
class function GetColumns: TArray<TListForm.TColumnRec>; override;
procedure PopupMenuPopup(Sender: TObject); override;
function RowIdentity: TListForm.TRowIdentity; override;
end;
procedure BeginBusyWork;
procedure EndBusyWork;
function TryNaturalStrToFloat(const S: string; out X: Double): Boolean;
function PrettyFormat(const Format: string; Args: array of const): string;
function DateTimeToStdStr(const T: TDateTime): string;
function DateTimeToStdStrMS(const T: TDateTime): string;
procedure Register;
procedure RegisterPanelClass(AClass: TCustomFormClass);
function IndexInt(const X: Integer; const Arr: array of Integer): Integer;
function GetTextEditorClass: TCustomFormClass;
procedure GotoPanel(APanelClass: TPanelFormClass);
var
DefaultLayoutName: string;
QuickLayouts: TArray<string>;
QuickLayoutIdx: Integer;
function EnumLayouts: TArray<string>;
procedure TidyQuickLayouts;
function GetLayoutPath(const AName: string): string;
function GetDefaultLayoutPath: string;
function LoadLayoutFromFile(const AFileName: string): TUxLayout;
var
CachedLayouts: TArray<string>;
implementation
uses
IOUtils, RichEdit, TextEncodings, TDMB, Math, StrUtils, ASColors, ScreenDispatch,
Rtti, ShellAPI, Clipbrd, ColorDialog, Character, MultiInput, SortWin, TruncateWin,
FilterWin, ChrSearchWin, TimeWin, StatisticsWin, UnicodeData, ClientVisuals, DwmApi,
ASConsole, XmlIntf, XmlDoc;
function GetParentFormSafe(AControl: TControl): TCustomForm;
begin
if Assigned(AControl) then
Result := GetParentForm(AControl)
else
Result := nil;
end;
function EnumLayouts: TArray<string>;
begin
Result := nil;
try
Result := Result +
TDirectory.GetFiles(
TPath.Combine(ExtractFilePath(Application.ExeName), 'Layouts'), '*.as-layout'
);
except
on EDirectoryNotFoundException do;
end;
try
Result := Result +
TDirectory.GetFiles(
TPath.Combine(TPath.GetHomePath, 'Rejbrand\Algosim\Layouts'), '*.as-layout'
);
except
on EDirectoryNotFoundException do;
end;
CachedLayouts := Copy(Result);
end;
procedure TidyQuickLayouts;
begin
var L := TArray<string>(nil);
for var LQuickLayout in QuickLayouts do
begin
const S = LQuickLayout.Trim;
if not S.IsEmpty and FileExists(GetLayoutPath(S)) then
L := L + [S];
end;
QuickLayouts := L;
end;
function GetLayoutPath(const AName: string): string;
begin
Result :=
TPath.Combine(TPath.Combine(TPath.GetHomePath, 'Rejbrand\Algosim\Layouts'),
AName + '.as-layout');
if FileExists(Result) then
Exit;
Result :=
TPath.Combine(TPath.Combine(ExtractFilePath(Application.ExeName), 'Layouts'),
AName + '.as-layout');
end;
function GetDefaultLayoutPath: string;
begin
Result := GetLayoutPath(DefaultLayoutName);
end;
function LoadLayoutFromFile(const AFileName: string): TUxLayout;
function StrToOrientation(S: OleVariant): TUxContainerOrientation;
begin
if VarIsStr(S) and (S = 'vertical') then
Result := uxoVertical
else
Result := uxoHorizontal;
end;
procedure ParseAttributes(ANode: IXMLNode; ALayoutItem: TUxLayoutItem);
begin
if ANode.HasAttribute('size') then
begin
var LSizeVal := string(ANode.Attributes['size']);
const LIsPctg = LSizeVal.Trim.EndsWith('%');
if LIsPctg then
begin
LSizeVal := Copy(LSizeVal.Trim, 1, LSizeVal.Length - 1).Trim;
var LSizeNumVal: Integer;
if TryStrToInt(LSizeVal, LSizeNumVal) then
ALayoutItem.Size := LSizeNumVal / 100.0;
end;
end;
ALayoutItem.Default := ANode.HasAttribute('default') and (ANode.Attributes['default'] = 'true');
end;
procedure PopulateStack(AStack: TUxLayoutStack; ANode: IXMLNode);
begin
if (AStack = nil) or (ANode = nil) then
Exit;
for var i := 0 to ANode.ChildNodes.Count - 1 do
begin
var LChild := ANode.ChildNodes[i];
var LItem := TUxLayoutItem(nil);
if LChild.NodeName = 'panel' then
LItem := TUxLayoutPanel.Create(LChild.Attributes['class'])
else if LChild.NodeName = 'stack' then
LItem := TUxLayoutStack.Create(StrToOrientation(LChild.Attributes['orientation']));
if Assigned(LItem) then
begin
AStack.Items.Add(LItem);
ParseAttributes(LChild, LItem);
if LItem is TUxLayoutStack then
PopulateStack(TUxLayoutStack(LItem), LChild);
end;
end;
end;
begin
try
var LTitle := '';
var LDoc: IXMLDocument := TXMLDocument.Create(nil);
if AFileName.StartsWith('<?xml') or AFileName.StartsWith('<layout') then
LDoc.LoadFromXML(AFileName)
else if FileExists(AFileName) then
begin
LDoc.LoadFromFile(AFileName);
LTitle := TPath.GetFileNameWithoutExtension(AFileName);
end
else
begin
LDoc.LoadFromFile(GetLayoutPath(AFileName));
LTitle := TPath.GetFileNameWithoutExtension(AFileName);
end;
if LDoc.DocumentElement.NodeName <> 'layout' then
raise Exception.Create('Invalid layout file.');
var LNode: IXMLNode;
Result := nil;
for var i := 0 to LDoc.DocumentElement.ChildNodes.Count - 1 do
begin
LNode := LDoc.DocumentElement.ChildNodes[i];
if LNode.NodeName = 'title' then
LTitle := LNode.Text
else if LNode.NodeName = 'panel' then
Result := TUxLayoutPanel.Create(LNode.Attributes['class'])
else if LNode.NodeName = 'stack' then
Result := TUxLayoutStack.Create(StrToOrientation(LNode.Attributes['orientation']));
if Assigned(Result) then
begin
Result.Title := LTitle;
ParseAttributes(LNode, Result);
Break;
end;
end;
if Result is TUxLayoutStack then
PopulateStack(TUxLayoutStack(Result), LNode);
if Result = nil then
Result := TUxEmptyLayout.Create;
except
on E: Exception do
raise Exception.Create('UxPanel.LoadLayoutFromFile failed: ' + E.ClassName + ': ' + E.Message + #13#10 + AFileName);
end;
end;
procedure GotoPanel(APanelClass: TPanelFormClass);
begin
if Assigned(TUxPanel.Instances) and (GetKeyState(VK_SHIFT) >= 0) then
for var LInstance in TUxPanel.Instances do
begin
var F := TPanelForm(nil);
if LInstance.Visible and LInstance.TryGetMainChild<TPanelForm>(F) then
begin
if F.ClassType.InheritsFrom(APanelClass) and F.Visible and F.CanFocus then
begin
LInstance.Flash;
F.SetFocus;
Exit;
end;
end;
end;
TUxForm.CreateNewForm(APanelClass);
end;
function GetTextEditorClass: TCustomFormClass;
begin
Result := TUxPanel.PanelClassFromName('Text editor', TTextEditorForm);
end;
function IndexInt(const X: Integer; const Arr: array of Integer): Integer;
begin
for var i := 0 to High(Arr) do
if Arr[i] = X then
Exit(i);
Result := -1;
end;
function ControlHasAncestor(AControl: TControl; AAncestor: TWinControl): Boolean;
begin
while Assigned(AControl) do
begin
if AControl = AAncestor then
Exit(True);
AControl := AControl.Parent;
end;
Result := False;
end;
procedure PanelLog(const S: string; E: Exception = nil);
begin
TDbgLogForm.DoLog(S, E);
end;
var
FBusyWorkLevel: Integer;
procedure SetAppCursor;
begin
if
(FBusyWorkLevel > 0)
or
TUxForm.FApplyingLayout
or
Assigned(TUxForm.FCleanupTimer) and TUxForm.FCleanupTimer.Enabled
then
Screen.Cursor := crHourGlass
else
Screen.Cursor := crDefault;
end;
procedure BeginBusyWork;
begin
Inc(FBusyWorkLevel);
SetAppCursor;
end;
procedure EndBusyWork;
begin
Dec(FBusyWorkLevel);
SetAppCursor;
end;
var
GInvFS: TFormatSettings;
GInvFS_Pretty: TFormatSettings;
function TryNaturalStrToFloat(const S: string; out X: Double): Boolean;
begin
var T: string;
SetLength(T, S.Length);
var ActualLength := 0;
for var i := 1 to S.Length do
begin
if (S[i] = '-') or (S[i] = '−') then
begin
Inc(ActualLength);
T[ActualLength] := '-';
end
else if (S[i] = '.') or (S[i] = ',') then
begin
Inc(ActualLength);
T[ActualLength] := '.';
end
else if S[i].IsWhiteSpace then
Continue
else
begin
Inc(ActualLength);
T[ActualLength] := S[i];
end;
end;
SetLength(T, ActualLength);
Result := TryStrToFloat(T, X, GInvFS);
end;
function PrettyFormat(const Format: string; Args: array of const): string;
begin
const LFormat = Format.Replace('%d', '%.0n');
var LArgs := TArray<TVarRec>(nil);
var LFloats := TArray<Extended>(nil);
SetLength(LArgs, Length(Args));
SetLength(LFloats, Length(Args));
for var i := 0 to High(Args) do
if Args[i].VType = vtInteger then
begin
LArgs[i].VType := vtExtended;
LFloats[i] := Args[i].VInteger.ToExtended;
LArgs[i].VExtended := @LFloats[i];
end
else
LArgs[i] := Args[i];
Result := SysUtils.Format(LFormat, LArgs, GInvFS_Pretty);
end;
function DateTimeToStdStr(const T: TDateTime): string;
begin
Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', T, GInvFS)
end;
function DateTimeToStdStrMS(const T: TDateTime): string;
begin
Result := FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz', T, GInvFS)
end;
procedure Register;
begin
RegisterComponents('Rejbrand 2020', [TUxPanel, TUxContainer, TUxSplitter,
TUxClient, TUxButton]);
end;
class procedure TUxPanel.ActiveFormChange;
begin
if Assigned(FInstances) then
for var UxPanel in FInstances do
begin
var ParentForm := GetParentFormSafe(UxPanel);
if UxPanel.FActivePanel xor (Screen.ActiveCustomForm = ParentForm) then
begin
UxPanel.FActivePanel := (Screen.ActiveCustomForm = ParentForm) and
UxPanel.ContainsControl(Screen.ActiveControl);
UxPanel.Invalidate;
if UxPanel.FActivePanel then
SetActivePanel(UxPanel);
end;
end;
end;
class procedure TUxPanel.ActivePanelNotificationTimer(Sender: TObject);
begin
if Assigned(FActivePanelNotificationTimer) then
FActivePanelNotificationTimer.Enabled := False;
if Application.Terminated then
Exit;
if Assigned(FActivePanelNotifications) then
for var LProc in FActivePanelNotifications do
try
LProc();
except
on E: Exception do
PanelLog('TUxPanel.ActivePanelNotificationTimer.for: Callback failed.', E);
end;
end;
procedure TUxPanel.AfterConstruction;
begin
inherited;
if not FCreatedWith then
begin
if FClassCombo = nil then
FClassCombo := TComboBox.Create(Self);
if FOkButton = nil then
FOkButton := TUxButton.Create(Self);
FClassCombo.Parent := Self;
FClassCombo.OnEnter := ClassComboEnter;
FClassCombo.OnExit := ClassComboExit;
TThread.ForceQueue(
nil,
procedure
begin
FClassCombo.Items.BeginUpdate;
try
FClassCombo.Clear;
if Assigned(FPanelClasses) then
for var LClass in FPanelClasses do
FClassCombo.Items.AddObject(LClass.Key, TObject(LClass.Value.FormClass));
FClassCombo.Sorted := True;
finally
FClassCombo.Items.EndUpdate;
end;
AlignClassCtrls;
end
);
FOkButton.Parent := Self;
FOkButton.Caption := 'Insert';
FOkButton.Width := ScaleValue(50);
FOkButton.OnClick := OkButtonClick;
end;
end;
procedure TUxPanel.AlignClassCtrls;
begin
if Assigned(FClassCombo) and Assigned(FOkButton) then
begin
FClassCombo.Font.PixelsPerInch := Self.PixelsPerInch;
FClassCombo.Font.Size := 9;
FOkButton.Font.PixelsPerInch := Self.PixelsPerInch;
FOkButton.Font.Size := 9;
const H = FClassCombo.Height;
const P = Padding.Top;
const W = Min(ScaleValue(204), ClientWidth - ScaleValue(8));
FClassCombo.Visible := W > ScaleValue(75);
FOkButton.Visible := FClassCombo.Visible;
if not FClassCombo.Visible then
Exit;
const CW = Round((150/204) * W);
const BW = Round((50/204) * W);
FClassCombo.Top := P + (ClientHeight - P - H) div 2;
FClassCombo.Left := (ClientWidth - W) div 2;
FClassCombo.Width := CW;
FOkButton.Top := FClassCombo.Top;
FOkButton.Left := FClassCombo.BoundsRect.Right + ScaleValue(4);
FOkButton.Height := H;
FOkButton.Width := BW;
end;
end;
class procedure TUxPanel.AppActivate(Sender: TObject);
begin
if Assigned(FInstances) then
for var LPanel in FInstances do
begin
const LIsActive = LPanel.ContainsControl(Screen.ActiveControl);
if LPanel.FActivePanel xor LIsActive then
begin
LPanel.FActivePanel := LIsActive;
LPanel.Invalidate;
end;
end;
end;
class procedure TUxPanel.AppDeactivate(Sender: TObject);
begin
if Assigned(FInstances) then
for var LPanel in FInstances do
begin
if LPanel.FActivePanel then
begin
LPanel.FActivePanel := False;
LPanel.Invalidate;
end;
end;
end;
class procedure TUxPanel.AppHint(Sender: TObject);
begin
if Assigned(FInstances) then
for var LPanel in FInstances do
if LPanel.FStatusHints then
LPanel.UpdateStatusBar;
end;
class procedure TUxPanel.ApplyLayoutOrder;
begin
FInstances.Sort(
TComparer<TUxPanel>.Construct(
function (const Left, Right: TUxPanel): Integer
begin
Result := CompareValue(Left.LayoutOrder, Right.LayoutOrder);
end
)
)
end;
class procedure TUxPanel.AppModalBegin(Sender: TObject);
begin
if Assigned(FInstances) then
for var LPanel in FInstances do
LPanel.ModalBegin;
end;
class procedure TUxPanel.AppModalEnd(Sender: TObject);
begin
if Assigned(FInstances) then
for var LPanel in FInstances do
LPanel.ModalEnd;
end;
class procedure TUxPanel.AppShortCut(var Msg: TWMKey; var Handled: Boolean);
begin
if (Msg.CharCode = VK_F1) and (GetKeyState(VK_CONTROL) >= 0) then
begin
var LCtl := Screen.ActiveControl;
var LHelpfulControl: IHelpfulControl;
while Assigned(LCtl) do
begin
if Supports(LCtl, IHelpfulControl, LHelpfulControl) then
if LHelpfulControl.ContextHelp then
begin
Handled := True;
Break;
end;
LCtl := LCtl.Parent;
end;
if not Handled and Supports(Application.MainForm, IHelpfulControl, LHelpfulControl) then
begin
if LHelpfulControl.ContextHelp then
Handled := True;
end;
end
else if (Msg.CharCode = VK_F12) and (GetKeyState(VK_CONTROL) >= 0) then
begin
const CF = TConsoleForm.ActiveInstance;
if CF <> nil then
begin
if CF.Console.Focused and CF.Console.TextFile.AtEOF then
begin
if (CF.Console.LineCount > 0) and not CF.Console.Lines[CF.Console.LineCount - 1].IsEmpty then
CF.Console.ClearLine;
end
else
begin
if CF.CanFocus then
CF.SetFocus;
CF.Console.TextFile.GotoEOF;
end;
end
else
begin
TUxForm.CreateNewForm(TConsoleForm);
end;
Handled := True;
end
else if (Msg.CharCode = VK_F6) and (GetKeyState(VK_CONTROL) >= 0) then
begin
var LShift := GetKeyState(VK_SHIFT) < 0;
if Assigned(FInstances) and (FInstances.Count > 0) then
begin
var LIdx := FInstances.IndexOf(FCurrentPanel);
Inc(LIdx, FInstances.Count + IfThen(LShift, -1, 1));
LIdx := LIdx mod FInstances.Count;
var LForm := TPanelForm(nil);
if FInstances[LIdx].TryGetMainChild<TPanelForm>(LForm) and LForm.CanFocus then
LForm.SetFocus
else
FInstances[LIdx].SetFocus;
end;
Handled := True;
end
else if Assigned(FCurrentPanel) and FCurrentPanel.FActivePanel then
FCurrentPanel.PanelShortCut(Msg, Handled)
else
Handled := False;
end;
procedure TUxPanel.BeginActive;
begin
var PF := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(PF) then
PF.BeginActive;
end;
procedure TUxPanel.BeginHighlight;
begin
Inc(FHighlightLevel);
Invalidate;
if FHighlightLevel >= 1 then
begin
if FHighlightTimer = nil then
begin
FHighlightTimer := TTimer.Create(Self);
FHighlightTimer.Interval := 1000;
FHighlightTimer.OnTimer := HighlightTimerTimer;
end;
FHighlightTimer.Enabled := False;
FHighlightTimer.Enabled := True;
FHighlightTimer.Tag := 1;
end;
end;
function TUxPanel.CanClose: Boolean;
begin
var PF := TPanelForm(nil);
Result := not TryGetMainChild<TPanelForm>(PF) or PF.CanClose;
end;
procedure TUxPanel.CaptionFontChange(Sender: TObject);
begin
Invalidate;
end;
class procedure TUxPanel.ChangeNotificationTimer(Sender: TObject);
begin
if Assigned(FChangeNotificationTimer) then
FChangeNotificationTimer.Enabled := False;
if Application.Terminated then
Exit;
if Assigned(FChangeNotifications) then
for var LProc in FChangeNotifications do
try
LProc();
except
on E: Exception do
PanelLog('TUxPanel.ChangeNotificationTimer.for: Callback failed.', E);
end;
end;
procedure TUxPanel.ChangeScale(M, D: Integer; isDpiChange: Boolean);
begin
inherited;
FCaptionRect := TRect.Empty;
UpdateMetrics;
Invalidate;
TThread.ForceQueue(nil, AlignClassCtrls);
end;
procedure TUxPanel.ClassComboEnter(Sender: TObject);
begin
if Assigned(FOkButton) then
FOkButton.Default := True;
end;
procedure TUxPanel.ClassComboExit(Sender: TObject);
begin
if Assigned(FOkButton) then
FOkButton.Default := False;
end;
function GetClassLevel(AClass: TClass): Integer;
begin
Result := 0;
while Assigned(AClass) do
begin
AClass := AClass.ClassParent;
Inc(Result);
end;
end;
class constructor TUxPanel.ClassCreate;
begin
FInstances := TList<TUxPanel>.Create;
TUx.RegisterCallback(UxThemeUpdate);
FChangeNotificationTimer := TTimer.Create(Application);
FChangeNotificationTimer.Interval := 100;
FChangeNotificationTimer.Enabled := False;
FChangeNotificationTimer.OnTimer := ChangeNotificationTimer;
FChangeNotifications := TList<TProc>.Create;
FActivePanelNotificationTimer := TTimer.Create(Application);
FActivePanelNotificationTimer.Interval := 100;
FActivePanelNotificationTimer.Enabled := False;
FActivePanelNotificationTimer.OnTimer := ActivePanelNotificationTimer;
FActivePanelNotifications := TList<TProc>.Create;
FPanelClasses := TDictionary<string, TPanelClassRec>.Create;
FSortedPanelClasses := TList<TPanelClassRec>.Create;
var Context := TRttiContext.Create;
try
for var LType in Context.GetTypes do
if LType.IsInstance and TRttiInstanceType(LType).MetaclassType.InheritsFrom(TCustomForm) then
for var LAttribute in LType.GetAttributes do
if LAttribute is PanelAttribute then
begin
const LName = PanelAttribute(LAttribute).Name;
var LExts := PanelAttribute(LAttribute).Exts;
var LClass := TCustomFormClass(TRttiInstanceType(LType).MetaclassType);
var LOldRec := Default(TPanelClassRec);
if FPanelClasses.TryGetValue(LName, LOldRec) then
begin
if LOldRec.FormClass.InheritsFrom(LClass) then
LClass := LOldRec.FormClass;
LExts := LExts + LOldRec.Exts;
end;
const LRec =
TPanelClassRec.Create(
LName,
LExts,
LClass,
GetClassLevel(LClass)
);
FPanelClasses.AddOrSetValue(
LName,
LRec
);
FSortedPanelClasses.Add(LRec);
end;
finally
Context.Free;
end;
FSortedPanelClasses.Sort(
TComparer<TPanelClassRec>.Construct(
function (const Left, Right: TPanelClassRec): Integer
begin
Result := -(Left.ClassLevel - Right.ClassLevel);
end
)
);
FAppEvents := TApplicationEvents.Create(nil);
FAppEvents.OnActivate := AppActivate;
FAppEvents.OnDeactivate := AppDeactivate;
FAppEvents.OnShortCut := AppShortCut;
FAppEvents.OnModalBegin := AppModalBegin;
FAppEvents.OnModalEnd := AppModalEnd;
FAppEvents.OnHint := AppHint;
end;
class destructor TUxPanel.ClassDestroy;
begin
FreeAndNil(FAppEvents);
FreeAndNil(FSortedPanelClasses);
FreeAndNil(FPanelClasses);
FreeAndNil(FActivePanelNotifications);
FreeAndNil(FChangeNotifications);
FreeAndNil(FInstances);
end;
class procedure TUxPanel.Cleanup;
begin
var LOrphans := TList<TUxPanel>.Create;
try
if Assigned(FInstances) then
for var LPanel in FInstances do
if (LPanel.Parent = nil) and not LPanel.FFreeElf then
LOrphans.Add(LPanel);
for var LOrphan in LOrphans do
LOrphan.Free;
finally
LOrphans.Free;
end;
end;
procedure TUxPanel.Close;
begin
if not CanClose then
Exit;
if Parent is TUxContainer then
TUxContainer(Parent).RemovePanel(Self)
else
Parent := nil;
TUxForm.RequestCleanup;
end;
procedure TUxPanel.CMFontChanged(var Message: TMessage);
begin
inherited;
UpdateMetrics;
Invalidate;
end;
procedure TUxPanel.CMMouseLeave(var Message: TMessage);
begin
inherited;
if FHotItem <> 0 then
begin
FHotItem := 0;
Invalidate;
end;
end;
procedure TUxPanel.CMTextChanged(var Message: TMessage);
begin
inherited;
UpdateMetrics;
Invalidate;
DoChangeNotification;
end;
constructor TUxPanel.CreateWith(AForm: TCustomForm);
begin
Create(Application);
if Assigned(AForm) then
begin
AForm.BorderStyle := bsNone;
AForm.Parent := Self;
AForm.Align := alClient;
AForm.Visible := True;
Caption := AForm.Caption;
FCreatedWith := True;
end;
end;
constructor TUxPanel.Create(AOwner: TComponent);
begin
inherited;
FGUID := TGUID.NewGuid;
FCaptionFont := TFont.Create;
FCaptionFont.Name := 'Segoe UI';
FCaptionFont.Style := [];
FCaptionFont.OnChange := CaptionFontChange;
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csOpaque, csDoubleClicks, csReplicatable];
FCaptionSize := GDefCaptionSize;
FBorderWidth := GDefBorderWidth;
FCaptionColor := TUx.ThemeData.ActiveCaptionColor;
FInactiveCaptionColor := TUx.ThemeData.InactiveCaptionColor;
FWindowedColor := TUx.ThemeData.WindowedColor;
FAlignment := taLeftJustify;
DoubleBuffered := True;
if Assigned(FInstances) then
FInstances.Add(Self);
TScreenDispatcher.RegisterFormChangeProc('TUxPanel', ActiveFormChange);
FMouseDownPoint := Point(-1, -1);
if FModalCover = nil then
begin
FModalCover := TUxClientLayer.Create(Self);
FModalCover.Visible := False;
FModalCover.Parent := Self;
end;
DoChangeNotification;
end;
constructor TUxPanel.CreateWith(const APanelClass: string);
begin
CreateWith(PanelClassFromName(APanelClass));
end;
constructor TUxPanel.CreateWith(AForm: TCustomFormClass; AAdoptee: TControl);
begin
if AForm = nil then
CreateWith(TCustomForm(nil))
else if AForm.InheritsFrom(TPanelForm) then
begin
if Assigned(AAdoptee) then
CreateWith(TPanelFormClass(AForm).CreateNewWith(Application, AAdoptee))
else
CreateWith(AForm.CreateNew(Application))
end
else
CreateWith(AForm.Create(Application));
end;
function TUxPanel.DAdvise(const formatetc: tagFORMATETC; advf: Integer;
const advSink: IAdviseSink; out dwConnection: Integer): HRESULT;
begin
Result := OLE_E_ADVISENOTSUPPORTED;
end;
destructor TUxPanel.Destroy;
begin
if FCurrentPanel = Self then
FCurrentPanel := nil;
FreeAndNil(FCaptionFont);
if Assigned(FInstances) then
FInstances.Remove(Self);
inherited;
DoChangeNotification;
end;
procedure TUxPanel.Detach;
begin
if Parent = nil then
Exit;
const P = ClientToScreen(TPoint.Zero);
var S := ClientRect.Size;
if Parent is TUxContainer then
TUxContainer(Parent).RemovePanel(Self);
var LForm := TUxForm.CreateNew(Application);
LForm.ScaleForCurrentDPI;
Parent := LForm;
LForm.Left := P.X;
LForm.Top := P.Y;
if not FIntrinsicSize.IsZero then
S := FIntrinsicSize;
LForm.ClientWidth := S.Width;
LForm.ClientHeight := S.Height;
LForm.Show;
TUxForm.RequestCleanup;
end;
class procedure TUxPanel.DoActivePanelNotification;
begin
if Assigned(FActivePanelNotificationTimer) then
FActivePanelNotificationTimer.Enabled := True;
end;
class procedure TUxPanel.DoChangeNotification;
begin
if Assigned(FChangeNotificationTimer) then
FChangeNotificationTimer.Enabled := True;
end;
procedure TUxPanel.DoEnter;
begin
inherited;
FActivePanel := True;
Invalidate;
SetActivePanel(Self);
if Assigned(FClassCombo) and Assigned(FOkButton) and FClassCombo.Visible and FOkButton.Visible then
if FClassCombo.CanFocus then
FClassCombo.SetFocus;
end;
procedure TUxPanel.DoExit;
begin
inherited;
FActivePanel := False;
Invalidate;
end;
procedure TUxPanel.DoPanelMenuPopup;
begin
if FPanelMenu = nil then
FPanelMenu := TUxPanelMenu.Create(nil);
const P = ClientToScreen(Point(FCaptionRect.Left, FCaptionRect.Bottom));
FPanelMenu.UxPopup(Self, P.X, P.Y);
end;
procedure TUxPanel.DoToolMenuPopup;
begin
if Assigned(FToolMenu) and not FEllipsisRect.IsEmpty then
begin
var P := ClientToScreen(Point(FEllipsisRect.Left, FEllipsisRect.Bottom));
FToolButtonDown := True;
Invalidate;
try
FToolMenu.Popup(P.X, P.Y);
finally
if Assigned(Self) then
begin
FToolButtonDown := False;
Invalidate;
end;
end;
end;
end;
function TUxPanel.DUnadvise(dwConnection: Integer): HRESULT;
begin
Result := OLE_E_ADVISENOTSUPPORTED;
end;
procedure TUxPanel.EndActive;
begin
var PF := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(PF) then
PF.EndActive;
end;
procedure TUxPanel.EndHighlight;
begin
Dec(FHighlightLevel);
Invalidate;
if (FHighlightLevel <= 0) and Assigned(FHighlightTimer) then
FHighlightTimer.Enabled := False;
end;
function TUxPanel.EnumDAdvise(out enumAdvise: IEnumSTATDATA): HRESULT;
begin
Result := OLE_E_ADVISENOTSUPPORTED;
end;
function TUxPanel.EnumFormatEtc(dwDirection: Integer;
out enumFormatEtc: IEnumFORMATETC): HRESULT;
begin
if dwDirection = DATADIR_GET then
begin
enumFormatEtc := TEnumFormatEtc.Create;
Result := S_OK;
end
else
begin
enumFormatEtc := nil;
Result := E_NOTIMPL;
end;
end;
procedure TUxPanel.Flash;
begin
if Assigned(FFlashTimer) and FFLashTimer.Enabled then
Exit;
BeginHighlight;
if FFlashTimer = nil then
begin
FFlashTimer := TTimer.Create(Self);
FFlashTimer.Interval := 1000;
FFlashTimer.OnTimer := FlashTimerTimer;
FFlashTimer.Enabled := True;
end
else
begin
FFlashTimer.Enabled := False;
FFlashTimer.Enabled := True;
end;
end;
procedure TUxPanel.FlashTimerTimer(Sender: TObject);
begin
if Assigned(FFlashTimer) then
begin
FFlashTimer.Enabled := False;
EndHighlight;
end;
end;
procedure TUxPanel.FocusContent;
begin
inherited;
var LForm := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(LForm) and Assigned(LForm) and LForm.CanFocus then
LForm.SetFocus;
end;
function TUxPanel.GetCanonicalFormatEtc(const formatetc: tagFORMATETC;
out formatetcOut: tagFORMATETC): HRESULT;
begin
formatetcOut := formatetc;
formatetcOut.ptd := nil;
Result := DATA_S_SAMEFORMATETC;
end;
function TUxPanel.GetData(const formatetcIn: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT;
begin
FillChar(medium, SizeOf(medium), 0);
var PanelRec := Default(TPanelOleRec);
PanelRec.Sign := PanelOleHeader;
PanelRec.PID := GetCurrentProcessId;
PanelRec.Wnd := Self.Handle;
PanelRec.Obj := Self;
case GetMatchingFormatIdx(formatetcIn) of
FMT_ASPANEL:
begin
medium.tymed := TYMED_HGLOBAL;
medium.hGlobal := GlobalAlloc(GMEM_MOVEABLE, SizeOf(PanelRec));
if medium.hGlobal = 0 then
Result := E_OUTOFMEMORY
else
begin
var p := GlobalLock(medium.hGlobal);
if p = nil then
begin
Result := E_OUTOFMEMORY;
GlobalFree(medium.hGlobal);
end
else
begin
Result := S_OK;
Move(PanelRec, p^, SizeOf(PanelRec));
GlobalUnlock(medium.hGlobal);
end;
end;
end;
else
Result := DV_E_FORMATETC;
end;
end;
function TUxPanel.GetDataHere(const formatetc: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT;
begin
Result := E_NOTIMPL;
end;
function TUxPanel.GetDisplayCaption: string;
begin
Result := Caption;
if TUxContainer.DebugMode then
begin
var LForm := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(LForm) then
Result := Format('%s (%d %g > %d %g)', [Result, Self.FCurrentPPI, Self.FScaleFactor, LForm.FCurrentPPI, LForm.FScaleFactor])
else
Result := Format('%s (%d %g)', [Result, Self.FCurrentPPI, Self.FScaleFactor])
end;
end;
function TUxPanel.GetMatchingFormatIdx(const AFormatEtc: TFormatEtc): Integer;
begin
for var i := 0 to High(Formats) do
if
(Formats[i].cfFormat = AFormatEtc.cfFormat)
and
(Formats[i].tymed and AFormatEtc.tymed <> 0)
and
(Formats[i].dwAspect = AFormatEtc.dwAspect)
and
(Formats[i].lindex = AFormatEtc.lindex)
then
Exit(i);
Result := -1;
end;
function TUxPanel.GetPanelClassRec: TPanelClassRec;
begin
var CF := TCustomForm(nil);
if Assigned(FSortedPanelClasses) and TryGetMainChild<TCustomForm>(CF) then
for var LRec in FSortedPanelClasses do
if CF.InheritsFrom(LRec.FormClass) then
Exit(LRec);
Result := Default(TPanelClassRec);
end;
function TUxPanel.GiveFeedback(dwEffect: Longint): HRESULT;
begin
Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
procedure TUxPanel.HighlightTimerTimer(Sender: TObject);
begin
if Assigned(FHighlightTimer) then
begin
FHighlightTimer.Tag := Succ(FHighlightTimer.Tag) mod 2;
Invalidate;
end;
end;
function TUxPanel.HitTest(const P: TPoint): Integer;
begin
if not FEllipsisRect.IsEmpty and FEllipsisRect.Contains(P) then
Result := ITEM_ELLIPSIS
else if FLeftStatusClick and not FLeftStatusTextRect.IsEmpty and FLeftStatusTextRect.Contains(P) then
Result := ITEM_STATUSLEFT
else if FRightStatusClick and not FRightStatusTextRect.IsEmpty and FRightStatusTextRect.Contains(P) then
Result := ITEM_STATUSRIGHT
else
Result := 0;
end;
function TUxPanel.IsDisposable: Boolean;
begin
var LForm := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(LForm) then
Result := LForm.IsDisposable
else
Result := Assigned(FClassCombo);
end;
function TUxPanel.IsVolatile: Boolean;
begin
var LForm := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(LForm) then
Result := LForm.IsVolatile
else
Result := Assigned(FClassCombo);
end;
procedure TUxPanel.Loaded;
begin
inherited;
UpdateMetrics;
end;
procedure TUxPanel.MakeFree;
begin
if Parent is TUxContainer then
(Parent as TUxContainer).RemovePanel(Self)
else
begin
FFreeElf := True;
Parent := nil;
end;
end;
procedure TUxPanel.ModalBegin;
begin
if not HandleAllocated or (Parent = nil) then
Exit;
if FModalCover = nil then
begin
FModalCover := TUxClientLayer.Create(Self);
FModalCover.Parent := Self;
end;
FModalCover.BoundsRect := Rect(0, 0, ClientWidth, ClientHeight);
FModalCover.Anchors := [akLeft, akTop, akRight, akBottom];
FModalCover.Visible := True;
FModalCover.BringToFront;
end;
procedure TUxPanel.ModalEnd;
begin
if Assigned(FModalCover) then
FModalCover.Hide;
end;
procedure TUxPanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
if CanFocus and not ContainsControl(Screen.ActiveControl) then
SetFocus;
FMouseDownPoint := Point(X, Y);
FDragDetect := False;
inherited;
if Button = mbLeft then
begin
const LMouseDownItem = FMouseDownItem;
FMouseDownItem := HitTest(FMouseDownPoint);
if
(FMouseDownItem = ITEM_ELLIPSIS)
and
Assigned(FToolMenu)
then
begin
DoToolMenuPopup;
FMouseDownItem := 0;
end
else if FMouseDownItem = 0 then
FDragDetect := True;
if LMouseDownItem <> FMouseDownItem then
Invalidate;
end;
end;
procedure TUxPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
if FLegacy then
Exit;
if FDragDetect and (csLButtonDown in ControlState) then
begin
const CxDrag = ScaleValue(GetSystemMetrics(SM_CXDRAG));
const CyDrag = ScaleValue(GetSystemMetrics(SM_CYDRAG));
if (Abs(X - FMouseDownPoint.X) > CxDrag) or (Abs(Y - FMouseDownPoint.Y) > CyDrag) then
begin
var LDropEffect := 0;
try
TUxContainer.BeginLayout_Internal;
try
DoDragDrop(Self, Self, DROPEFFECT_MOVE, LDropEffect);
TUxForm.RequestCleanup;
finally
TUxContainer.EndLayout_Internal;
end;
finally
ControlState := ControlState - [csLButtonDown];
end;
end;
end
else
begin
const P = Point(X, Y);
const LHotItem = FHotItem;
FHotItem := HitTest(P);
if LHotItem <> FHotItem then
Invalidate;
end;
end;
procedure TUxPanel.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
const LMouseDownItem = FMouseDownItem;
FMouseDownPoint := Point(-1, -1);
FDragDetect := False;
var LMouseUpItem := HitTest(Point(X, Y));
if (FMouseDownItem > ITEM_ELLIPSIS) and (LMouseUpItem = FMouseDownItem) and (Button = mbLeft) then
begin
var LForm := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(LForm) then
LForm.PanelEvent(FMouseDownItem);
end;
FMouseDownItem := 0;
if LMouseDownItem <> 0 then
Invalidate;
end;
procedure TUxPanel.NeedMetrics;
begin
if FCaptionRect.IsEmpty then
UpdateMetrics;
end;
procedure TUxPanel.OkButtonClick(Sender: TObject);
begin
if Assigned(FClassCombo) then
if FClassCombo.ItemIndex <> -1 then
begin
var LClass := TClass(FClassCombo.Items.Objects[FClassCombo.ItemIndex]);
if LClass.InheritsFrom(TCustomForm) then
begin
var LForm: TCustomForm;
if LClass.InheritsFrom(TPanelForm) then
LForm := TCustomFormClass(LClass).CreateNew(Application)
else
LForm := TCustomFormClass(LClass).Create(Application);
LForm.BorderStyle := bsNone;
LForm.Align := alClient;
LForm.Parent := Self;
LForm.ScaleForCurrentDPI;
LForm.Visible := True;
if LForm.CanFocus then
LForm.SetFocus;
Self.Caption := LForm.Caption;
DoChangeNotification;
DoActivePanelNotification;
end;
end;
end;
function AvgColor(C1, C2: TColor): TColor;
begin
Result :=
RGB(
(GetRValue(C1) + GetRValue(C2)) div 2,
(GetGValue(C1) + GetGValue(C2)) div 2,
(GetBValue(C1) + GetBValue(C2)) div 2
);
end;
procedure TUxPanel.Paint;
begin
inherited;
NeedMetrics;
FActivePanel := FActivePanel and ContainsControl(Screen.ActiveControl);
var LCaptionColor := FInactiveCaptionColor;
var LCaptionMidColor := TUx.ThemeData.CaptionMidColor;
var LStatusColor := FWindowedColor;
var LBorderColor := IfThen(FActivePanel and (Parent is TUxContainer), TUx.ThemeData.BlackenedColor, LCaptionColor);
if (FHighlightLevel > 0) and Assigned(FHighlightTimer) and (FHighlightTimer.Tag <> 0) then
begin
LCaptionColor := clHighlight;
LCaptionMidColor := clHighlight;
LStatusColor := clHighlight;
LBorderColor := clHighlight;
end;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := LCaptionColor;
Canvas.FillRect(CaptionRect);
if Assigned(FToolMenu) and not FEllipsisRect.IsEmpty then
begin
Canvas.Font.Assign(FCaptionFont);
Canvas.Font.Height := ScaleValue(FCaptionSize);
if FToolButtonDown then
begin
Canvas.Brush.Color := TUx.ThemeData.BlackenedColor;
Canvas.FillRect(FEllipsisRect);
end
else if FHotItem = ITEM_ELLIPSIS then
begin
Canvas.Brush.Color := LCaptionMidColor;
Canvas.FillRect(FEllipsisRect);
end
else
Canvas.Brush.Color := LCaptionColor;
Canvas.Font.Color := TUx.ThemeData.OtherWB(Canvas.Brush.Color);
var R := FEllipsisRect;
var S: string := '⋯';
Canvas.TextRect(R, S, [tfSingleLine, tfCenter, tfVerticalCenter]);
end;
if FStatusBar and not FStatusRect.IsEmpty then
begin
Canvas.Brush.Color := LStatusColor;
Canvas.FillRect(StatusRect);
end;
Canvas.Font.Assign(FCaptionFont);
Canvas.Font.Color := TUx.ThemeData.OtherWB(LCaptionColor);
Canvas.Font.Height := ScaleValue(FCaptionSize);
Canvas.Brush.Color := LCaptionColor;
Canvas.Brush.Style := bsClear;
var S := DisplayCaption;
var R := TextRect;
Canvas.TextRect(R, S, [tfSingleLine, tfVerticalCenter, tfLeft, tfEndEllipsis]);
Canvas.Brush.Style := bsSolid;
Canvas.Font.Height := ScaleValue(GDefTextHeight);
FLeftStatusTextRect := TRect.Empty;
FRightStatusTextRect := TRect.Empty;
if FStatusBar and not FStatusRect.IsEmpty then
begin
Canvas.Brush.Color := LStatusColor;
Canvas.Font.Color := TUx.ThemeData.OtherWB(Canvas.Brush.Color);
Canvas.Brush.Style := bsClear;
if not FStatusHints or Application.Hint.IsEmpty then
begin
Canvas.Font.Style := Canvas.Font.Style - [fsItalic];
var P := StatusText.Split([#9]);
var LFreeSpace := 0;
if Length(P) >= 1 then
begin
S := P[0];
R := StatusRect;
R.Inflate(-TextRect.Left, -ScaleValue(FBorderWidth), -TextRect.Left, 0);
const TW = Canvas.TextWidth(S);
LFreeSpace := R.Width - TW;
FLeftStatusTextRect := Rect(R.Left, R.Top, R.Left + TW, R.Bottom);
if FHotItem = ITEM_STATUSLEFT then
begin
if FMouseDownItem = ITEM_STATUSLEFT then
Canvas.Brush.Color := TUx.ThemeData.ActiveCaptionColor
else
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.Brush.Style := bsSolid;
var RR := FLeftStatusTextRect;
RR.Inflate(TextRect.Left, 0);
RR.Left := ScaleValue(FBorderWidth);
RR.Inflate(-ScaleValue(1), -ScaleValue(1));
Canvas.FillRect(RR);
Canvas.Pen.Color := TUx.ThemeData.BlackenedColor;
Canvas.Rectangle(RR);
end;
Canvas.Font.Color := TUx.ThemeData.OtherWB(Canvas.Brush.Color);
Canvas.Brush.Style := bsClear;
Canvas.TextRect(R, S, [tfSingleLine, tfVerticalCenter, tfLeft, tfEndEllipsis]);
Canvas.Brush.Color := LStatusColor;
end;
if Length(P) >= 2 then
begin
S := P[1];
R := StatusRect;
R.Inflate(-TextRect.Left, -ScaleValue(FBorderWidth), -TextRect.Left, 0);
if Canvas.TextWidth(S + #32#32) < LFreeSpace then
begin
const TW = Canvas.TextWidth(S);
FRightStatusTextRect := Rect(R.Right - TW, R.Top, R.Right, R.Bottom);
if FHotItem = ITEM_STATUSRIGHT then
begin
if FMouseDownItem = ITEM_STATUSRIGHT then
Canvas.Brush.Color := TUx.ThemeData.ActiveCaptionColor
else
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.Brush.Style := bsSolid;
var RR := FRightStatusTextRect;
RR.Inflate(TextRect.Left, 0);
RR.Right := ClientWidth - ScaleValue(FBorderWidth);
RR.Inflate(-ScaleValue(1), -ScaleValue(1));
Canvas.FillRect(RR);
Canvas.Pen.Color := TUx.ThemeData.BlackenedColor;
Canvas.Rectangle(RR);
end;
Canvas.Font.Color := TUx.ThemeData.OtherWB(Canvas.Brush.Color);
Canvas.Brush.Style := bsClear;
Canvas.TextRect(R, S, [tfSingleLine, tfVerticalCenter, tfRight, tfEndEllipsis]);
Canvas.Brush.Color := LStatusColor;
end;
end;
end
else
begin
Canvas.Font.Style := Canvas.Font.Style + [fsItalic];
S := Application.Hint;
R := StatusRect;
R.Inflate(-TextRect.Left, -ScaleValue(FBorderWidth), -TextRect.Left, 0);
const LOriginalFontHeight = Canvas.Font.Height;
const LFontHeightLimit = Round(0.7 * LOriginalFontHeight);
while (Canvas.TextWidth(S) > R.Width) and (Canvas.Font.Height > LFontHeightLimit) do
Canvas.Font.Height := Canvas.Font.Height - 1;
Canvas.TextRect(R, S, [tfSingleLine, tfVerticalCenter, tfLeft, tfEndEllipsis]);
end;
Canvas.Brush.Style := bsSolid;
end;
if FFreeArea.Bottom > FFreeArea.Top then
begin
Canvas.Brush.Color := Self.Color;
Canvas.FillRect(FFreeArea);
end;
Canvas.Brush.Color := LBorderColor;
R := Rect(0, 0, ClientWidth, ScaleValue(FBorderWidth));
Canvas.FillRect(R);
R := Rect(0, 0, ScaleValue(FBorderWidth), ClientHeight);
Canvas.FillRect(R);
R := Rect(ClientWidth - ScaleValue(FBorderWidth), 0, ClientWidth, ClientHeight);
Canvas.FillRect(R);
R := Rect(0, ClientHeight - ScaleValue(FBorderWidth), ClientWidth, ClientHeight);
Canvas.FillRect(R);
end;
class function TUxPanel.PanelClassFromName(const AName: string;
ADefault: TCustomFormClass): TCustomFormClass;
var
LPanelClassRec: TPanelClassRec;
begin
if Assigned(FPanelClasses) and FPanelClasses.TryGetValue(AName, LPanelClassRec) then
Result := LPanelClassRec.FormClass
else
Result := ADefault;
end;
function TUxPanel.PanelRec: TPanelRec;
begin
Result := Default(TPanelRec);
Result.ID := Self.FGUID;
Result.Name := Self.Caption;
Result.&Type := Self.PanelClass.Name;
end;
class function TUxPanel.PanelRecArr: TArray<TPanelRec>;
begin
Result := nil;
if Assigned(FInstances) then
for var LInstance in FInstances do
Result := Result + [LInstance.PanelRec];
end;
procedure TUxPanel.PanelShortCut(var Msg: TWMKey; var Handled: Boolean);
begin
if
(Msg.CharCode in [VK_F4, Ord('W')])
and
(GetKeyState(VK_CONTROL) < 0)
and
(GetKeyState(VK_MENU) >= 0)
and
not FLegacy
then
begin
Self.Close;
Handled := True;
end
else if
(Msg.CharCode = VK_F6)
and
(GetKeyState(VK_CONTROL) < 0)
and
(GetKeyState(VK_MENU) >= 0)
and
not FLegacy
then
begin
Self.Detach;
Handled := True;
end
else if
(Msg.CharCode = VK_F11)
and
(GetKeyState(VK_CONTROL) >= 0)
and
(GetKeyState(VK_SHIFT) >= 0)
and
(GetKeyState(VK_MENU) >= 0)
and
Assigned(FToolMenu)
and
not FEllipsisRect.IsEmpty
then
begin
DoToolMenuPopup;
Handled := True;
end
else if
(Msg.CharCode = VK_F10)
and
(GetKeyState(VK_CONTROL) >= 0)
and
(GetKeyState(VK_SHIFT) >= 0)
and
(GetKeyState(VK_MENU) >= 0)
then
begin
DoPanelMenuPopup;
Handled := True;
end
else
begin
var PF := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(PF) then
PF.PanelShortCut(Msg, Handled)
else
Handled := False;
end;
end;
function TUxPanel.QueryContinueDrag(fEscapePRessed: BOOL;
grfKeyState: Longint): HRESULT;
begin
if fEscapePressed then
Result := DRAGDROP_S_CANCEL
else if grfKeyState and MK_LBUTTON = 0 then
Result := DRAGDROP_S_DROP
else
Result := S_OK;
end;
function TUxPanel.QueryGetData(const formatetc: tagFORMATETC): HRESULT;
begin
Result := IfThen(GetMatchingFormatIdx(formatetc) <> -1, S_OK, S_FALSE);
end;
class procedure TUxPanel.RegisterActivePanelNotification(const AProc: TProc);
begin
if Assigned(FActivePanelNotifications) and Assigned(AProc) then
FActivePanelNotifications.Add(AProc);
end;
class procedure TUxPanel.RegisterChangeNotification(const AProc: TProc);
begin
if Assigned(FChangeNotifications) and Assigned(AProc) then
FChangeNotifications.Add(AProc);
end;
procedure TUxPanel.RequestClientSize(const ASize: TSize);
begin
RequestClientSize(ASize.Width, ASize.Height);
end;
procedure TUxPanel.RequestClientSize(AWidth, AHeight: Integer);
begin
if Parent is TUxForm then
begin
var LForm := Parent as TUxForm;
if Assigned(LForm.FConstraintsTimer) then
LForm.FConstraintsTimer.Enabled := False;
LForm.RequestClientSize(
AWidth + (Self.ClientWidth - FFreeArea.Width),
AHeight + FCaptionRect.Height + FStatusRect.Height
);
end
else
begin
ClientWidth := AWidth + (Self.ClientWidth - FFreeArea.Width);
ClientHeight := AHeight + FCaptionRect.Height + FStatusRect.Height;
end;
end;
procedure TUxPanel.Resize;
begin
inherited;
UpdateMetrics;
Invalidate;
if Floating then
FIntrinsicSize := ClientRect.Size;
if Assigned(FClassCombo) and Assigned(FOkButton) then
AlignClassCtrls;
end;
procedure TUxPanel.ScreenCoordsChanged;
begin
inherited;
var LForm := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(LForm) then
LForm.ScreenCoordsChanged;
end;
class procedure TUxPanel.SetActivePanel(ANewPanel: TUxPanel);
begin
if FCurrentPanel <> ANewPanel then
begin
if Assigned(FCurrentPanel) then
try
FCurrentPanel.EndActive;
except
end;
FCurrentPanel := ANewPanel;
if Assigned(FCurrentPanel) then
try
FCurrentPanel.BeginActive;
except
end;
DoActivePanelNotification;
end;
end;
procedure TUxPanel.SetAlignment(AAlignment: TAlignment);
begin
if FAlignment <> AAlignment then
begin
FAlignment := AAlignment;
UpdateMetrics;
Invalidate;
end;
end;
procedure TUxPanel.SetBorderWidth(ABorderWidth: Integer);
begin
if FBorderWidth <> ABorderWidth then
begin
FBorderWidth := ABorderWidth;
UpdateMetrics;
Invalidate;
end;
end;
procedure TUxPanel.SetCaptionColor(ACaptionColor: TColor);
begin
if FCaptionColor <> ACaptionColor then
begin
FCaptionColor := ACaptionColor;
FWindowedColor := 0.2 * TRGB(ACaptionColor) + 0.8 * TRGB(clWhite);
Invalidate;
end;
end;
procedure TUxPanel.SetCaptionSize(ACaptionSize: Integer);
begin
if FCaptionSize <> ACaptionSize then
begin
FCaptionSize := ACaptionSize;
UpdateMetrics;
Invalidate;
end;
end;
function TUxPanel.SetData(const formatetc: tagFORMATETC;
var medium: tagSTGMEDIUM; fRelease: LongBool): HRESULT;
begin
Result := E_NOTIMPL;
end;
procedure TUxPanel.SetInactiveCaptionColor(AInactiveCaptionColor: TColor);
begin
if FInactiveCaptionColor <> AInactiveCaptionColor then
begin
FInactiveCaptionColor := AInactiveCaptionColor;
Invalidate;
end;
end;
procedure TUxPanel.SetParent(AParent: TWinControl);
begin
if Assigned(AParent) then
FFreeElf := False;
inherited;
var LChild := TCustomForm(nil);
if Assigned(AParent) and Assigned(GetParentFormSafe(AParent)) and TryGetMainChild<TCustomForm>(LChild) then
begin
LChild.ScaleForPPI(AParent.CurrentPPI);
LChild.Font.PixelsPerInch := LChild.PixelsPerInch;
LChild.Font.Size := 9;
end;
end;
procedure TUxPanel.SetToolMenu(AToolMenu: TPopupMenu);
begin
if FToolMenu <> AToolMenu then
begin
FToolMenu := AToolMenu;
UpdateMetrics;
Invalidate;
end;
end;
procedure TUxPanel.SetStatusBar(const Value: Boolean);
begin
if FStatusBar <> Value then
begin
FStatusBar := Value;
UpdateMetrics;
Invalidate;
end;
end;
procedure TUxPanel.SetStatusText(const Value: string);
begin
if FStatusText <> Value then
begin
FStatusText := Value;
if FStatusBar then
Invalidate;
end;
end;
procedure TUxPanel.SplitHorizontally;
begin
if Parent = nil then
Exit;
var LCtr := TUxContainer(nil);
var LIdx := 0;
if Parent is TUxForm then
begin
LCtr := TUxContainer.Create(Application);
LCtr.Parent := Parent;
LCtr.Orientation := uxoHorizontal;
Parent := nil;
LCtr.InsertPanel(Self, 0);
LIdx := 1;
end
else if Parent is TUxContainer then
begin
const LParentCtnr = TUxContainer(Parent);
const LOldIdx = LParentCtnr.FSections.IndexOf(Self);
if LParentCtnr.Orientation = uxoVertical then
begin
if LOldIdx = -1 then
Exit;
LCtr := TUxContainer.Create(Application);
LCtr.Orientation := uxoHorizontal;
LParentCtnr.RemovePanel(Self);
LParentCtnr.InsertPanel(LCtr, LOldIdx);
LCtr.InsertPanel(Self, 0);
LIdx := 1;
end
else
begin
LCtr := TUxContainer(Parent);
LIdx := LOldIdx + 1;
end;
end;
if Assigned(LCtr) then
begin
const LPanel = TUxPanel.Create(Application);
LCtr.InsertPanel(LPanel, LIdx);
if LPanel.CanFocus then
LPanel.SetFocus;
end;
end;
procedure TUxPanel.SplitVertically;
begin
if Parent = nil then
Exit;
var LCtr := TUxContainer(nil);
var LIdx := 0;
if Parent is TUxForm then
begin
LCtr := TUxContainer.Create(Application);
LCtr.Parent := Parent;
LCtr.Orientation := uxoVertical;
Parent := nil;
LCtr.InsertPanel(Self, 0);
LIdx := 1;
end
else if Parent is TUxContainer then
begin
const LParentCtnr = TUxContainer(Parent);
const LOldIdx = LParentCtnr.FSections.IndexOf(Self);
if LParentCtnr.Orientation = uxoHorizontal then
begin
if LOldIdx = -1 then
Exit;
LCtr := TUxContainer.Create(Application);
LCtr.Orientation := uxoVertical;
LCtr.SectionSize := Self.SectionSize;
LParentCtnr.RemovePanel(Self);
LCtr.Replacing := True;
LParentCtnr.InsertPanel(LCtr, LOldIdx);
LCtr.InsertPanel(Self, 0);
LIdx := 1;
end
else
begin
LCtr := TUxContainer(Parent);
LIdx := LOldIdx + 1;
end;
end;
if Assigned(LCtr) then
begin
const LPanel = TUxPanel.Create(Application);
LCtr.InsertPanel(LPanel, LIdx);
if LPanel.CanFocus then
LPanel.SetFocus;
end;
end;
procedure TUxPanel.ThemeUpdate;
begin
CaptionColor := TUx.ThemeData.ActiveCaptionColor;
InactiveCaptionColor := TUx.ThemeData.InactiveCaptionColor;
var PF := TPanelForm(nil);
if TryGetMainChild<TPanelForm>(PF) then
PF.ThemeUpdate;
end;
function TUxPanel.TryGetMainChild<T>(out AChild: T): Boolean;
begin
AChild := nil;
Result := False;
for var i := 0 to ControlCount - 1 do
if Controls[i] is T then
begin
if Result then
begin
AChild := nil;
Exit(False);
end;
AChild := T(Controls[i]);
Result := True;
end;
end;
procedure TUxPanel.UpdateMetrics;
begin
if not HandleAllocated or not HasParent then
Exit;
var bm := TBitmap.Create;
try
bm.Canvas.Font.Assign(FCaptionFont);
bm.Canvas.Font.Height := ScaleValue(FCaptionSize);
const W = bm.Canvas.TextWidth(DisplayCaption);
const LCaptionHeight = Round(1.25 * bm.Canvas.TextHeight('X'));
const LIndent = Scalevalue(GIndentSize);
FCaptionRect := Rect(0, 0, ClientWidth, LCaptionHeight);
FEllipsisRect := TRect.Empty;
if Assigned(FToolMenu) then
FEllipsisRect := Rect(ClientWidth - LCaptionHeight - LIndent, 0, ClientWidth - LIndent, LCaptionHeight);
const LStatusHeight = IfThen(FStatusBar, LCaptionHeight, 0);
FStatusRect := TRect.Empty;
if FStatusBar then
begin
FStatusRect := Rect(0, ClientHeight - LStatusHeight, ClientWidth, ClientHeight - ScaleValue(FBorderWidth));
if FStatusRect.Top < FCaptionRect.Bottom then
FStatusRect := TRect.Empty;
end;
case FAlignment of
taLeftJustify:
FTextRect := Rect(LIndent, 0, Min(LIndent + W, ClientWidth - FEllipsisRect.Width - LIndent), LCaptionHeight);
taRightJustify:
FTextRect := Rect(Max(ClientWidth - FEllipsisRect.Width - LIndent - W, 0), 0, ClientWidth - FEllipsisRect.Width - LIndent, LCaptionHeight);
else
FTextRect := Rect(Max((ClientWidth - W) div 2, 0), 0, Min((ClientWidth + W + 1) div 2, ClientWidth), LCaptionHeight);
end;
FFreeArea := Rect(
ScaleValue(FBorderWidth),
LCaptionHeight,
ClientWidth - ScaleValue(FBorderWidth),
ClientHeight - ScaleValue(FBorderWidth) - IfThen(not FStatusRect.IsEmpty, LStatusHeight, 0)
);
finally
bm.Free;
end;
Padding.Top := FCaptionRect.Height;
Padding.Left := ScaleValue(FBorderWidth);
Padding.Right := ScaleValue(FBorderWidth);
Padding.Bottom := Max(ScaleValue(FBorderWidth), FStatusRect.Height);
end;
procedure TUxPanel.UpdateStatusBar;
begin
if not StatusRect.IsEmpty then
InvalidateRect(Handle, StatusRect, False)
end;
class procedure TUxPanel.UxThemeUpdate;
begin
if Assigned(FInstances) then
for var Panel in FInstances do
Panel.ThemeUpdate;
end;
procedure TUxPanel.ValidateInsert(AComponent: TComponent);
begin
inherited;
if
(AComponent <> FOkButton)
and
(AComponent <> FClassCombo)
and
not (AComponent is TUxClientLayer)
and
Assigned(FOkButton)
and
Assigned(FClassCombo)
then
TThread.ForceQueue(
nil,
procedure
begin
FreeAndNil(FClassCombo);
FreeAndNil(FOkButton);
end
)
end;
procedure TUxPanel.WMContextMenu(var Message: TWMContextMenu);
begin
if FLegacy then
begin
inherited;
Exit;
end;
if (Message.XPos = -1) and (Message.YPos = -1) then
begin
if FPanelMenu = nil then
FPanelMenu := TUxPanelMenu.Create(nil);
with ClientToScreen(Point(0, FCaptionRect.Height)) do
FPanelMenu.UxPopup(Self, X, Y);
Exit;
end;
const CP = Mouse.CursorPos;
if Assigned(FToolMenu) and FFreeArea.Contains(ScreenToClient(CP)) then
begin
FToolMenu.Popup(CP.X, CP.Y);
end
else
begin
if FPanelMenu = nil then
FPanelMenu := TUxPanelMenu.Create(nil);
FPanelMenu.UxPopup(Self, CP.X, CP.Y);
end;
end;
procedure TUxPanel.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TUxPanel.WMKillFocus(var Message: TMessage);
begin
inherited;
end;
class constructor TUxSplitter.ClassCreate;
begin
FInstances := TList<TUxSplitter>.Create;
TUx.RegisterCallback(UxThemeUpdate);
end;
class destructor TUxSplitter.ClassDestroy;
begin
FreeAndNil(FInstances);
end;
constructor TUxSplitter.Create(AOwner: TComponent);
begin
inherited;
if Assigned(FInstances) then
FInstances.Add(Self);
Color := TUx.ThemeData.WindowedColor;
end;
destructor TUxSplitter.Destroy;
begin
if Assigned(FInstances) then
FInstances.Remove(Self);
inherited;
end;
procedure TUxSplitter.Loaded;
begin
inherited;
Color := TUx.ThemeData.WindowedColor;
end;
procedure TUxSplitter.RequestAlign;
begin
inherited RequestAlign;
if Align in [alBottom, alTop] then
Cursor := crSizeNS
else
Cursor := crSizeWE;
end;
class procedure TUxSplitter.UxThemeUpdate;
begin
if Assigned(FInstances) then
for var Splitter in FInstances do
Splitter.Color := TUx.ThemeData.WindowedColor;
end;
class constructor TUxClient.ClassCreate;
begin
FInstances := TList<TUxClient>.Create;
TUx.RegisterCallback(UxThemeUpdate);
end;
class destructor TUxClient.ClassDestroy;
begin
FreeAndNil(FInstances);
end;
procedure TUxClient.CMColorChanged(var Message: TMessage);
begin
inherited;
if HandleAllocated then
Invalidate;
end;
procedure TUxClient.CMTextChanged(var Message: TMessage);
begin
inherited;
if HandleAllocated then
Invalidate;
end;
constructor TUxClient.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csOpaque, csDoubleClicks, csReplicatable];
if Assigned(FInstances) then
FInstances.Add(Self);
Color := TUx.ThemeData.InactiveCaptionColor;
end;
destructor TUxClient.Destroy;
begin
if Assigned(FInstances) then
FInstances.Remove(Self);
inherited;
end;
procedure TUxClient.Paint;
var
LSizeGrip: Boolean;
begin
inherited;
if FSizeGrip then
begin
var Frm := GetParentFormSafe(Self);
LSizeGrip := Assigned(Frm) and (Frm.WindowState <> wsMaximized) and (Frm.BorderStyle = bsSizeable);
end
else
LSizeGrip := False;
if LSizeGrip then
FSizeGripSize := GetSystemMetricsForWindow(SM_CXVSCROLL, Handle);
Canvas.Brush.Color := IfThen(FWindowedColor, TUx.ThemeData.WindowedColor, TUx.ThemeData.InactiveCaptionColor);
var R := ClientRect;
if LSizeGrip then
Dec(R.Right, FSizeGripSize);
Canvas.FillRect(R);
if Caption <> '' then
begin
Canvas.Font.PixelsPerInch := 96;
Canvas.Font.Assign(Font);
Canvas.Font.Size := ScaleValue(9);
Canvas.Font.Color := IfThen(FWindowedColor, clBlack, TUx.ThemeData.InactiveCaptionTextColor);
var S := #32 + Caption;
for var i := 0 to ControlCount - 1 do
if Controls[i].Visible and (Controls[i].Align = alLeft) then
Inc(R.Left, Controls[i].Width);
Canvas.TextRect(R, S, [tfSingleLine, tfLeft, tfVerticalCenter, tfEndEllipsis]);
end;
if LSizeGrip then
begin
Canvas.Brush.Color := TUx.ThemeData.ActiveCaptionColor;
Canvas.Pen.Style := psClear;
R := Rect(
ClientWidth - FSizeGripSize,
ClientHeight - FSizeGripSize,
ClientWidth,
ClientHeight
);
Canvas.Polygon(
[
Point(R.Right, R.Top),
Point(R.Right, R.Bottom),
Point(R.Left, R.Bottom)
]
);
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.Polygon(
[
Point(R.Left, 0),
Point(R.Right, 0),
Point(R.Right, R.Top),
Point(R.Left, R.Bottom)
]
);
end;
end;
procedure TUxClient.SetSizeGrip(const Value: Boolean);
begin
if FSizeGrip <> Value then
begin
FSizeGrip := Value;
Invalidate;
end;
end;
procedure TUxClient.SetWindowedColor(const Value: Boolean);
begin
if FWindowedColor <> Value then
begin
FWindowedColor := Value;
Invalidate;
for var i := 0 to ControlCount - 1 do
if Controls[i] is TUxButton then
Controls[i].Invalidate;
end;
end;
class procedure TUxClient.UxThemeUpdate;
begin
if Assigned(FInstances) then
for var Panel in FInstances do
Panel.Invalidate;
end;
procedure TUxClient.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TUxClient.WMNCHitTest(var Message: TWMNCHitTest);
begin
if FMousePassthrough then
Message.Result := HTTRANSPARENT
else
inherited;
end;
procedure TUxButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
inherited ActionChange(Sender, CheckDefaults);
if Sender is TCustomAction then
with TCustomAction(Sender) do
if not CheckDefaults or not Self.Down then
Self.Down := Checked;
end;
class constructor TUxButton.ClassCreate;
begin
FInstances := TList<TUxButton>.Create;
TUx.RegisterCallback(UxThemeUpdate);
end;
class destructor TUxButton.ClassDestroy;
begin
FreeAndNil(FInstances);
end;
procedure TUxButton.Click;
begin
var Form := GetParentFormSafe(Self);
if Form <> nil then
Form.ModalResult := ModalResult;
inherited Click;
end;
procedure TUxButton.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and CanFocus then
begin
Click;
Result := 1;
end else
inherited;
end;
procedure TUxButton.CMDialogKey(var Message: TCMDialogKey);
begin
with Message do
if
(
(
FDefault
and
(CharCode = VK_RETURN)
and
(Focused or not ((Screen.ActiveControl is TCustomButton) or (Screen.ActiveControl is TUxButton)))
and
(Screen.ActiveCustomForm = GetParentFormSafe(Self))
)
or
(FCancel and (CharCode = VK_ESCAPE))
)
and
(KeyDataToShiftState(Message.KeyData) = [])
and
CanFocus
then
begin
Click;
Result := 1;
end else
inherited;
end;
procedure TUxButton.CMEnabledChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TUxButton.CMFocusChanged(var Message: TCMFocusChanged);
var
LActive: Boolean;
begin
inherited;
with Message do
LActive := FDefault and
((Sender = Self) or not ((Sender is TCustomButton) or (Sender is TUxButton))) and
(Screen.ActiveCustomForm = GetParentFormSafe(Self));
if LActive <> FActive then
begin
FActive := LActive;
Invalidate;
end;
end;
procedure TUxButton.CMMouseEnter(var Message: TMessage);
begin
inherited;
FHot := True;
Invalidate;
end;
procedure TUxButton.CMMouseLeave(var Message: TMessage);
begin
inherited;
FHot := False;
Invalidate;
end;
procedure TUxButton.CMTextChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
constructor TUxButton.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := [csCaptureMouse, csClickEvents, csOpaque, csReplicatable,
csSetCaption];
if Assigned(FInstances) then
FInstances.Add(Self);
Color := TUx.ThemeData.InactiveCaptionColor;
TabStop := True;
end;
destructor TUxButton.Destroy;
begin
if Assigned(FInstances) then
FInstances.Remove(Self);
inherited;
end;
function TUxButton.GetActionLinkClass: TControlActionLinkClass;
begin
Result := TUxButtonActionLink;
end;
function TUxButton.IsDownStored: Boolean;
begin
Result := (ActionLink = nil) or not TUxButtonActionLink(ActionLink).IsCheckedLinked;
end;
procedure TUxButton.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_SPACE:
Invalidate;
VK_RETURN:
Click;
end;
end;
procedure TUxButton.KeyUp(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_SPACE:
begin
Click;
Invalidate;
end;
end;
end;
procedure TUxButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if TabStop and CanFocus then
SetFocus;
Invalidate;
end;
procedure TUxButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
Invalidate;
end;
function Blend(AFactor: Double; C1, C2: TColor): TColor;
begin
C1 := ColorToRGB(C1);
C2 := ColorToRGB(C2);
const s = AFactor;
const t = 1 - s;
Result :=
RGB(
Round(s * GetRValue(C1) + t * GetRValue(C2)),
Round(s * GetGValue(C1) + t * GetGValue(C2)),
Round(s * GetBValue(C1) + t * GetBValue(C2))
);
end;
procedure TUxButton.Paint;
begin
inherited;
Canvas.Font.PixelsPerInch := 96;
Canvas.Font.Assign(Font);
Canvas.Font.Size := ScaleValue(9);
var LNormal := False;
if not Enabled then
begin
if (Parent is TUxClient) and TUxClient(Parent).WindowedColor then
begin
Canvas.Brush.Color := TUx.ThemeData.WindowedColor;
Canvas.Font.Color := Blend(0.75, Canvas.Brush.Color, clBlack);
end
else
begin
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.Font.Color := TUx.ThemeData.InactiveTextColor;
end;
end
else if (csLButtonDown in ControlState) or Focused and (GetKeyState(VK_SPACE) < 0) then
begin
Canvas.Brush.Color := TUx.ThemeData.DownCaptionColor;
Canvas.Font.Color := TUx.ThemeData.DownCaptionTextColor;
end
else if FHot or Focused or FDown then
begin
Canvas.Brush.Color := TUx.ThemeData.ActiveCaptionColor;
Canvas.Font.Color := TUx.ThemeData.ActiveCaptionTextColor;
end
else if (Parent is TUxClient) and TUxClient(Parent).WindowedColor then
begin
Canvas.Brush.Color := TUx.ThemeData.WindowedColor;
Canvas.Font.Color := clBlack;
LNormal := True;
end
else
begin
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.Font.Color := TUx.ThemeData.InactiveCaptionTextColor;
LNormal := True;
end;
Canvas.FillRect(ClientRect);
var R := ClientRect;
var LCaptions := [Caption] + FShorterCaptions;
for var i := 0 to High(LCaptions) do
begin
const LCaption = LCaptions[i];
if (i = High(LCaptions)) or (Canvas.TextWidth(LCaption.Replace('&', '') + 'X') < ClientWidth) then
begin
var S: string := LCaption;
Canvas.TextRect(R, S, [tfSingleLine, tfVerticalCenter, tfEndEllipsis, tfCenter]);
Break;
end;
end;
if LNormal and FActive then
begin
Canvas.Brush.Color := TUx.ThemeData.ActiveCaptionColor;
Canvas.FillRect(Rect(0, 0, ClientWidth, ScaleValue(4)));
Canvas.FillRect(Rect(0, 0, ScaleValue(4), ClientHeight));
Canvas.FillRect(Rect(0, ClientHeight - ScaleValue(4), ClientWidth, ClientHeight));
Canvas.FillRect(Rect(ClientWidth - ScaleValue(4), 0, ClientWidth, ClientHeight));
end;
if Focused then
begin
R := ClientRect;
R.Inflate(-ScaleValue(4), -ScaleValue(4));
DrawFocusRect(Canvas.Handle, R);
end;
end;
procedure TUxButton.SetDefault(const Value: Boolean);
begin
if FDefault <> Value then
begin
FDefault := Value;
Invalidate;
end;
end;
procedure TUxButton.SetDown(const Value: Boolean);
begin
if FDown <> Value then
begin
FDown := Value;
Invalidate;
end;
end;
class procedure TUxButton.UxThemeUpdate;
begin
if Assigned(FInstances) then
for var Button in FInstances do
Button.Color := TUx.ThemeData.InactiveCaptionColor;
end;
procedure TUxButton.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TUxButton.WMKillFocus(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TUxButton.WMSetFocus(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TUxButtonActionLink.AssignClient(AClient: TObject);
begin
inherited AssignClient(AClient);
FClient := AClient as TUxButton;
end;
function TUxButtonActionLink.IsCheckedLinked: Boolean;
begin
Result := inherited IsCheckedLinked and
(FClient.Down = TCustomAction(Action).Checked);
end;
procedure TUxButtonActionLink.SetChecked(Value: Boolean);
begin
if IsCheckedLinked then
FClient.Down := Value;
end;
procedure TUxContainer.AlignControls(AControl: TControl; var Rect: TRect);
begin
if (csDesigning in ComponentState) or ((csLButtonDown in ControlState) and not FCancelResize) then
inherited
else
begin
const InternalPadding = ScaleValue(InternalPaddingInvariant);
const BorderPadding = ScaleValue(BorderPaddingInvariant);
FSplitters.Clear;
var LPanels := PanelArray;
if Length(LPanels) = 0 then
Exit;
var LTotalExtent := 0;
case Orientation of
uxoHorizontal:
LTotalExtent := ClientWidth;
uxoVertical:
LTotalExtent := ClientHeight;
end;
var LTotalNonSplitterExtent := LTotalExtent - Pred(Length(LPanels)) * InternalPadding - 2 * BorderPadding;
var LTotalPanelExtentFraction := 0.0;
for var LPanel in LPanels do
begin
LPanel.SectionSize := EnsureRange(LPanel.SectionSize, 0.1, 1.0);
LTotalPanelExtentFraction := LTotalPanelExtentFraction + LPanel.SectionSize;
end;
var t := BorderPadding;
for var i := 0 to High(LPanels) do
begin
var LPanel := LPanels[i];
const LPanelSize = Round(LPanel.SectionSize / LTotalPanelExtentFraction * LTotalNonSplitterExtent);
var S := LPanelSize;
if i = High(LPanels) then
S := LTotalExtent - BorderPadding - t;
case Orientation of
uxoHorizontal:
LPanel.SetBounds(t, BorderPadding, S, ClientHeight - 2*BorderPadding);
uxoVertical:
LPanel.SetBounds(BorderPadding, t, ClientWidth - 2*BorderPadding, S);
end;
Inc(t, S);
if i < High(LPanels) then
begin
var R := Default(TSplitterRec);
case Orientation of
uxoHorizontal:
R.Region := Types.Rect(t, BorderPadding, t + InternalPadding, ClientHeight - BorderPadding);
uxoVertical:
R.Region := Types.Rect(BorderPadding, t, ClientWidth - BorderPadding, t + InternalPadding);
end;
R.A := LPanel;
R.B := LPanels[Succ(i)];
FSplitters.Add(R);
end;
Inc(t, InternalPadding);
end;
end;
end;
class procedure TUxContainer.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
if
(Msg.message = WM_KEYDOWN)
and
(Msg.wParam = VK_ESCAPE)
and
Assigned(FResizeCtl)
and
Assigned(FInstances)
and
FInstances.Contains(FResizeCtl)
then
begin
var LCtl := FResizeCtl;
FResizeCtl := nil;
LCtl.CancelResize;
end;
end;
procedure TUxContainer.ArrangeAll;
begin
for var LPanel in PanelArray do
LPanel.SectionSize := 0.0;
Realign;
end;
class procedure TUxContainer.BeginLayout;
begin
FLayoutModeTimer.Enabled := False;
FLayoutMode_External := True;
Relayout;
end;
class procedure TUxContainer.BeginLayout_Internal;
begin
FLayoutMode_Internal := True;
Relayout;
end;
procedure TUxContainer.BeginPopup;
begin
FCtxPopup := True;
Invalidate;
end;
class function TUxContainer.BorderPaddingInvariant: Integer;
begin
if DebugMode then
Result := 12
else if LayoutMode then
Result := BorderPaddingInvariant2
else
Result := BorderPaddingInvariant1;
end;
procedure TUxContainer.CancelResize;
begin
if (csLButtonDown in ControlState) and not FDragSplitter.Region.IsEmpty then
begin
FResizeCtl := nil;
FDragSplitter := Default(TSplitterRec);
ClipCursor(nil);
FCancelResize := True;
try
SetCursor(Screen.Cursors[crDefault]);
Realign;
finally
FCancelResize := False;
end;
end;
end;
class constructor TUxContainer.ClassCreate;
begin
FInstances := TList<TUxContainer>.Create;
TUx.RegisterCallback(UxThemeUpdate);
FAppEvents := TApplicationEvents.Create(nil);
FAppEvents.OnMessage := AppMessage;
FLayoutModeTimer := TTimer.Create(nil);
FLayoutModeTimer.Enabled := False;
FLayoutModeTimer.Interval := 50;
FLayoutModeTimer.OnTimer := LayoutModeTimerTimer;
end;
class destructor TUxContainer.ClassDestroy;
begin
FreeAndNil(FLayoutModeTimer);
FreeAndNil(FAppEvents);
FreeAndNil(FInstances);
end;
class procedure TUxContainer.Cleanup;
begin
if Assigned(FInstances) then
for var LCtr in FInstances do
if LCtr.IsStronglySuperfluous then
begin
(LCtr.Parent as TUxContainer).RemovePanel(LCtr);
LCtr.Free;
end;
if Assigned(FInstances) then
for var LCtr in FInstances do
if LCtr.IsWeaklySuperfluous then
begin
var LParent := LCtr.Parent;
var LChild := LCtr.FSections.First;
if LParent is TUxContainer then
begin
var LParentCtr := LParent as TUxContainer;
var LIdx := LParentCtr.FSections.IndexOf(LCtr);
Assert(LIdx <> -1);
if LIdx = -1 then
Exit;
LParentCtr.FSections[LIdx] := LChild;
end;
LCtr.FSections.Clear;
LCtr.Parent := nil;
LChild.SectionSize := LCtr.SectionSize;
LChild.Parent := LParent;
LCtr.Free;
Break;
end;
end;
constructor TUxContainer.Create(AOwner: TComponent);
begin
if AOwner <> Application then
raise Exception.Create('TUxContainer must be owned by application.');
inherited;
FSplitters := TList<TSplitterRec>.Create;
FSections := TList<TUxDockable>.Create;
FUxDockSite := TUxDockSite.Create(Self);
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csOpaque, csDoubleClicks, csReplicatable];
if Assigned(FInstances) then
FInstances.Add(Self);
end;
procedure TUxContainer.CreateWnd;
begin
inherited;
OleCheck(RegisterDragDrop(Handle, Self));
end;
destructor TUxContainer.Destroy;
begin
if Assigned(FInstances) then
FInstances.Remove(Self);
FreeAndNil(FSections);
FreeAndNil(FSplitters);
inherited;
end;
procedure TUxContainer.DestroyWnd;
begin
RevokeDragDrop(Handle);
inherited;
end;
class procedure TUxContainer.EndLayout;
begin
if FLayoutModeTimer = nil then
Exit;
FLayoutModeTimer.Enabled := False;
FLayoutModeTimer.Enabled := True;
end;
class procedure TUxContainer.EndLayout_Internal;
begin
FLayoutMode_Internal := False;
Relayout;
end;
procedure TUxContainer.EndPopup;
begin
FCtxPopup := False;
Invalidate;
end;
procedure TUxContainer.ExpandBackwards(AControl: TUxDockable; D: Integer);
begin
const BorderPadding = ScaleValue(BorderPaddingInvariant);
case FOrientation of
uxoHorizontal:
AControl.SetBounds(AControl.Left - D, BorderPadding, AControl.Width + D, ClientHeight - 2*BorderPadding);
uxoVertical:
AControl.SetBounds(BorderPadding, AControl.Top - D, ClientWidth - 2*BorderPadding, AControl.Height + D);
end;
end;
function TUxContainer.FindInsertionPoint(const APoint: TPoint): Integer;
begin
var LPanels := PanelArray;
var t := GetPos(APoint);
var LPrevPos := 0;
var i := 0;
for var LPanel in LPanels do
begin
var LPos := GetPos(LPanel);
if LPos > t then
begin
if (i > 0) and (Abs(t - LPrevPos) < Abs(t - LPos)) then
Exit(Pred(i))
else
Exit(i);
Break;
end;
Inc(i);
LPrevPos := LPos;
end;
if (i > 0) and (Abs(t - LPrevPos) < Abs(t - GetSize(Self))) then
Result := High(LPanels)
else
Result := Length(LPanels);
end;
function TUxContainer.FirstBorderPaddingRect: TRect;
begin
case Orientation of
uxoHorizontal:
Result := Rect(0, 0, ScaleValue(BorderPaddingInvariant), ClientHeight);
uxoVertical:
Result := Rect(0, 0, ClientWidth, ScaleValue(BorderPaddingInvariant));
else
Result := TRect.Empty;
end;
end;
procedure TUxContainer.FormRethinkConstraints;
begin
var LForm := GetParentFormSafe(Self);
if LForm is TUxForm then
TUxForm(LForm).RethinkConstraints;
end;
function TUxContainer.GetPos(ARect: TRect): Integer;
begin
case FOrientation of
uxoHorizontal:
Result := ARect.Left;
uxoVertical:
Result := ARect.Top;
else
Result := 0;
end;
end;
function TUxContainer.GetPos(AControl: TUxDockable): Integer;
begin
Result := GetPos(AControl.BoundsRect);
end;
function TUxContainer.GetSize(const ARect: TRect): Integer;
begin
case FOrientation of
uxoHorizontal:
Result := ARect.Width;
uxoVertical:
Result := ARect.Height;
else
Result := 0;
end;
end;
function TUxContainer.GetSize(AControl: TUxDockable): Integer;
begin
Result := GetSize(AControl.BoundsRect);
end;
function TUxContainer.GetPos(const P: TPoint): Integer;
begin
case FOrientation of
uxoHorizontal:
Result := P.X;
uxoVertical:
Result := P.Y;
else
Result := 0;
end;
end;
procedure TUxContainer.IncSize(AControl: TUxDockable; D: Integer);
begin
SetSize(AControl, GetSize(AControl) + D);
end;
procedure TUxContainer.InsertPanel(APanel: TUxDockable; AIndex: Integer);
begin
Assert(Assigned(APanel));
Assert(APanel.Parent = nil);
Assert(not FSections.Contains(APanel));
if not APanel.Replacing then
APanel.SectionSize := 0.0;
APanel.Replacing := False;
var LPanels := PanelArray;
if AIndex < 0 then
AIndex := 0;
if AIndex > Length(LPanels) then
AIndex := Length(LPanels);
FSections.Insert(AIndex, APanel);
APanel.Parent := Self;
APanel.Align := alNone;
Realign;
FormRethinkConstraints;
end;
class function TUxContainer.InternalPaddingInvariant: Integer;
begin
if DebugMode then
Result := 24
else if LayoutMode then
Result := InternalPaddingInvariant2
else
Result := InternalPaddingInvariant1;
end;
function TUxContainer.IsStronglySuperfluous: Boolean;
begin
Result :=
Assigned(Self)
and
(FSections.Count = 0)
and
(Parent is TUxContainer);
end;
function TUxContainer.IsWeaklySuperfluous: Boolean;
begin
Result :=
Assigned(Self)
and
(FSections.Count = 1)
and
(
(Parent is TUxContainer)
or
(Parent is TUxForm)
);
end;
function TUxContainer.LastBorderPaddingRect: TRect;
begin
case Orientation of
uxoHorizontal:
Result := Rect(ClientWidth - ScaleValue(BorderPaddingInvariant), 0, ClientWidth, ClientHeight);
uxoVertical:
Result := Rect(0, ClientHeight - ScaleValue(BorderPaddingInvariant), ClientWidth, ClientHeight);
else
Result := TRect.Empty;
end;
end;
class function TUxContainer.LayoutMode: Boolean;
begin
Result := FLayoutMode_External or FLayoutMode_Internal;
end;
class procedure TUxContainer.LayoutModeTimerTimer(Sender: TObject);
begin
if FLayoutModeTimer = nil then
Exit;
FLayoutModeTimer.Enabled := False;
if FLayoutMode_External then
begin
FLayoutMode_External := False;
Relayout;
end;
end;
procedure TUxContainer.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
FNoCtxPopup := False;
if Button = TMouseButton.mbLeft then
begin
FDragSplitter := SplitterHitTest(ScreenToClient(Mouse.CursorPos));
if ValidateSplitter(FDragSplitter) then
begin
FDragPos := Point(X, Y);
var R := Shrink1D(ClientToScreen(FDragSplitter.A.BoundsRect + FDragSplitter.B.BoundsRect));
ClipCursor(@R);
FResizeCtl := Self;
end;
end
else
begin
if not FDragSplitter.Region.IsEmpty then
begin
FNoCtxPopup := True;
CancelResize;
end;
end;
end;
procedure TUxContainer.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
if (csLButtonDown in ControlState) and ValidateSplitter(FDragSplitter) then
begin
var T := 0;
PointDelta1D(FDragPos, Point(X, Y), T);
IncSize(FDragSplitter.A, T);
ExpandBackwards(FDragSplitter.B, -T);
end;
end;
procedure TUxContainer.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
ClipCursor(nil);
FResizeCtl := nil;
if ValidateSplitter(FDragSplitter) then
begin
var T := 0;
const InternalPadding = ScaleValue(InternalPaddingInvariant);
const BorderPadding = ScaleValue(BorderPaddingInvariant);
const LTotalNonSplitterExtent = GetSize(ClientRect) - Pred(FSections.Count) * InternalPadding - 2 * BorderPadding;
if LTotalNonSplitterExtent <= 0 then
Exit;
PointDelta1D(FDragPos, Point(X, Y), T);
IncSize(FDragSplitter.A, T);
ExpandBackwards(FDragSplitter.B, -T);
for var LSection in FSections do
LSection.SectionSize := GetSize(LSection) / LTotalNonSplitterExtent;
Realign;
end;
FDragSplitter := Default(TSplitterRec);
end;
procedure TUxContainer.MovePanel(APanel: TUxDockable; AIndex: Integer);
begin
const LOldIdx = FSections.IndexOf(APanel);
if LOldIdx = -1 then
Exit;
if (AIndex = LOldIdx) or (AIndex = LOldIdx + 1) then
Exit;
if AIndex > LOldIdx then
Dec(AIndex);
FSections.Move(LOldIdx, AIndex);
Realign;
end;
procedure TUxContainer.Paint;
begin
inherited;
Canvas.Brush.Style := bsSolid;
var LBaseColor := TUx.ThemeData.InactiveCaptionColor;
if LayoutMode then
LBaseColor := TUx.ThemeData.WindowedColor;
if FCtxPopup then
begin
Canvas.Brush.Color := TUx.ThemeData.ActiveCaptionColor;
Canvas.FillRect(ClientRect);
end
else if FUxDockSite.FInsertionPoint = -1 then
begin
Canvas.Brush.Color := LBaseColor;
Canvas.FillRect(ClientRect);
end
else if FUxDockSite.FInsertionPoint = 0 then
begin
Canvas.Brush.Color := LBaseColor;
Canvas.FillRect(ClientRect);
Canvas.Brush.Color :=
IfThen(
FUxDockSite.FInsertionPointAnimationStep,
TUx.ThemeData.InsertionPointColor2,
TUx.ThemeData.InsertionPointColor1
);
Canvas.FillRect(FirstBorderPaddingRect);
end
else if FUxDockSite.FInsertionPoint = FSections.Count then
begin
Canvas.Brush.Color := LBaseColor;
Canvas.FillRect(ClientRect);
Canvas.Brush.Color :=
IfThen(
FUxDockSite.FInsertionPointAnimationStep,
TUx.ThemeData.InsertionPointColor2,
TUx.ThemeData.InsertionPointColor1
);
Canvas.FillRect(LastBorderPaddingRect);
end
else
begin
Canvas.Brush.Color := LBaseColor;
Canvas.FillRect(ClientRect);
end;
for var i := 0 to FSplitters.Count - 1 do
begin
if FUxDockSite.FInsertionPoint = i + 1 then
Canvas.Brush.Color :=
IfThen(
FUxDockSite.FInsertionPointAnimationStep,
TUx.ThemeData.InsertionPointColor2,
TUx.ThemeData.InsertionPointColor1
)
else
Canvas.Brush.Color := LBaseColor;
Canvas.FillRect(FSplitters[i].Region);
end;
if DebugMode then
begin
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := TUx.ThemeData.ActiveCaptionColor;
Canvas.Pen.Width := 2;
var R := ClientRect;
R.Inflate(-6, -6);
Canvas.Rectangle(R);
Canvas.Brush.Style := bsSolid;
end;
end;
function TUxContainer.PanelArray: TArray<TUxDockable>;
begin
Result := FSections.ToArray;
end;
procedure TUxContainer.PointDelta1D(var P: TPoint; const ANewPoint: TPoint;
out D: Integer);
begin
case FOrientation of
uxoHorizontal:
D := ANewPoint.X - P.X;
uxoVertical:
D := ANewPoint.Y - P.Y;
end;
P := ANewPoint;
end;
class procedure TUxContainer.Relayout;
begin
if Assigned(FInstances) then
for var LCtr in FInstances do
begin
LCtr.Invalidate;
LCtr.Realign;
end;
TUxForm.Relayout(LayoutMode);
end;
procedure TUxContainer.RemovePanel(APanel: TUxDockable);
begin
Assert(FSections.Contains(APanel));
Assert(APanel.Parent = Self);
FSections.Remove(APanel);
APanel.Parent := nil;
Realign;
FormRethinkConstraints;
end;
procedure TUxContainer.ScreenCoordsChanged;
begin
inherited;
for var i := 0 to ControlCount - 1 do
if Controls[i] is TUxDockable then
TUxDockable(Controls[i]).ScreenCoordsChanged;
end;
class procedure TUxContainer.SetDebugMode(const Value: Boolean);
begin
if FDebugMode <> Value then
begin
FDebugMode := Value;
Relayout;
end;
end;
procedure TUxContainer.SetOrientation(const Value: TUxContainerOrientation);
begin
if FOrientation <> Value then
begin
FOrientation := Value;
Realign;
end;
end;
procedure TUxContainer.SetSize(AControl: TUxDockable; ASize: Integer);
begin
case FOrientation of
uxoHorizontal:
AControl.Width := ASize;
uxoVertical:
AControl.Height := ASize;
end;
end;
function TUxContainer.Shrink1D(const R: TRect): TRect;
begin
Result := R; Exit;
end;
function TUxContainer.SplitterHitTest(const P: TPoint): TSplitterRec;
begin
for var S in FSplitters do
if S.Region.Contains(P) then
Exit(S);
Result := Default(TSplitterRec);
end;
class procedure TUxContainer.UxThemeUpdate;
begin
if Assigned(FInstances) then
for var Container in FInstances do
Container.Color := TUx.ThemeData.InactiveCaptionColor;
end;
function TUxContainer.ValidateControl(AControl: TControl): Boolean;
begin
for var i := 0 to ControlCount - 1 do
if Controls[i] = AControl then
Exit(True);
Result := False;
end;
function TUxContainer.ValidateSplitter(var ASplitter: TSplitterRec): Boolean;
begin
Result :=
not ASplitter.Region.IsEmpty
and
ValidateControl(ASplitter.A)
and
ValidateControl(ASplitter.B);
if not Result then
ASplitter := Default(TSplitterRec);
end;
procedure TUxContainer.WMContextMenu(var Message: TWMContextMenu);
begin
if FLegacy then
begin
inherited;
Exit;
end;
if FNoCtxPopup then
begin
FNoCtxPopup := False;
Exit;
end;
if FContainerMenu = nil then
FContainerMenu := TUxContainerMenu.Create(nil);
with Mouse.CursorPos do
FContainerMenu.UxPopup(Self, X, Y)
end;
procedure TUxContainer.WMSetCursor(var Message: TWMSetCursor);
const
OrientationCursors: array[TUxContainerOrientation] of TCursor =
(crSizeWE, crSizeNS);
begin
var LSplitterRec := SplitterHitTest(ScreenToClient(Mouse.CursorPos));
if not LSplitterRec.Region.IsEmpty then
begin
SetCursor(Screen.Cursors[OrientationCursors[Orientation]]);
Message.Result := 1;
end
else
inherited;
end;
class constructor TUxDockable.ClassCreate;
begin
CF_ASPANEL := RegisterClipboardFormat(CFSTR_ASPANEL);
FORMATETC_ASPANEL.cfFormat := CF_ASPANEL;
Formats := [FORMATETC_ASPANEL];
end;
class destructor TUxDockable.ClassDestroy;
begin
FreeAndNil(FContainerMenu);
FreeAndNil(FPanelMenu);
end;
constructor TUxDockable.Create(AOwner: TComponent);
begin
inherited;
end;
destructor TUxDockable.Destroy;
begin
inherited;
end;
function TUxDockable.Floating: Boolean;
begin
Result :=
(Parent is TUxForm)
or
(Parent is TUxContainer)
and
(Parent.Parent is TUxForm)
and
OnlyChild
or
(Parent is TUxContainer)
and
(Parent.Parent is TUxContainer)
and
(Parent.Parent.Parent is TUxForm)
and
OnlyChild
and
(Parent as TUxContainer).OnlyChild
end;
procedure TUxDockable.FocusContent;
begin
if CanFocus then
SetFocus;
end;
function TUxDockable.OnlyChild: Boolean;
begin
Result :=
not (Parent is TUxContainer)
or
(Length(TUxContainer(Parent).PanelArray) = 1);
end;
procedure TUxDockable.ScreenCoordsChanged;
begin
end;
procedure TUxDockable.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
inherited;
ScreenCoordsChanged;
end;
constructor TUxPanelMenu.Create(AOwner: TComponent);
begin
inherited;
FmiClose := TMenuItem.Create(Self);
FmiClose.Caption := 'Close'#9'Ctrl+F4';
FmiClose.Hint := 'Closes this panel.';
FmiClose.OnClick := mnuCloseClick;
Items.Add(FmiClose);
FmiDetach := TMenuItem.Create(Self);
FmiDetach.Caption := 'Detach'#9'Ctrl+F6';
FmiDetach.Hint := 'Detaches this panel into its own, floating window.';
FmiDetach.OnClick := mnuDetachClick;
Items.Add(FmiDetach);
Items.InsertNewLineAfter(FmiDetach);
FmiAutoSizeAll := TMenuItem.Create(Self);
FmiAutoSizeAll.Caption := 'Arrange stack';
FmiAutoSizeAll.Hint := 'Makes all the panels in this horizontal or vertical stack share the stack’s width or height equally.';
FmiAutoSizeAll.OnClick := mnuAutoSizeAllClick;
Items.Add(FmiAutoSizeAll);
Items.InsertNewLineAfter(FmiAutoSizeAll);
FmiSplitHorizontally := TMenuItem.Create(Self);
FmiSplitHorizontally.Caption := 'Split &horizontally';
FmiSplitHorizontally.Hint := 'Splits this panel into two panels (this one and a new one) horizontally.';
FmiSplitHorizontally.OnClick := mnuSplitHorizontallyClick;
Items.Add(FmiSplitHorizontally);
FmiSplitVertically := TMenuItem.Create(Self);
FmiSplitVertically.Caption := 'Split &vertically';
FmiSplitVertically.Hint := 'Splits this panel into two panels (this one and a new one) vertically.';
FmiSplitVertically.OnClick := mnuSplitVerticallyClick;
Items.Add(FmiSplitVertically);
Items.InsertNewLineAfter(FmiSplitVertically);
FmiNewWindow := TMenuItem.Create(Self);
FmiNewWindow.Caption := 'New &window';
FmiNewWindow.Hint := 'Creates a new floating window.';
FmiNewWindow.OnClick := mnuNewWindowClick;
Items.Add(FmiNewWindow);
FmiCopyStatusText := TMenuItem.Create(Self);
FmiCopyStatusText.Caption := 'Copy status bar text';
FmiCopyStatusText.OnClick := mnuCopyStatusBarText;
Items.Add(FmiCopyStatusText);
end;
class procedure TUxPanelMenu.mnuAutoSizeAllClick(Sender: TObject);
begin
if Assigned(FSource) and (FSource.Parent is TUxContainer) then
TUxContainer(FSource.Parent).ArrangeAll;
end;
class procedure TUxPanelMenu.mnuCloseClick(Sender: TObject);
begin
if Assigned(FSource) then
FSource.Close;
end;
class procedure TUxPanelMenu.mnuCopyStatusBarText(Sender: TObject);
begin
if Assigned(FSource) and FSource.StatusBar and not FSource.StatusText.IsEmpty then
Clipboard.AsText := FSource.StatusText;
end;
class procedure TUxPanelMenu.mnuDetachClick(Sender: TObject);
begin
if Assigned(FSource) then
FSource.Detach;
end;
class procedure TUxPanelMenu.mnuNewWindowClick(Sender: TObject);
begin
TUxForm.CreateNewForm;
end;
class procedure TUxPanelMenu.mnuSplitHorizontallyClick(Sender: TObject);
begin
if Assigned(FSource) then
FSource.SplitHorizontally;
end;
class procedure TUxPanelMenu.mnuSplitVerticallyClick(Sender: TObject);
begin
if Assigned(FSource) then
FSource.SplitVertically;
end;
procedure TUxPanelMenu.Popup(X, Y: Integer);
begin
if FSource = nil then
Exit;
const LOnlyChild = FSource.OnlyChild;
const LFloating = FSource.Floating;
const LWithinStatusBar = FSource.StatusBar and not FSource.StatusRect.IsEmpty
and FSource.StatusRect.Contains(FSource.ScreenToClient(Point(X, Y)));
if Assigned(FmiClose) then
FmiClose.Visible := not LWithinStatusBar;
if Assigned(FmiSplitHorizontally) then
FmiSplitHorizontally.Visible := not LWithinStatusBar;
if Assigned(FmiSplitVertically) then
FmiSplitVertically.Visible := not LWithinStatusBar;
if Assigned(FmiAutoSizeAll) then
FmiAutoSizeAll.Visible := not LWithinStatusBar and not LOnlyChild;
if Assigned(FmiDetach) then
FmiDetach.Visible := not LWithinStatusBar and not LFloating;
if Assigned(FmiCopyStatusText) then
begin
FmiCopyStatusText.Visible := LWithinStatusBar;
FmiCopyStatusText.Enabled := not FSource.StatusText.IsEmpty;
end;
inherited;
end;
procedure TUxPanelMenu.UxPopup(ASource: TUxPanel; X, Y: Integer);
begin
FSource := ASource;
Popup(X, Y);
end;
constructor TUxContainerMenu.Create(AOwner: TComponent);
begin
inherited;
FmiAutoSizeAll := TMenuItem.Create(Self);
FmiAutoSizeAll.Caption := 'Arrange stack';
FmiAutoSizeAll.Hint := 'Makes all the panels in this horizontal or vertical stack share the stack’s width or height equally.';
FmiAutoSizeAll.OnClick := mnuAutoSizeAllClick;
Items.Add(FmiAutoSizeAll);
FmiAddPanel := TMenuItem.Create(Self);
FmiAddPanel.Caption := 'Add panel';
FmiAddPanel.OnClick := mnuAddPanelClick;
Items.Add(FmiAddPanel);
end;
class procedure TUxContainerMenu.mnuAddPanelClick(Sender: TObject);
begin
if Assigned(FSource) then
FSource.InsertPanel(TUxPanel.Create(Application), FSource.FSections.Count);
end;
class procedure TUxContainerMenu.mnuAutoSizeAllClick(Sender: TObject);
begin
if Assigned(FSource) then
FSource.ArrangeAll;
end;
procedure TUxContainerMenu.Popup(X, Y: Integer);
begin
FmiAutoSizeAll.Visible := Assigned(FSource) and Assigned(FSource.FSections)
and (FSource.FSections.Count > 0);
FmiAddPanel.Visible := Assigned(FSource) and Assigned(FSource.FSections)
and (FSource.FSections.Count = 0);
inherited;
end;
procedure TUxContainerMenu.UxPopup(ASource: TUxContainer; X, Y: Integer);
begin
FSource := ASource;
ASource.BeginPopup;
try
Popup(X, Y);
finally
ASource.EndPopup;
end;
end;
function TUxDockable.TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;
begin
try
Enum := TEnumFormatEtc.Create;
TEnumFormatEtc(Enum).FIndex := Self.FIndex;
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TUxDockable.TEnumFormatEtc.Next(celt: Longint; out elt;
pceltFetched: PLongint): HResult;
begin
if (celt <= 0) or ((celt > 1) and (pceltFetched = nil)) then
Exit(E_INVALIDARG);
var count := 0;
var p := PFormatEtc(@elt);
while (FIndex <= High(Formats)) and (count < celt) do
begin
p^ := Formats[FIndex];
Inc(p);
Inc(count);
Inc(FIndex);
end;
if Assigned(pceltFetched) then
pceltFetched^ := count;
Result := IfThen(count = celt, S_OK, S_FALSE);
end;
function TUxDockable.TEnumFormatEtc.Reset: HResult;
begin
FIndex := 0;
Result := S_OK;
end;
function TUxDockable.TEnumFormatEtc.Skip(celt: Longint): HResult;
begin
if FIndex + celt <= High(Formats) then
begin
Inc(FIndex, celt);
Result := S_OK;
end
else
Result := S_FALSE;
end;
procedure TUxForm.Activate;
begin
inherited;
UpdateDwmColors;
Invalidate;
end;
procedure TUxForm.AlignControls(AControl: TControl; var Rect: TRect);
begin
if (ControlCount = 1) and (Controls[0] is TUxDockable) then
begin
const BorderPadding = ScaleValue(TUxContainer.BorderPaddingInvariant);
Controls[0].SetBounds(BorderPadding, BorderPadding,
ClientWidth - 2*BorderPadding, ClientHeight - 2*BorderPadding - AppBarHeight);
end
else
inherited;
end;
class procedure TUxForm.UpdateTitlebars(Sender: TObject);
begin
if Assigned(FInstances) then
for var LForm in FInstances do
begin
LForm.UpdateDwmColors;
LForm.Invalidate;
end;
end;
function TUxForm.AppBarHeight: Integer;
begin
Result := ScaleValue(GDefCaptionSize);
end;
function TUxForm.AppBarRect: TRect;
begin
Result := Rect(0, ClientHeight - AppBarHeight, ClientWidth, ClientHeight);
end;
function TUxForm.AppButtonRect: TRect;
begin
Result := Rect(0, ClientHeight - AppBarHeight, 4 * AppBarHeight, ClientHeight);
end;
class procedure TUxForm.AppHint(Sender: TObject);
begin
if Assigned(FInstances) then
for var LForm in FInstances do
LForm.UpdateStatusBar;
end;
procedure TUxForm.ApplyLayout(const ALayout: TUxLayout; ATakeOwnership: Boolean);
var
LDefCtl: TUxDockable;
LIndex: Integer;
procedure PopulateStack(const AContainer: TUxContainer; AStack: TUxLayoutStack);
begin
AContainer.Orientation := AStack.Orientation;
for var i := 0 to AStack.Items.Count - 1 do
begin
if AStack.Items[i] is TUxLayoutPanel then
begin
var LPanel: TUxPanel;
if TUxLayoutPanel(AStack.Items[i]).Instance = nil then
LPanel := TUxPanel.CreateWith(TUxLayoutPanel(AStack.Items[i]).PanelClassName)
else
LPanel := TUxLayoutPanel(AStack.Items[i]).Instance;
LPanel.SectionSize := AStack.Items[i].Size;
LPanel.Replacing := True;
LPanel.LayoutOrder := LIndex;
Inc(LIndex);
AContainer.InsertPanel(LPanel, i);
if AStack.Items[i].Default then
LDefCtl := LPanel;
end
else if AStack.Items[i] is TUxLayoutStack then
begin
var LContainer := TUxContainer.Create(Application);
LContainer.SectionSize := AStack.Items[i].Size;
LContainer.Replacing := True;
AContainer.InsertPanel(LContainer, i);
PopulateStack(LContainer, AStack.Items[i] as TUxLayoutStack);
if AStack.Items[i].Default then
LDefCtl := LContainer;
end;
end;
end;
function TryFindPlace(APanel: TUxPanel; ALayoutPanels: TArray<TUxLayoutPanel>): Boolean;
begin
for var LLayoutPanel in ALayoutPanels do
begin
if
(LLayoutPanel.Instance = nil)
and
not LLayoutPanel.PanelClassName.IsEmpty
and
(LLayoutPanel.PanelClassName = APanel.PanelClass.Name)
then
begin
LLayoutPanel.Instance := APanel;
Exit(True);
end;
end;
Result := False;
end;
function RemoveEmptyStacks(AStack: TUxContainer): Boolean;
begin
for var i := AStack.ControlCount - 1 downto 0 do
if AStack.Controls[i] is TUxContainer then
RemoveEmptyStacks(TUxContainer(AStack.Controls[i]));
Result := AStack.ControlCount = 0;
if Result then
AStack.Free;
end;
begin
try
try
LIndex := 1;
LDefCtl := nil;
if FCleanupTimer = nil then
Exit;
if FCleanupTimer.Enabled then
Exit;
if FCleanupTimer.Tag <> 0 then
Exit;
if ALayout = nil then
Exit;
if FApplyingLayout then
Exit;
FApplyingLayout := True;
try
SetAppCursor;
if Self = Application.MainForm then
if Assigned(TUxPanel.Instances) then
for var LPanel in TUxPanel.Instances do
LPanel.LayoutOrder := 0;
LockDrawing;
try
var LayoutPanels := ALayout.Panels;
if Assigned(TUxPanel.Instances) then
for var LPanel in TUxPanel.Instances do
if GetParentFormSafe(LPanel) = Self then
begin
if TryFindPlace(LPanel, LayoutPanels) then
LPanel.MakeFree
else if LPanel.IsDisposable or LPanel.IsVolatile then
LPanel.Close
else
LPanel.Detach;
end;
if (ControlCount = 1) and (Controls[0] is TUxContainer) then
RemoveEmptyStacks(Controls[0] as TUxContainer);
if ALayout is TUxLayoutPanel then
begin
var LPanel: TUxPanel;
if TUxLayoutPanel(ALayout).Instance = nil then
LPanel := TUxPanel.CreateWith(TUxLayoutPanel(ALayout).PanelClassName)
else
LPanel := TUxLayoutPanel(ALayout).Instance;
InsertPanel(LPanel, 0);
if ALayout.Default then
LDefCtl := LPanel;
end
else if ALayout is TUxLayoutStack then
begin
const LStack = TUxLayoutStack(ALayout);
var LContainer := TUxContainer.Create(Application);
InsertPanel(LContainer, 0);
PopulateStack(LContainer, LStack);
if ALayout.Default then
LDefCtl := LContainer;
end;
finally
if Assigned(FCleanupTimer) then
begin
FCleanupTimer.Tag := NativeUInt(Self);
FCleanupTimer.Enabled := False;
FCleanupTimer.Enabled := True;
end
else
UnlockDrawing;
end;
finally
FApplyingLayout := False;
SetAppCursor;
end;
try
if Assigned(LDefCtl) and LDefCtl.CanFocus then
LDefCtl.FocusContent;
if LDefCtl = nil then
FocusSomething;
except
on E: Exception do
PanelLog('TUxForm.ApplyLayout.focus: ', E)
end;
AppliedLayoutName := ALayout.Title;
InvalidateRect(Handle, AppBarRect, False);
if FLayoutApplicationTimer = nil then
begin
FLayoutApplicationTimer := TTimer.Create(Self);
FLayoutApplicationTimer.Interval := 5000;
FLayoutApplicationTimer.OnTimer := LayoutApplicationTimerTimer;
end;
FLayoutApplicationTimer.Enabled := False;
FLayoutApplicationTimer.Enabled := True;
except
on E: Exception do
raise Exception.Create('TUxForm.ApplyLayout failed: ' + E.ClassName + ': ' + E.Message + ' Layout: ' + ALayout.Title);
end;
finally
if ATakeOwnership then
ALayout.Free;
end;
end;
class procedure TUxForm.AppModalBegin(Sender: TObject);
begin
if Assigned(FInstances) then
for var LForm in FInstances do
LForm.UpdateStatusBar;
end;
class procedure TUxForm.AppModalEnd(Sender: TObject);
begin
UpdateTitleBars(Sender);
end;
function TUxForm.ChildRect: TRect;
begin
Result := Rect(0, 0, ClientWidth, ClientHeight - AppBarHeight);
end;
class constructor TUxForm.ClassCreate;
begin
FInstances := TList<TUxForm>.Create;
TUx.RegisterCallback(UxThemeUpdate);
FAppEvents := TApplicationEvents.Create(nil);
FAppEvents.OnActivate := UpdateTitlebars;
FAppEvents.OnDeactivate := UpdateTitlebars;
FAppEvents.OnModalBegin := AppModalBegin;
FAppEvents.OnModalEnd := AppModalEnd;
FAppEvents.OnHint := AppHint;
FCleanupTimer := TTimer.Create(nil);
FCleanupTimer.Interval := 50;
FCleanupTimer.Enabled := False;
FCleanupTimer.OnTimer := CleanupTimerTimer;
end;
class destructor TUxForm.ClassDestroy;
begin
FreeAndNil(FCleanupTimer);
FreeAndNil(FAppEvents);
FreeAndNil(FInstances);
end;
class procedure TUxForm.Cleanup;
begin
var L := TList<TUxForm>.Create;
try
if Assigned(FInstances) then
for var LForm in FInstances do
if LForm.IsSuperfluous then
L.Add(LForm);
for var LForm in L do
begin
if LForm = Application.MainForm then
else
LForm.Free;
end;
finally
L.Free;
end;
end;
function UxObjectCount: Integer;
begin
if TUxForm.Instances = nil then
Exit(0);
if TUxContainer.Instances = nil then
Exit(0);
if TUxPanel.Instances = nil then
Exit(0);
Result :=
TUxForm.Instances.Count
+
TUxContainer.Instances.Count
+
TUxPanel.Instances.Count;
end;
class procedure TUxForm.CleanupTimerTimer(Sender: TObject);
begin
if TUxContainer.DebugMode then
PanelLog('Cleanup?');
if FApplyingLayout then
Exit;
if TUxForm.Instances = nil then
Exit;
if TUxContainer.Instances = nil then
Exit;
if TUxPanel.Instances = nil then
Exit;
if TUxContainer.DebugMode then
PanelLog('Cleanup');
const LInitialCount = UxObjectCount;
var S := '';
try
S := 'TUxPanel.Cleanup';
TUxPanel.Cleanup;
S := 'TUxContainer.Cleanup';
TUxContainer.Cleanup;
S := 'TUxForm.Cleanup';
TUxForm.Cleanup;
S := 'TUxPanel.ApplyLayoutOrder';
if
(Sender is TTimer)
and
Assigned(TUxForm.FInstances)
and
TUxForm.FInstances.Contains(TUxForm(TTimer(Sender).Tag))
then
TUxPanel.ApplyLayoutOrder;
except
on E: Exception do
PanelLog(S, E);
end;
const LFinalCount = UxObjectCount;
if Assigned(FCleanupTimer) then
begin
FCleanupTimer.Enabled := LFinalCount < LInitialCount;
if
not FCleanupTimer.Enabled
and
(FCleanupTimer.Tag <> 0)
and
Assigned(TUxForm.FInstances)
and
TUxForm.FInstances.Contains(TUxForm(FCleanupTimer.Tag))
then
begin
var LForm := TUxForm(FCleanupTimer.Tag);
try
FCleanupTimer.Tag := 0;
finally
LForm.UnlockDrawing;
SetAppCursor;
end;
end
else if not FCleanupTimer.Enabled then
begin
FCleanupTimer.Tag := 0;
SetAppCursor;
end;
end;
end;
procedure TUxForm.Click;
begin
inherited;
if (FMouseDownHitTest = FHitTest) and (FHitTest = FHT_APPBUTTON) then
if not FAppMenuToRemainClosed then
ShowAppMenu
else
FAppMenuToRemainClosed := False;
end;
procedure TUxForm.CMMouseLeave(var Message: TMessage);
begin
if FHitTest <> 0 then
begin
FHitTest := 0;
Invalidate;
end;
end;
procedure TUxForm.ConstraintsTimerTimer(Sender: TObject);
function GetXCM(ACtl: TUxDockable): Integer;
begin
if ACtl is TUxContainer then
begin
const Ctn = TUxContainer(ACtl);
if Ctn.Orientation = uxoHorizontal then
begin
Result := 0;
for var LSection in Ctn.FSections do
Inc(Result, GetXCM(LSection));
end
else
begin
Result := 1;
for var LSection in Ctn.FSections do
Result := Max(Result, GetXCM(LSection));
end;
end
else
Result := 1;
end;
function GetYCM(ACtl: TUxDockable): Integer;
begin
if ACtl is TUxContainer then
begin
const Ctn = TUxContainer(ACtl);
if Ctn.Orientation = uxoVertical then
begin
Result := 0;
for var LSection in Ctn.FSections do
Inc(Result, GetYCM(LSection));
end
else
begin
Result := 1;
for var LSection in Ctn.FSections do
Result := Max(Result, GetYCM(LSection));
end;
end
else
Result := 1;
end;
const
MinPanelWidth = 250;
MinPanelHeight = 225;
begin
if FConstraintsTimer = nil then
Exit;
FConstraintsTimer.Enabled := False;
var xcm := 0;
var ycm := 0;
for var i := 0 to ControlCount - 1 do
if Controls[i] is TUxDockable then
begin
xcm := Max(xcm, GetXCM(TUxDockable(Controls[i])));
ycm := Max(ycm, GetYCM(TUxDockable(Controls[i])));
end;
if InRange(xcm, 1, 6) and InRange(ycm, 1, 6) then
begin
Constraints.MinWidth := xcm * ScaleValue(MinPanelWidth);
Constraints.MinHeight := ycm * ScaleValue(MinPanelHeight);
end
else
begin
Constraints.MinWidth := 0;
Constraints.MinHeight := 0;
end;
if TUxContainer.DebugMode then
begin
PanelLog(Caption + ' cstr x ' + xcm.ToString + ', ' + IntToStr(Constraints.MinWidth));
PanelLog(Caption + ' cstr y ' + ycm.ToString + ', ' + IntToStr(Constraints.MinHeight));
end;
end;
constructor TUxForm.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csOpaque, csReplicatable];
DoubleBuffered := True;
Color := clWindow;
FUxDockSite := TUxDockSite.Create(Self);
if Assigned(FInstances) then
FInstances.Add(Self);
FConstraintsTimer := TTimer.Create(Self);
FConstraintsTimer.Interval := 1000;
FConstraintsTimer.OnTimer := ConstraintsTimerTimer;
end;
constructor TUxForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csOpaque, csReplicatable];
DoubleBuffered := True;
Color := clWindow;
FUxDockSite := TUxDockSite.Create(Self);
if Assigned(FInstances) then
FInstances.Add(Self);
FConstraintsTimer := TTimer.Create(Self);
FConstraintsTimer.Interval := 1000;
FConstraintsTimer.OnTimer := ConstraintsTimerTimer;
end;
class function TUxForm.CreateNewForm(AClass: TCustomFormClass): TCustomForm;
begin
var LForm := TUxForm.CreateNew(Application);
LForm.ScaleForCurrentDPI;
var LPanel := TUxPanel.CreateWith(AClass);
LPanel.Parent := LForm;
LForm.Show;
if LPanel.TryGetMainChild<TCustomForm>(Result) then
Result.ScaleForCurrentDPI
else
Result := nil;
end;
class function TUxForm.CreateNewForm<T>(AAdoptee: TControl): T;
begin
var LForm := TUxForm.CreateNew(Application);
LForm.ScaleForCurrentDPI;
var LPanel := TUxPanel.CreateWith(T, AAdoptee);
LPanel.Parent := LForm;
LForm.Show;
if LPanel.TryGetMainChild<T>(Result) then
Result.ScaleForCurrentDPI
else
Result := nil;
end;
class procedure TUxForm.CreateNewForm;
begin
var LForm := TUxForm.CreateNew(Application);
LForm.ScaleForCurrentDPI;
var LPanel := TUxPanel.Create(Application);
LPanel.Parent := LForm;
LForm.Show;
end;
const
DWMWA_BORDER_COLOR = 34;
DWMWA_CAPTION_COLOR = 35;
DWMWA_TEXT_COLOR = 36;
procedure TUxForm.CreateWnd;
begin
inherited;
OleCheck(RegisterDragDrop(Handle, Self));
ThemeUpdate;
end;
procedure TUxForm.Deactivate;
begin
inherited;
UpdateDwmColors;
Invalidate;
end;
destructor TUxForm.Destroy;
begin
if Assigned(FInstances) then
FInstances.Remove(Self);
inherited;
end;
procedure TUxForm.DoClose(var Action: TCloseAction);
begin
if Self.FApplyingLayout then
begin
Action := TCloseAction.caNone;
Exit;
end;
if Self = Application.MainForm then
begin
if Assigned(TUxPanel.Instances) then
for var LPanel in TUxPanel.Instances do
if not LPanel.CanClose then
begin
Action := TCloseAction.caNone;
Exit;
end;
Exit;
end;
if Assigned(TUxPanel.Instances) then
for var LPanel in TUxPanel.Instances do
if Self.ContainsControl(LPanel) then
if not LPanel.CanClose then
begin
Action := TCloseAction.caNone;
Exit;
end;
Action := TCloseAction.caFree;
end;
procedure TUxForm.DoShow;
begin
inherited;
if not FHasShown and (ControlCount = 1) and (Controls[0] is TUxPanel) then
begin
FHasShown := True;
var LPanelForm := TPanelForm(nil);
if TUxPanel(Controls[0]).TryGetMainChild<TPanelForm>(LPanelForm) then
begin
if LPanelForm.ScaleFactor <> Self.ScaleFactor then
LPanelForm.ScaleForPPI(Self.CurrentPPI);
LPanelForm.FirstShow;
end;
end;
FHasShown := True;
end;
function TUxForm.FindInsertionPoint(const APoint: TPoint): Integer;
const
Sides: array[Boolean, Boolean] of Integer = ((0, 3), (1, 2));
begin
const X = APoint.X / ClientWidth;
const Y = APoint.Y / ClientHeight;
Result := Sides[X < Y, Y > 1 - X];
end;
procedure TUxForm.FocusSomething;
var
LAnyPanel: TUxPanel;
LConsolePanel: TUxPanel;
procedure Scan(ACtl: TWinControl);
begin
for var i := ACtl.ControlCount - 1 downto 0 do
if ACtl.Controls[i] is TUxPanel then
begin
LAnyPanel := TUxPanel(ACtl.Controls[i]);
const FC = TUxPanel(ACtl.Controls[i]).PanelClass.FormClass;
if Assigned(FC) and FC.InheritsFrom(TConsoleForm) then
begin
LConsolePanel := TUxPanel(ACtl.Controls[i]);
Exit;
end;
end
else if ACtl.Controls[i] is TUxContainer then
begin
Scan(TUxContainer(ACtl.Controls[i]));
if Assigned(LConsolePanel) then
Exit;
end;
end;
begin
LAnyPanel := nil;
LConsolePanel := nil;
Scan(Self);
if Assigned(LConsolePanel) then
LConsolePanel.FocusContent
else if Assigned(LAnyPanel) then
LAnyPanel.FocusContent;
end;
function TUxForm.HitTest(const X, Y: Integer): Integer;
begin
Result := HitTest(Point(X, Y));
end;
function TUxForm.HitTest(const P: TPoint): Integer;
begin
if AppButtonRect.Contains(P) then
Exit(FHT_APPBUTTON);
Result := 0;
end;
procedure TUxForm.InsertPanel(APanel: TUxDockable; AIndex: Integer);
const
OrientationFromSideParity: array[Boolean] of TUxContainerOrientation =
(uxoVertical, uxoHorizontal);
begin
Assert(Assigned(APanel));
Assert(APanel.Parent = nil);
APanel.Replacing := False;
if ControlCount = 0 then
begin
APanel.Parent := Self;
APanel.Align := alNone;
Realign;
end
else if
(ControlCount = 1)
and
(Controls[0] is TUxContainer)
and
(Odd(Ord(TUxContainer(Controls[0]).Orientation)) <> Odd(AIndex))
then
begin
var LCtr := Controls[0] as TUxContainer;
LCtr.InsertPanel(APanel, IfThen(AIndex <= 1, 0, LCtr.FSections.Count))
end
else if
(ControlCount = 1)
and
(Controls[0] is TUxDockable)
then
begin
var LOldCtr := Controls[0] as TUxDockable;
LOldCtr.Parent := nil;
var LNewCtr := TUxContainer.Create(Application);
LNewCtr.Orientation := OrientationFromSideParity[Odd(AIndex)];
LNewCtr.Parent := Self;
LNewCtr.InsertPanel(LOldCtr, 0);
LNewCtr.InsertPanel(APanel, IfThen(AIndex <= 1, 0, LNewCtr.FSections.Count));
end
else
PanelLog('TUxForm.InsertPanel: Multiple or unknown controls.');
RethinkConstraints;
end;
function TUxForm.IsSuperfluous: Boolean;
begin
Result := False;
var Ctl := TWinControl(Self);
while Assigned(Ctl) do
begin
if Ctl.ControlCount = 0 then
Exit(True);
if Ctl.ControlCount > 1 then
Exit(False);
if not (Ctl.Controls[0] is TUxContainer) then
Exit(False);
Ctl := Ctl.Controls[0] as TUxContainer;
end;
end;
procedure TUxForm.LayoutApplicationTimerTimer(Sender: TObject);
begin
if Assigned(FLayoutApplicationTimer) then
FLayoutApplicationTimer.Enabled := False;
AppliedLayoutName := '';
InvalidateRect(Handle, AppBarRect, False);
end;
procedure TUxForm.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
FAppMenuToRemainClosed := GetTickCount64 - FAppMenuTickCount < 10;
inherited;
var LNewHitTest := HitTest(X, Y);
if LNewHitTest = FHT_APPBUTTON then
begin
FAppButtonDown := True;
Invalidate;
end;
if FHitTest <> LNewHitTest then
begin
FHitTest := LNewHitTest;
Invalidate;
end;
FMouseDownHitTest := LNewHitTest;
end;
procedure TUxForm.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
var LNewHitTest := HitTest(X, Y);
if FHitTest <> LNewHitTest then
begin
FHitTest := LNewHitTest;
Invalidate;
end;
end;
procedure TUxForm.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
FMouseDownHitTest := 0;
if FAppButtonDown then
begin
FAppButtonDown := False;
Invalidate;
end;
end;
procedure TUxForm.MovePanel(APanel: TUxDockable; AIndex: Integer);
begin
end;
procedure TUxForm.Paint;
begin
inherited;
var R := TRect.Empty;
var S := '';
const BorderPadding = ScaleValue(TUxContainer.BorderPaddingInvariant);
case FUxDockSite.FInsertionPoint of
0:
R := Rect(0, 0, ClientWidth, BorderPadding);
1:
R := Rect(0, 0, BorderPadding, ClientHeight - AppBarHeight);
2:
R := Rect(0, ClientHeight - BorderPadding - AppBarHeight, ClientWidth, ClientHeight - AppBarHeight);
3:
R := Rect(ClientWidth - BorderPadding, 0, ClientWidth, ClientHeight - AppBarHeight);
end;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := TUx.ThemeData.WindowedColor;
Canvas.FillRect(ChildRect);
if ControlCount = 0 then
begin
Canvas.Font.Name := 'Palatino Linotype';
Canvas.Font.Size := 24;
Canvas.Font.Style := [TFontStyle.fsItalic];
Canvas.Font.Color := TUx.ThemeData.InactiveCaptionColor;
var R2 := ChildRect;
var S2 := 'Algosim';
Canvas.TextRect(R2, S2, [tfSingleLine, tfCenter, tfVerticalCenter])
end;
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.FillRect(AppBarRect);
if not R.IsEmpty then
begin
Canvas.Brush.Color :=
IfThen(
FUxDockSite.FInsertionPointAnimationStep,
TUx.ThemeData.InsertionPointColor2,
TUx.ThemeData.InsertionPointColor1
);
Canvas.FillRect(R);
end;
if (WindowState <> TWindowState.wsMaximized) and (Application.ModalLevel = 0) then
begin
const ABR = AppBarRect;
Canvas.Pen.Style := psClear;
const P0 = ABR.BottomRight;
const P1 = P0 - Point(0, ABR.Height);
const P2 = P0 - Point(ABR.Height, 0);
if Active then
Canvas.Brush.Color := TUx.ThemeData.Accent0
else
Canvas.Brush.Color := TUx.ThemeData.CaptionMidColor;
Canvas.Polygon([P0, P1, P2]);
end;
Canvas.Font.Assign(Self.Font);
Canvas.Font.Height := ScaleValue(GDefTextHeight);
if Application.ModalLevel > 0 then
begin
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.Font.Color := TUx.ThemeData.InactiveTextColor;
end
else if FAppButtonDown then
begin
Canvas.Brush.Color := TUx.ThemeData.BlackenedColor;
Canvas.Font.Color := TUx.ThemeData.OtherWB(Canvas.Brush.Color);
end
else if FHitTest = FHT_APPBUTTON then
begin
Canvas.Brush.Color := TUx.ThemeData.CaptionMidColor;
Canvas.Font.Color := TUx.ThemeData.OtherWB(Canvas.Brush.Color);
end
else
begin
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.Font.Color := TUx.ThemeData.InactiveCaptionTextColor;
end;
R := AppButtonRect;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(R);
Canvas.Brush.Style := bsClear;
const LIndent = ScaleValue(GIndentSize);
S := AppMenuCaption;
Canvas.TextRect(R, S, [tfSingleLine, tfCenter, tfVerticalCenter]);
if Application.ModalLevel > 0 then
begin
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.Font.Color := TUx.ThemeData.InactiveTextColor;
end
else
begin
Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;
Canvas.Font.Color := TUx.ThemeData.InactiveCaptionTextColor;
end;
Canvas.Brush.Style := bsClear;
if Application.Hint.IsEmpty then
begin
const delim = ' ';
S := FAppBarStatus;
if Application.ModalLevel > 0 then
S := S + delim + 'Modal dialog';
if TUxContainer.LayoutMode then
S := S + delim + 'Layout mode';
if not AppliedLayoutName.IsEmpty then
S := S + delim + Format('Layout “%s” applied', [AppliedLayoutName]);
end
else
S := Application.Hint;
R := AppBarRect;
R.Left := AppButtonRect.Right + LIndent;
R.Right := R.Right - LIndent;
const LOriginalFontHeight = Canvas.Font.Height;
const LFontHeightLimit = Round(0.8 * LOriginalFontHeight);
while (Canvas.TextWidth(S) > R.Width) and (Canvas.Font.Height > LFontHeightLimit) do
Canvas.Font.Height := Canvas.Font.Height - 1;
Canvas.TextRect(R, S, [tfSingleLine, tfVerticalCenter, tfLeft, tfEndEllipsis]);
end;
class procedure TUxForm.Relayout(ALayoutMode: Boolean);
begin
if Assigned(FInstances) then
for var LFrm in FInstances do
begin
LFrm.Realign;
LFrm.Invalidate;
end;
end;
class procedure TUxForm.RequestCleanup;
begin
if GetCurrentThreadId <> MainThreadID then
Exit;
if Assigned(FCleanupTimer) then
begin
FCleanupTimer.Enabled := False;
FCleanupTimer.Enabled := True;
end;
end;
procedure TUxForm.RequestClientSize(const ASize: TSize);
begin
RequestClientSize(ASize.Width, ASize.Height);
end;
procedure TUxForm.RequestClientSize(AWidth, AHeight: Integer);
begin
ClientWidth := AWidth;
ClientHeight := AHeight + AppBarHeight;
end;
procedure TUxForm.Resize;
begin
inherited;
Invalidate;
end;
procedure TUxForm.RethinkConstraints;
begin
if Assigned(FConstraintsTimer) then
begin
FConstraintsTimer.Enabled := False;
FConstraintsTimer.Enabled := True;
end;
end;
class procedure TUxForm.SetAppBarStatus(const Value: string);
begin
if FAppBarStatus <> Value then
begin
FAppBarStatus := Value;
UpdateAppBars;
end;
end;
class procedure TUxForm.SetAppMenuCaption(const Value: string);
begin
if FAppMenuCaption <> Value then
begin
FAppMenuCaption := Value;
UpdateAppBars;
end;
end;
procedure TUxForm.ShowAppMenu;
begin
if Assigned(FAppMenu) then
begin
FAppButtonDown := True;
Invalidate;
const P = ClientToScreen(AppBarRect.TopLeft);
try
FAppMenu.PopupComponent := Self;
FAppMenu.Popup(P.X, P.Y);
if Assigned(Self) then
FAppMenuTickCount := GetTickCount64;
finally
if Assigned(Self) then
begin
FAppButtonDown := False;
Invalidate;
end;
end;
end;
end;
function TUxForm.SizeGripRect: TRect;
begin
const ABR = AppBarRect;
const P = AppBarRect.BottomRight;
Result := TRect.Create(P - Point(ABR.Height, ABR.Height), P);
end;
procedure TUxForm.ThemeUpdate;
begin
UpdateDwmColors;
InvalidateRect(Handle, AppBarRect, False);
end;
class procedure TUxForm.UpdateAppBars;
begin
if Assigned(FInstances) then
for var LForm in FInstances do
InvalidateRect(LForm.Handle, LForm.AppBarRect, False);
end;
procedure TUxForm.UpdateDwmColors;
var
c: DWORD;
begin
if not GThemedBorders then
Exit;
if Active then
c := TUx.ThemeData.ActiveCaptionColor
else
c := TUx.ThemeData.InactiveCaptionColor;
DwmSetWindowAttribute(Handle, DWMWA_CAPTION_COLOR, @c, SizeOf(c));
c := TUx.ThemeData.ActiveCaptionColor;
DwmSetWindowAttribute(Handle, DWMWA_BORDER_COLOR, @c, SizeOf(c));
if Active then
c := TUx.ThemeData.ActiveCaptionTextColor
else
c := Blend(0.25, TUx.ThemeData.InactiveCaptionTextColor, TUx.ThemeData.InactiveCaptionColor);
DwmSetWindowAttribute(Handle, DWMWA_TEXT_COLOR, @c, SizeOf(c));
end;
procedure TUxForm.UpdateStatusBar;
begin
InvalidateRect(Handle, AppBarRect, False);
end;
class procedure TUxForm.UxThemeUpdate;
begin
if Assigned(FInstances) then
for var Form in FInstances do
Form.ThemeUpdate;
end;
procedure TUxForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TUxForm.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;
if SizeGripRect.Contains(ScreenToClient(Mouse.CursorPos)) then
Message.Result := HTBOTTOMRIGHT;
end;
procedure TUxForm.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
inherited;
for var i := 0 to ControlCount - 1 do
if Controls[i] is TUxDockable then
TUxDockable(Controls[i]).ScreenCoordsChanged;
end;
constructor PanelAttribute.Create(const AName: string);
begin
FName := AName;
end;
constructor PanelAttribute.Create(const AName: string;
const AExts: string);
begin
FName := AName;
FExts := AExts.Split([',']);
end;
procedure TListForm.BuildContextMenu;
begin
if Assigned(FPopupMenu) then
Exit;
if FListView = nil then
Exit;
FPopupMenu := TPopupMenu.Create(FListView);
FPopupMenu.OnPopup := PopupMenuPopup;
FListView.PopupMenu := FPopupMenu;
FmiDefault := TMenuItem.Create(FPopupMenu);
FmiDefault.Caption := 'Open';
FmiDefault.OnClick := DefaultClick;
FmiDefault.Default := True;
FPopupMenu.Items.Add(FmiDefault);
FmiDelete := TMenuItem.Create(FPopupMenu);
FmiDelete.Caption := 'Delete'#9'Del';
FmiDelete.Hint := 'Deletes the selected object(s).';
FmiDelete.OnClick := DeleteClick;
FPopupMenu.Items.Add(FmiDelete);
FPopupMenu.Items.InsertNewLineAfter(FmiDelete);
FmiCopyRows := TMenuItem.Create(FPopupMenu);
FmiCopyRows.Caption := 'Copy rows'#9'Ctrl+C';
FmiCopyRows.Hint := 'Copies the selected row(s) to clipboard.';
FmiCopyRows.OnClick := CopyRowsClick;
FPopupMenu.Items.Add(FmiCopyRows);
FmiSelectAll := TMenuItem.Create(FPopupMenu);
FmiSelectAll.Caption := 'Select all'#9'Ctrl+A';
FmiSelectAll.Hint := 'Selects all rows in the table.';
FmiSelectAll.OnClick := SelectAllClick;
FPopupMenu.Items.Add(FmiSelectAll);
FmiRefresh := TMenuItem.Create(FPopupMenu);
FmiRefresh.Caption := 'Refresh'#9'F5';
FmiRefresh.Hint := 'Updates the table with the latest data.';
FmiRefresh.OnClick := RefreshClick;
FPopupMenu.Items.Add(FmiRefresh);
end;
procedure TListForm.CmdExec(AID: Integer);
begin
case AID of
TLF_REFRESH:
Refresh;
end;
end;
procedure TListForm.CopyRowsClick(Sender: TObject);
begin
if Assigned(FListView) then
FListView.CopySelRows;
end;
class function TListForm.CR(const ACaption: string; AWidth: Integer;
ASortMethod: TColumnSortMethod): TColumnRec;
begin
Result := Default(TColumnRec);
Result.Caption := ACaption;
Result.Width := AWidth;
Result.SortMethod := ASortMethod;
end;
constructor TListForm.Create(AOwner: TComponent);
begin
inherited;
end;
constructor TListForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
FListView := TListViewEx.Create(Self);
FListView.Parent := Self;
FListView.Align := alClient;
FListView.BorderStyle := bsNone;
FListView.ViewStyle := vsReport;
FListView.DoubleBuffered := True;
FListView.ReadOnly := True;
FListView.RowSelect := True;
FListView.MultiSelect := True;
FListView.OnKeyDown := LVKeyDown;
FListView.OnDblClick := DefaultClick;
FListView.OnSelCntChange := LVSelCntChange;
var LSortMethods := TArray<TColumnSortMethod>(nil);
for var LColumn in GetColumns do
begin
var LCtlCol := FListView.Columns.Add;
LCtlCol.Caption := LColumn.Caption;
LCtlCol.Width := ScaleValue(LColumn.Width);
LSortMethods := LSortMethods + [LColumn.SortMethod];
end;
FListView.EnableSorting(LSortMethods);
StatusBar := True;
Refresh;
end;
class function TListForm.DataRow(const AValues: array of Variant;
AData: NativeUInt): TDataRow;
begin
SetLength(Result.Columns, Length(AValues));
for var i := 0 to High(Result.Columns) do
Result.Columns[i] := AValues[i];
Result.Data := AData;
end;
procedure TListForm.DefaultClick(Sender: TObject);
begin
end;
procedure TListForm.DeleteClick(Sender: TObject);
begin
end;
procedure TListForm.FirstShow;
begin
RequestClientSize(1000, 400);
end;
class function TListForm.GetColumns: TArray<TColumnRec>;
begin
Result := nil;
end;
class function TListForm.GetData: TArray<TDataRow>;
begin
Result := nil;
end;
class function TListForm.IsDisposable: Boolean;
begin
Result := True;
end;
procedure TListForm.LVKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
case Key of
VK_F5:
Refresh;
VK_RETURN:
DefaultClick(Sender);
VK_DELETE:
DeleteClick(Sender);
end;
end;
procedure TListForm.LVSelCntChange(Sender: TObject);
begin
UpdateStatusBar;
end;
procedure TListForm.PopupMenuPopup(Sender: TObject);
begin
if Assigned(FmiDefault) then
FmiDefault.Enabled := Assigned(FListView) and (FListView.SelCount = 1);
if Assigned(FmiDelete) then
FmiDelete.Enabled := Assigned(FListView) and (FListView.SelCount > 0);
if Assigned(FmiCopyRows) then
FmiCopyRows.Enabled := Assigned(FListView) and (FListView.SelCount > 0);
if Assigned(FmiSelectAll) then
FmiSelectAll.Enabled := Assigned(FListView) and (FListView.Items.Count > 0);
end;
procedure TListForm.Refresh;
begin
if FListView = nil then
Exit;
if not HandleAllocated then
begin
if FRefresher = nil then
FRefresher := TTimer.Create(Self);
FRefresher.Interval := 500;
FRefresher.OnTimer := RefresherTimer;
FRefresher.Enabled := True;
Exit;
end;
var LRowIdentityRec := Default(TRowIdentityRec);
if HandleAllocated and (FListView.SelCount = 1) then
LRowIdentityRec := TRowIdentityRec.Create(RowIdentity, FListView.Selected);
var LNewItem := TListItem(nil);
FListView.Items.BeginUpdate;
try
FListView.Clear;
var LData := GetData;
for var LRow in LData do
begin
var LItem := FListView.Items.Add;
if Length(LRow.Columns) >= 1 then
LItem.Caption := LRow.Columns[0];
for var i := 1 to FListView.Columns.Count - 1 do
if i <= High(LRow.Columns) then
LItem.SubItems.Add(LRow.Columns[i])
else
LItem.SubItems.Add('');
LItem.Data := Pointer(LRow.Data);
if LRowIdentityRec.Mode <> riNone then
if (LNewItem = nil) and LRowIdentityRec.Matches(LItem) then
LNewItem := LItem;
end;
if Assigned(LNewItem) then
begin
FListView.ClearSelection;
LNewItem.Selected := True;
LNewItem.Focused := True;
LNewItem.MakeVisible(False);
end;
finally
FListView.Items.EndUpdate;
end;
FListView.Resort;
UpdateStatusBar;
end;
procedure TListForm.RefreshClick(Sender: TObject);
begin
Refresh;
end;
procedure TListForm.RefresherTimer(Sender: TObject);
begin
if Assigned(FRefresher) then
FRefresher.Enabled := False;
Refresh;
end;
function TListForm.RowIdentity: TRowIdentity;
begin
Result := riNone;
end;
procedure TListForm.SelectAllClick(Sender: TObject);
begin
if Assigned(FListView) then
FListView.SelectAll;
end;
procedure TListForm.SetupToolMenu;
begin
inherited;
BuildContextMenu;
CreateToolMenu;
SimpleMenu.AddCommand(TLF_REFRESH, FmiRefresh.Caption, FmiRefresh.Hint);
end;
procedure TListForm.UpdateStatusBar;
begin
if Assigned(FListView) then
StatusText := Format('%d item(s) %d selected', [FListView.Items.Count, FListView.SelCount])
else
StatusText := '';
end;
constructor TListForm.TRowIdentityRec.Create(AMode: TRowIdentity;
AItem: TListItem);
begin
Self := Default(TRowIdentityRec);
if AItem = nil then
Exit;
Self.Mode := AMode;
case AMode of
riCaption:
Self.Caption := AItem.Caption;
riData:
Self.Data := AItem.Data;
end;
end;
constructor TListForm.TRowIdentityRec.Create(const ACaption: string);
begin
Self := Default(TRowIdentityRec);
Self.Mode := riCaption;
Self.Caption := ACaption;
end;
constructor TListForm.TRowIdentityRec.Create(AData: Pointer);
begin
Self := Default(TRowIdentityRec);
Self.Mode := riData;
Self.Data := AData;
end;
class operator TListForm.TRowIdentityRec.Equal(const Left,
Right: TRowIdentityRec): Boolean;
begin
if Left.Mode <> Right.Mode then
Exit(False);
case Left.Mode of
riNone:
Result := False;
riCaption:
Result := Left.Caption = Right.Caption;
riData:
Result := Left.Data = Right.Data;
else
Result := False;
end;
end;
function TListForm.TRowIdentityRec.Matches(AItem: TListItem): Boolean;
begin
case Self.Mode of
riCaption:
Result := Assigned(AItem) and (Self.Caption = AItem.Caption);
riData:
Result := Assigned(AItem) and (Self.Data = AItem.Data);
else
Result := False;
end;
end;
class procedure TWndMgrForm.ActChNot;
begin
if Assigned(FInstances) then
for var LForm in FInstances do
LForm.UpdateActive;
end;
class constructor TWndMgrForm.ClassCreate;
begin
FInstances := TList<TWndMgrForm>.Create;
end;
class destructor TWndMgrForm.ClassDestroy;
begin
FreeAndNil(FInstances);
end;
procedure TWndMgrForm.CmdExec(AID: Integer);
begin
case AID of
WMF_NEWWIN:
TUxForm.CreateNewForm;
else
inherited;
end;
end;
function TWndMgrForm.ContextHelp: Boolean;
begin
TDocBrowser.ShowDocOrIndex('Window manager', False);
Result := True;
end;
constructor TWndMgrForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
if not FHasReg then
begin
FHasReg := True;
TUxPanel.RegisterChangeNotification(WndChNot);
TUxPanel.RegisterActivePanelNotification(ActChNot);
end;
FListView.OnCustomDrawItem := LvCustomDrawItem;
FListView.EmptyText := 'No windows';
if Assigned(FInstances) then
FInstances.Add(Self);
end;
procedure TWndMgrForm.DefaultClick(Sender: TObject);
begin
inherited;
if FListView = nil then
Exit;
if FListView.SelCount <> 1 then
Exit;
if FListView.ItemIndex = -1 then
Exit;
var LData := FListView.Items[FListView.ItemIndex].Data;
if LData = nil then
Exit;
var LObject := TObject(LData);
if LObject is TUxPanel then
begin
var LPanel := TUxPanel(LObject);
if LPanel.CanFocus then
LPanel.SetFocus;
end;
end;
procedure TWndMgrForm.DeleteClick(Sender: TObject);
begin
inherited;
if FListView = nil then
Exit;
var LPanelsToClose := TList<TUxPanel>.Create;
try
var Idx := FListView.GetSelectedIndicesFast;
for var i in Idx do
begin
var LData := FListView.Items[i].Data;
if LData = nil then
Continue;
var LObject := TObject(LData);
if LObject is TUxPanel then
LPanelsToClose.Add(TUxPanel(LObject));
end;
for var LPanel in LPanelsToClose do
LPanel.Close;
finally
LPanelsToClose.Free;
end;
end;
destructor TWndMgrForm.Destroy;
begin
if Assigned(FInstances) then
FInstances.Remove(Self);
inherited;
end;
class function TWndMgrForm.GetColumns: TArray<TListForm.TColumnRec>;
begin
Result :=
[
CR('Name', 250, csmText),
CR('Type', 200, csmText),
CR('#', 50, csmInteger)
];
end;
class function TWndMgrForm.GetData: TArray<TListForm.TDataRow>;
begin
var L := TList<TListForm.TDataRow>.Create;
try
if Assigned(TUxPanel.Instances) then
for var i := 0 to TUxPanel.Instances.Count - 1 do
begin
const LPanel = TUxPanel.Instances[i];
var LName: string := LPanel.Caption;
if LName.IsEmpty then
LName := '(Unnamed window)';
var LClass := LPanel.PanelClass.Name;
L.Add(DataRow([LName, LClass, Succ(i)], NativeUInt(LPanel)));
end;
Result := L.ToArray;
finally
L.Free;
end;
end;
procedure TWndMgrForm.LvCustomDrawItem(Sender: TCustomListView; Item: TListItem;
State: TCustomDrawState; var DefaultDraw: Boolean);
begin
if Assigned(Sender) and Assigned(Item) and (Item.Data <> nil) and (Item.Data = FActivePanel) then
begin
Sender.Canvas.Font.Assign(Font);
Sender.Canvas.Font.PixelsPerInch := Self.PixelsPerInch;
Sender.Canvas.Font.Size := 9;
Sender.Canvas.Font.Style := [TFontStyle.fsBold];
end;
end;
procedure TWndMgrForm.LVKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if
(Shift = [ssCtrl])
and
(Key in [Ord('U'), Ord('D')])
then
begin
if Key = Ord('U') then
mnuMovePanelUpClick(Sender)
else
mnuMovePanelDownClick(Sender)
end
else
inherited;
end;
procedure TWndMgrForm.mnuMovePanelDownClick(Sender: TObject);
begin
if FListView = nil then
Exit;
if FListView.SelCount <> 1 then
Exit;
if FListView.ItemIndex = -1 then
Exit;
if FListView.Selected = nil then
Exit;
if TUxPanel.Instances = nil then
Exit;
const LCurIdx = TUxPanel.Instances.IndexOf(TUxPanel(FListView.Selected.Data));
if (LCurIdx = -1) or (LCurIdx = TUxPanel.Instances.Count - 1) then
Exit;
TUxPanel.Instances.Move(LCurIdx, Succ(LCurIdx));
TUxPanel.DoChangeNotification;
end;
procedure TWndMgrForm.mnuMovePanelUpClick(Sender: TObject);
begin
if FListView = nil then
Exit;
if FListView.SelCount <> 1 then
Exit;
if FListView.ItemIndex = -1 then
Exit;
if FListView.Selected = nil then
Exit;
if TUxPanel.Instances = nil then
Exit;
const LCurIdx = TUxPanel.Instances.IndexOf(TUxPanel(FListView.Selected.Data));
if LCurIdx <= 0 then
Exit;
TUxPanel.Instances.Move(LCurIdx, Pred(LCurIdx));
TUxPanel.DoChangeNotification;
end;
procedure TWndMgrForm.mnuNewPanelClick(Sender: TObject);
begin
TUxForm.CreateNewForm;
end;
procedure TWndMgrForm.PopupMenuPopup(Sender: TObject);
begin
inherited;
FmiDefault.Caption := 'Go to';
FmiDefault.Hint := 'Sets focus to the selected panel.';
FmiDelete.Caption := 'Close'#9'Del';
FmiDelete.Hint := 'Closes the selected panel(s).';
end;
function TWndMgrForm.RowIdentity: TListForm.TRowIdentity;
begin
Result := riData;
end;
procedure TWndMgrForm.SetupToolMenu;
begin
inherited;
FmiNewPanel := TMenuItem.Create(Self);
FmiNewPanel.Caption := 'New window';
FmiNewPanel.Hint := 'Creates a new floating window.';
FmiNewPanel.OnClick := mnuNewPanelClick;
FPopupMenu.Items.Insert(2, FmiNewPanel);
FmiMoveUp := TMenuItem.Create(Self);
FmiMoveUp.Caption := 'Move up'#9'Ctrl+U';
FmiMoveUp.Hint := 'Moves the selected panel up in the list.';
FmiMoveUp.OnClick := mnuMovePanelUpClick;
FPopupMenu.Items.Insert(3, FmiMoveUp);
FmiMoveDown := TMenuItem.Create(Self);
FmiMoveDown.Caption := 'Move down'#9'Ctrl+D';
FmiMoveDown.Hint := 'Moves the selected panel down in the list.';
FmiMoveDown.OnClick := mnuMovePanelDownClick;
FPopupMenu.Items.Insert(4, FmiMoveDown);
FPopupMenu.Items.InsertNewLineBefore(FmiMoveUp);
SimpleMenu.AddCommand(WMF_NEWWIN, FmiNewPanel.Caption, FMiNewPanel.Hint);
end;
procedure TWndMgrForm.UpdateActive;
begin
FActivePanel := TUxPanel.ActivePanel;
if Assigned(FListView) then
FListView.Invalidate;
end;
class procedure TWndMgrForm.WndChNot;
begin
if Assigned(FInstances) then
for var LForm in FInstances do
LForm.Refresh;
end;
function TPanelForm.AddToolbarControl<T>(ASubclass: TControlClass = nil): T;
begin
RequireToolbar;
if Assigned(ASubclass) and ASubclass.InheritsFrom(T) then
Result := ASubclass.Create(Self) as T
else
Result := T.Create(Self);
if Result is TLabel then
begin
TLabel(Result).Layout := tlCenter;
end
else if Result is TTextEditor then
begin
TTextEditor(Result).UseRuxThemes := True;
TTextEditor(Result).AutoHeight := False;
end;
FToolBarControls := FToolBarControls + [Result];
Result.Parent := FToolBar;
UpdateToolbar;
end;
procedure TPanelForm.AfterConstruction;
begin
inherited;
SetupToolMenu;
SetupToolbar;
LoadSettings;
end;
procedure TPanelForm.BeginActive;
begin
if
Assigned(FToolBar)
and
(FToolBarControls <> nil)
and
Assigned(FToolbarCaptions)
and
(FToolbarCaptions.Count > 0)
then
begin
for var LCtl in FToolBarControls do
begin
if LCtl is TUxButton then
begin
const LBtn = TUxButton(LCtl);
var LOriginalCaption := '';
if FToolbarCaptions.TryGetValue(LBtn, LOriginalCaption) then
LBtn.Caption := LOriginalCaption;
end;
end;
FToolbarCaptions.Clear;
end;
end;
procedure TPanelForm.BeginHighlight;
begin
var LPanel := Panel;
if Assigned(LPanel) then
LPanel.BeginHighlight;
end;
function TPanelForm.CanClose: Boolean;
begin
if Assigned(TTextEditor.InstancesWithBalloons) then
for var LEditor in TTextEditor.InstancesWithBalloons do
if ControlHasAncestor(LEditor, Self) then
begin
LEditor.HideBalloon;
Exit(False);
end;
Result := True;
end;
procedure TPanelForm.ChangeScale(M, D: Integer; isDpiChange: Boolean);
begin
inherited;
FontFix;
UpdateToolbar;
end;
procedure TPanelForm.CmdExec(AID: Integer);
begin
case AID of
PAN_SHOWTOOLBAR:
ShowToolBar := not ShowToolbar;
end;
end;
procedure TPanelForm.CmdGetState(AID: Integer; var AVisible, AEnabled, AChecked: Boolean);
begin
case AID of
PAN_SHOWTOOLBAR:
AChecked := ShowToolBar;
end;
end;
procedure TPanelForm.CMTextChanged(var Message: TMessage);
begin
inherited;
var LPanel := Panel;
if Assigned(LPanel) then
LPanel.Caption := Self.Caption;
end;
constructor TPanelForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
FGUID := TGUID.NewGuid;
DoubleBuffered := True;
if Assigned(TUxPanel.FPanelClasses) then
for var LPanelClass in TUxPanel.FPanelClasses do
if LPanelClass.Value.FormClass = Self.ClassType then
begin
Caption := LPanelClass.Value.Name;
Break;
end;
end;
constructor TPanelForm.CreateNewWith(AOwner: TComponent; AAdoptee: TControl);
begin
CreateNew(AOwner);
if Assigned(AAdoptee) then
begin
AAdoptee.Parent := Self;
AAdoptee.Align := alClient;
end;
end;
procedure TPanelForm.CreateToolMenu;
begin
if Assigned(FToolMenu) then
Exit;
var LMenu := TSimpleMenu.Create(Self);
ToolMenu := LMenu;
LMenu.OnCmdExec := MenuCmdExec;
LMenu.OnGetState := MenuGetState;
end;
destructor TPanelForm.Destroy;
begin
FreeAndNil(FToolbarCaptions);
inherited;
end;
procedure TPanelForm.EndActive;
begin
if Assigned(FToolBar) and (FToolBarControls <> nil) then
begin
for var LCtl in FToolBarControls do
begin
if LCtl is TUxButton then
begin
const LBtn = TUxButton(LCtl);
if string(LBtn.Caption).Contains('&') then
begin
if FToolbarCaptions = nil then
FToolbarCaptions := TDictionary<TUxButton, string>.Create;
FToolbarCaptions.AddOrSetValue(LBtn, LBtn.Caption);
LBtn.Caption := StripHotkey(LBtn.Caption);
end;
end;
end;
end;
end;
procedure TPanelForm.EndHighlight;
begin
var LPanel := Panel;
if Assigned(LPanel) then
LPanel.EndHighlight;
end;
procedure TPanelForm.FirstShow;
begin
end;
procedure TPanelForm.FocusSender(Sender: TObject);
begin
if (Sender is TWinControl) and TWinControl(Sender).CanFocus then
TWinControl(Sender).SetFocus
else if (Sender is TControl) and Assigned(TControl(Sender).Parent) and TControl(Sender).Parent.CanFocus then
TControl(Sender).Parent.SetFocus;
end;
type
TControlCracker = class(TControl)
end;
procedure TPanelForm.FontFix;
begin
Font.PixelsPerInch := Self.PixelsPerInch;
Font.Size := 9;
for var i := 0 to ControlCount - 1 do
begin
const Ctl = TControlCracker(Controls[i]);
Ctl.Font.PixelsPerInch := Self.PixelsPerInch;
Ctl.Font.Size := 9;
Ctl.Invalidate;
end;
end;
function TPanelForm.GetLeftStatusClick: Boolean;
begin
var LPanel := Panel;
Result := Assigned(LPanel) and LPanel.LeftStatusClick;
end;
function TPanelForm.GetRightStatusClick: Boolean;
begin
var LPanel := Panel;
Result := Assigned(LPanel) and LPanel.RightStatusClick;
end;
function TPanelForm.GetShowToolbar: Boolean;
begin
Result := Assigned(FToolBar) and FToolBar.Visible;
end;
function TPanelForm.GetStatusBar: Boolean;
begin
var LPanel := Panel;
Result := Assigned(LPanel) and LPanel.StatusBar;
end;
function TPanelForm.GetStatusText: string;
begin
var LPanel := Panel;
if Assigned(LPanel) then
Result := LPanel.StatusText
else
Result := '';
end;
function TPanelForm.GetToolMenu: TPopupMenu;
begin
Result := FToolMenu;
end;
class function TPanelForm.IsDisposable: Boolean;
begin
Result := False;
end;
function TPanelForm.IsVolatile: Boolean;
begin
Result := False;
end;
procedure TPanelForm.LoadFromFile(const AFileName: string);
begin
end;
procedure TPanelForm.LoadSettings;
begin
end;
procedure TPanelForm.MenuCmdExec(Sender: TObject; AID: Integer);
begin
CmdExec(AID);
end;
procedure TPanelForm.MenuGetState(Sender: TObject; AID: Integer;
var AVisible, AEnabled, AChecked: Boolean);
begin
CmdGetState(AID, AVisible, AEnabled, AChecked);
end;
function TPanelForm.Panel: TUxPanel;
begin
if Parent is TUxPanel then
Result := TUxPanel(Parent)
else
Result := nil;
end;
procedure TPanelForm.PanelEvent(AEventID: Integer);
begin
end;
procedure TPanelForm.PanelShortCut(var Msg: TWMKey; var Handled: Boolean);
begin
Handled := False;
end;
procedure TPanelForm.RequestClientSize(const ASize: TSize);
begin
RequestClientSize(ASize.Width, ASize.Height);
end;
procedure TPanelForm.RequestClientSize(AWidth, AHeight: Integer);
begin
if Parent is TUxPanel then
begin
if ShowToolBar and Assigned(FToolbar) then
TUxPanel(Parent).RequestClientSize(AWidth, AHeight + 6*ScaleValue(6))
else
TUxPanel(Parent).RequestClientSize(AWidth, AHeight);
end
else
begin
ClientWidth := AWidth;
ClientHeight := AHeight;
end
end;
procedure TPanelForm.RequireToolbar;
begin
if FToolbar = nil then
begin
FToolbar := TUxClient.Create(Self);
FToolbar.Parent := Self;
FToolbar.Align := alTop;
FToolbar.OnClick := FocusSender;
FToolbar.WindowedColor := True;
FToolbarTimer := TTimer.Create(Self);
FToolbarTimer.OnTimer := ToolbarTimerTimer;
UpdateToolbar;
end;
end;
procedure TPanelForm.Resize;
begin
inherited;
if Assigned(FToolbarTimer) then
begin
FToolbarDirty := True;
FToolbarTimer.Interval := 250;
FToolbarTimer.Enabled := False;
FToolbarTimer.Enabled := True;
end
else
UpdateToolbar;
end;
procedure TPanelForm.ScaleForPPI(NewPPI: Integer);
begin
inherited;
FontFix;
end;
procedure TPanelForm.ScreenCoordsChanged;
begin
if Assigned(TTextEditor.InstancesWithBalloons) then
for var LEditor in TTextEditor.InstancesWithBalloons do
if ControlHasAncestor(LEditor, Self) then
LEditor.MoveBalloonPostScroll;
end;
procedure TPanelForm.SetLeftStatusClick(const Value: Boolean);
begin
FLeftStatusClick := Value;
var LPanel := Panel;
if Assigned(LPanel) then
LPanel.LeftStatusClick := Value;
end;
procedure TPanelForm.SetParent(AParent: TWinControl);
begin
inherited;
if Assigned(AParent) and not (csDestroying in ComponentState) then
begin
SetStatusBar(FStatusBar);
SetStatusText(FStatusText);
SetLeftStatusClick(FLeftStatusClick);
SetRightStatusClick(FRightStatusClick);
SetToolMenu(FToolMenu);
FontFix;
UpdateToolbar;
end;
end;
procedure TPanelForm.SetRightStatusClick(const Value: Boolean);
begin
FRightStatusClick := Value;
var LPanel := Panel;
if Assigned(LPanel) then
LPanel.RightStatusClick := Value;
end;
procedure TPanelForm.SetShowToolbar(const Value: Boolean);
begin
RequireToolbar;
FToolbar.Visible := Value;
if Value then
UpdateToolbar;
end;
procedure TPanelForm.SetStatusBar(const Value: Boolean);
begin
FStatusBar := Value;
var LPanel := Panel;
if Assigned(LPanel) then
LPanel.StatusBar := Value;
end;
procedure TPanelForm.SetStatusText(const Value: string);
begin
FStatusText := Value;
var LPanel := Panel;
if Assigned(LPanel) then
LPanel.StatusText := Value;
end;
procedure TPanelForm.SetToolMenu(const Value: TPopupMenu);
begin
FToolMenu := Value;
var LPanel := Panel;
if Assigned(LPanel) then
LPanel.ToolMenu := Value;
end;
procedure TPanelForm.SetupToolbar;
begin
end;
procedure TPanelForm.SetupToolMenu;
begin
end;
function TPanelForm.SimpleMenu: TSimpleMenu;
begin
Result := FToolMenu as TSimpleMenu;
end;
procedure TPanelForm.ThemeUpdate;
begin
end;
procedure TPanelForm.ToolbarTimerTimer(Sender: TObject);
begin
FToolbarTimer.Interval := 1000;
if FToolbarDirty and Assigned(FToolBar) then
UpdateToolbar;
end;
procedure TPanelForm.UpdateToolbar;
begin
FToolbarDirty := True;
if Assigned(FToolbarTimer) then
begin
FToolbarTimer.Interval := 250;
FToolbarTimer.Enabled := True;
end;
if csDestroying in ComponentState then
Exit;
if Self = nil then
Exit;
if Parent = nil then
Exit;
if GetParentFormSafe(Parent) = nil then
Exit;
if FToolBar = nil then
Exit;
if FToolbar.Parent = nil then
Exit;
if not FToolBar.Visible then
Exit;
if FToolBarControls = nil then
Exit;
const P = ScaleValue(6);
var x := P;
FToolBar.Height := 6*P;
var LBtnWidth := 20;
if Length(FToolBarControls) > 5 then
begin
var LMaxChrCount := 0;
for var LCtl in FToolBarControls do
if (LCtl is TUxButton) and (Length(TUxButton(LCtl).Caption) > LMaxChrCount) then
LMaxChrCount := Length(TUxButton(LCtl).Caption);
if LMaxChrCount < 10 then
LBtnWidth := 12;
end;
var LEditWidth := 26;
var Q := P;
begin
var LEstimatedWidth := 0;
for var LCtl in FToolBarControls do
begin
if (LCtl is TLabel) and TLabel(LCtl).AutoSize then
Inc(LEstimatedWidth, LCtl.Width + P)
else if LCtl is TTextEditor then
Inc(LEstimatedWidth, LEditWidth*P + P)
else if LCtl is TUxButton then
begin
if Length(TUxButton(LCtl).Caption) = 1 then
Inc(LEstimatedWidth, FToolBar.ClientHeight - 2*P + P)
else
Inc(LEstimatedWidth, LBtnWidth*P + P);
end;
end;
if (LEstimatedWidth > FToolBar.ClientWidth) and (FToolBar.ClientWidth > 0) then
begin
const Factor = FToolbar.ClientWidth / LEstimatedWidth;
LBtnWidth := Max(3, Floor(Factor * LBtnWidth));
LEditWidth := Max(8, Floor(Factor * LEditWidth));
Q := Floor(Factor / LEstimatedWidth * Q);
end;
end;
for var LCtl in FToolBarControls do
begin
if (LCtl is TLabel) and TLabel(LCtl).AutoSize then
LCtl.Top := (FToolBar.ClientHeight - LCtl.Height) div 2
else
begin
LCtl.Top := P;
LCtl.Height := FToolBar.ClientHeight - 2*P;
end;
if LCtl is TTextEditor then
LCtl.Width := LEditWidth*P
else if LCtl is TUxButton then
begin
if Length(TUxButton(LCtl).Caption) = 1 then
LCtl.Width := LCtl.Height
else
LCtl.Width := LBtnWidth*P;
end;
if
(LCtl = FToolbarControls[High(FToolBarControls)])
and
not (akLeft in LCtl.Anchors)
and
(akRight in LCtl.Anchors)
then
begin
if LCtl is TLabel then
TLabel(LCtl).Alignment := taRightJustify;
LCtl.Left := FToolbar.ClientWidth - P - LCtl.Width;
end
else
begin
LCtl.Left := x;
Inc(x, LCtl.Width + Q);
end;
end;
FToolbarDirty := False;
FToolbarTimer.Enabled := False;
end;
procedure TUxColorForm.CmdExec(AID: Integer);
begin
case AID of
UCF_ADVPICK:
ShowAdvancedPicker(Self);
UCF_RESTORE:
RestoreDefaultColor(Self);
end;
end;
function TUxColorForm.ContextHelp: Boolean;
begin
TDocBrowser.ShowDocOrIndex('UI colour window', False);
Result := True;
end;
constructor TUxColorForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
FHueCtl := THueSelector.Create(Self);
FHueCtl.Parent := Self;
FHueCtl.Align := alTop;
FHueCtl.OnChange := HueChanged;
FHueCtl.Height := ScaleValue(32);
FSVCtl := TSVColorMap.Create(Self);
FSVCtl.Parent := Self;
FSVCtl.Align := alClient;
FSVCtl.OnChange := SatValChanged;
const LInitialColor = THSV(TUx.ThemeData.ActiveCaptionColor);
FHueCtl.Hue := LInitialColor.Hue;
FSVCtl.Hue := LInitialColor.Hue;
FSVCtl.Saturation := LInitialColor.Saturation;
FSVCtl.Value := LInitialColor.Value;
StatusBar := True;
UpdateStatusText;
Rux.TUx.RegisterCallback(Self, ThemeChanged);
end;
function TUxColorForm.CurrentColor: TColor;
begin
Result := THSV.Create(FHueCtl.Hue, FSVCtl.Saturation, FSVCtl.Value);
end;
procedure TUxColorForm.HueChanged(Sender: TObject);
begin
FSVCtl.Hue := FHueCtl.Hue;
TUx.ThemeUpdate(TUxTheme.Create(CurrentColor));
UpdateStatusText;
end;
class function TUxColorForm.IsDisposable: Boolean;
begin
Result := True;
end;
procedure TUxColorForm.RestoreDefaultColor(Sender: TObject);
begin
Rux.TUx.ThemeUpdate(TUxTheme.Create(GDefaultColor));
end;
procedure TUxColorForm.SatValChanged(Sender: TObject);
begin
TUx.ThemeUpdate(TUxTheme.Create(CurrentColor));
UpdateStatusText;
end;
procedure TUxColorForm.SetupToolMenu;
begin
inherited;
var LSVPopup := TPopupMenu.Create(Self);
var LmnuRestoreDefaultColor := TMenuItem.Create(LSVPopup);
LmnuRestoreDefaultColor.Caption := 'Restore default colour';
LmnuRestoreDefaultColor.Hint :=
Format('Restores the default GUI colour of %s.', [ColorToHex(GDefaultColor)]);
LmnuRestoreDefaultColor.OnClick := RestoreDefaultColor;
LSVPopup.Items.Add(LmnuRestoreDefaultColor);
var LmnuRCP := TMenuItem.Create(LSVPopup);
LmnuRCP.Caption := 'Advanced picker';
LmnuRCP.Hint := 'Displays the advanced colour picker.';
LmnuRCP.OnClick := ShowAdvancedPicker;
LSVPopup.Items.Add(LmnuRCP);
FSVCtl.PopupMenu := LSvPopup;
CreateToolMenu;
SimpleMenu.AddCommand(UCF_RESTORE, LmnuRestoreDefaultColor.Caption, LmnuRestoreDefaultColor.Hint);
SimpleMenu.AddCommand(UCF_ADVPICK, LmnuRCP.Caption, LmnuRCP.Hint);
end;
procedure TUxColorForm.ShowAdvancedPicker(Sender: TObject);
begin
var Dlg := TColorDialog.Create(nil);
try
Dlg.Color := TUx.ThemeData.ActiveCaptionColor;
if Dlg.Execute then
Rux.TUx.ThemeUpdate(TUxTheme.Create(Dlg.Color));
finally
Dlg.Free;
end;
end;
procedure TUxColorForm.ThemeChanged;
begin
const LNewColor = THSV(TUx.ThemeData.TintColor);
FHueCtl.Hue := LNewColor.Hue;
FSVCtl.Hue := LNewColor.Hue;
FSVCtl.Saturation := LNewColor.Saturation;
FSVCtl.Value := LNewColor.Value;
UpdateStatusText;
end;
procedure TUxColorForm.UpdateStatusText;
begin
StatusText :=
Format(
'Hue: %d Sat: %d%% Val: %d%%'#9'Hex: %s',
[
Round(FHueCtl.Hue),
Round(100*FSVCtl.Saturation),
Round(100*FSVCtl.Value),
ColorToHex(CurrentColor)
]
);
end;
procedure TTextEditorForm.ApplyFP;
const
Assocs:
array[0..8] of
record
Exts: TArray<string>;
FP: TFormattingProcessorClass
end
=
(
(Exts: ['xml', 'xsd', 'xsl', 'xslt', 'svg', 'rss', 'atom', 'xul', 'wml', 'kml']; FP: TXMLFormattingProcessor),
(Exts: ['xhtml', 'html', 'htm', 'asp', 'php']; FP: THTMLFormattingProcessor),
(Exts: ['css']; FP: TCSSFormattingProcessor),
(Exts: ['mw']; FP: TMediaWikiFormattingProcessor),
(Exts: ['pas', 'dpr', 'dfm']; FP: TPascalFormattingProcessor),
(Exts: ['prg']; FP: TAlgosim3FormattingProcessor),
(Exts: ['asml']; FP: TASRefFormattingProcessor),
(Exts: ['ini', 'inf', 'url', 'book', 'shelf', 'iss']; FP: TINIFormattingProcessor),
(Exts: nil; FP: nil)
);
begin
if FEditor = nil then
Exit;
const ext = ExtractFileExt(FEditor.TextFile.FileName).Trim(['.']);
for var LAssoc in Assocs do
if (IndexText(ext, LAssoc.Exts) <> -1) or (LAssoc.FP = nil) then
begin
var LPrevFP := FEditor.FormattingProcessor;
if Assigned(LPrevFP) then
begin
FEditor.FormattingProcessor := nil;
LPrevFP.Free;
end;
if Assigned(LAssoc.FP) then
FEditor.FormattingProcessor := LAssoc.FP.Create(Self);
Break;
end;
end;
procedure TTextEditorForm.BeginActive;
begin
inherited;
if Assigned(FEditor) then
FEditor.RuxAccent := True;
end;
function TTextEditorForm.CanClose: Boolean;
begin
Result := inherited;
if not Result then
Exit;
Result := Assigned(FEditor) and not FEditor.Printing and CheckModified;
end;
function TTextEditorForm.CheckModified: Boolean;
begin
Result := False;
try
if FEditor = nil then
Exit;
if FEditor.TextFile.FileModified then
begin
BeginHighlight;
try
case
TD
.TextFmt('Do you want to save the changes made to "%s"?', [ExtractFileName(FEditor.TextFile.FileName)])
.YesNoCancel
.Execute(Self)
of
mrYes:
Result := DoSave;
mrNo:
Result := True;
else
Result := False;
end;
finally
EndHighlight;
end;
end
else
Result := True;
finally
if not Result then
Abort;
end;
end;
function TextEditor_GetDriveAccess: string;
var
Path: array [0..MAX_PATH] of Char;
begin
SHGetFolderPath(0, CSIDL_APPDATA, 0, SHGFP_TYPE_CURRENT, @Path);
Result := Path + '\Rejbrand\Rejbrand Text Editor\Embedded\';
ForceDirectories(Result);
end;
function LineComparerStrLen(const A, B: string): integer;
begin
Result := CompareValue(A.Length, B.Length);
end;
function LineComparerIntegers(const A, B: string): integer;
var
Ai, Bi: Int64;
begin
Result := 0;
if TryStrToInt64(A, Ai) and TryStrToInt64(B, Bi) then
Result := CompareValue(Ai, Bi);
end;
function LineComparerReals(const A, B: string): integer;
var
Ar, Br: Double;
begin
Result := 0;
if TryNaturalStrToFloat(A, Ar) and TryNaturalStrToFloat(B, Br) then
Result := CompareValue(Ar, Br);
end;
procedure TTextEditorForm.CmdExec(AID: Integer);
const
LoremIpsum: array[0..3] of string =
(
'Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. ',
'Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. ',
'Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. ',
'Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. '
);
begin
if FEditor = nil then
Exit;
const LReadOnly = FEditor.EditMode = emReadOnly;
const LStrictReadOnly = LReadOnly and FEditor.TextFile.StrictReadOnly;
try
case AID of
TEF_NEW:
begin
if LStrictReadOnly then
Exit;
if not CheckModified then Exit;
FEditor.NewFile;
ApplyFP;
UpdateCaption;
end;
TEF_NEWWIN:
begin
var LNewForm := TUxForm.CreateNewForm(GetTextEditorClass) as TTextEditorForm;
LNewForm.UpdateCaption;
end;
TEF_OPEN:
begin
if LStrictReadOnly then
Exit;
if not CheckModified then Exit;
var Dlg := TFileOpenDialog.Create(nil);
try
Dlg.ClientGuid := GetClientGUID.ToString;
Dlg.Options := [fdoPathMustExist, fdoFileMustExist];
for var LFilter in GetFilters do
begin
var M := Dlg.FileTypes.Add;
M.DisplayName := LFilter.Key;
M.FileMask := LFilter.Value;
end;
if Dlg.Execute then
begin
var LBestGuessEncoding := TextEncodings.TTextEncoding.teASCII;
var LPossibleEncodings: TextEncodings.TTextEncodings := [];
var LMagicWords: TextEncodings.TTextEncodings := [];
if GuessEncodingOfFile(Dlg.FileName, LBestGuessEncoding, LPossibleEncodings, LMagicWords) then
FEditor.LoadFromFile(Dlg.FileName, GetVCLEncoding(LBestGuessEncoding))
else if teUTF8 in LPossibleEncodings then
FEditor.LoadFromFile(Dlg.FileName, GetVCLEncoding(teUTF8))
else
FEditor.LoadFromFile(Dlg.FileName, GetVCLEncoding(teWindows8bitCodepage));
ApplyFP;
UpdateCaption;
end;
finally
Dlg.Free;
end;
end;
TEF_RELOAD:
begin
if LStrictReadOnly then
Exit;
if not FileExists(FEditor.TextFile.FileName) then
Exit;
if
TD
.Text('Do you want to reload the file from the file system?')
.Text('The contents of the current editor buffer will be lost unless it is identical to the current data in the file system file. This operation cannot be undone.')
.Footer(FEditor.TextFile.FileName)
.AddButton('&Reload', mrYes)
.AddButton('&Cancel', mrCancel)
.Execute = mrYes
then
begin
var LNewFile := TTextFile.Create;
try
LNewFile.LoadFromFileAndInitUndo(FEditor.TextFile.FileName, FEditor.TextFile.Encoding.GetVCLEncoding);
except
LNewFile.Free;
raise;
end;
FEditor.TextFile := LNewFile;
ApplyFP;
UpdateCaption;
end;
end;
TEF_DUPBUF:
begin
var LNewForm := TUxForm.CreateNewForm(GetTextEditorClass) as TTextEditorForm;
LNewForm.FEditor.TextFile.PlainText := FEditor.PlainText;
LNewForm.FEditor.TextFile.GotoSOF;
LNewForm.FEditor.TextFile.ClearUndoHistory;
LNewForm.FEditor.TextFile.AddUndoRecord(SUndoNewFile, UID_UNKNOWN);
LNewForm.FEditor.TextFile.FileModified := False;
if FEditor.FormattingProcessor <> nil then
LNewForm.FEditor.FormattingProcessor := TFormattingProcessorClass(FEditor.FormattingProcessor.ClassType).Create(LNewForm);
LNewForm.UpdateCaption;
end;
TEF_DUPSEL:
begin
var LNewForm := TUxForm.CreateNewForm(GetTextEditorClass) as TTextEditorForm;
LNewForm.FEditor.TextFile.PlainText := FEditor.SelText;
LNewForm.FEditor.TextFile.GotoSOF;
LNewForm.FEditor.TextFile.ClearUndoHistory;
LNewForm.FEditor.TextFile.AddUndoRecord(SUndoNewFile, UID_UNKNOWN);
LNewForm.FEditor.TextFile.FileModified := False;
LNewForm.UpdateCaption;
end;
TEF_SAVE:
begin
if LStrictReadOnly then
Exit;
DoSave;
end;
TEF_SAVEAS:
begin
if LStrictReadOnly then
Exit;
DoSaveAs;
end;
TEF_EXPORT:
DoSaveAs(True);
TEF_IMPORT:
begin
if LReadOnly then
Exit;
var LDlg := TFileOpenDialog.Create(nil);
try
LDlg.Options := [fdoPathMustExist, fdoFileMustExist];
if LDlg.Execute then
begin
var LBestGuessEncoding := TextEncodings.TTextEncoding.teASCII;
var LPossibleEncodings: TextEncodings.TTextEncodings := [];
var LMagicWords: TextEncodings.TTextEncodings := [];
var LEnc: TEncoding;
if GuessEncodingOfFile(LDlg.FileName, LBestGuessEncoding, LPossibleEncodings, LMagicWords) then
LEnc := GetVCLEncoding(LBestGuessEncoding)
else if teUTF8 in LPossibleEncodings then
LEnc := GetVCLEncoding(teUTF8)
else
LEnc := GetVCLEncoding(teWindows8bitCodepage);
FEditor.SelText := TFile.ReadAllText(LDlg.FileName, LEnc);
end;
finally
LDlg.Free;
end;
end;
TEF_OPENFOLDER:
begin
if not FileExists(FEditor.TextFile.FileName) then
Exit;
var IIDL := ILCreateFromPath(PChar(FEditor.TextFile.FileName));
if IIDL <> nil then
try
if SHOpenFolderAndSelectItems(IIDL, 0, nil, 0) <> S_OK then
ShellExecute(Handle, nil, PChar(ExtractFilePath(FEditor.TextFile.FileName)),
nil, nil, SW_SHOWNORMAL);
finally
ILFree(IIDL);
end;
end;
TEF_COPYFILENAME:
Clipboard.AsText := FEditor.TextFile.FileName;
TEF_PRINT:
FEditor.PrintGUI(ExtractFileName(FEditor.TextFile.FileName));
TEF_TOXHTML:
begin
const LFileName = TextEditor_GetDriveAccess + 'export.html';
FEditor.ExportToHTML(LFileName);
var LNewForm := TUxForm.CreateNewForm<TTextEditorForm>;
LNewForm.FEditor.LoadFromFile(LFileName, TEncoding.UTF8);
LNewForm.ApplyFP;
LNewForm.UpdateCaption;
end;
TEF_RULER:
FEditor.RulerVisible := not FEditor.RulerVisible;
TEF_CBEYOND:
FEditor.CaretAfterEOL := not FEditor.CaretAfterEOL;
TEF_SHOWHIDDEN:
FEditor.ShowHiddenCharacters := not FEditor.ShowHiddenCharacters;
TEF_LINEHIGHL:
FEditor.LineHighlight := not FEditor.LineHighlight;
TEF_FONT:
begin
var LDlg := TFontDialog.Create(nil);
try
LDlg.Font.Assign(FEditor.Font);
LDlg.Options := [fdFixedPitchOnly, fdForceFontExist, fdApplyButton];
LDlg.OnApply := FontDialogApply;
if LDlg.Execute then
FEditor.Font.Assign(LDlg.Font);
finally
LDlg.Free;
end;
end;
TEF_CUSTZOOM:
begin
var z := FEditor.Zoom.ToString + '%';
if
TMultiInputBox.TextInputBoxEx(
Self,
'Zoom',
'Please enter a custom zoom level:',
z,
ecNormal,
function(const S: string): Boolean
begin
var T := S.Trim;
if T.EndsWith('%') then
SetLength(T, Pred(T.Length));
var v: Integer;
Result := TryStrToInt(T, v) and InRange(v, 10, 500);
end
)
then
FEditor.Zoom := StrToInt(z.Replace('%', '').Trim);
end;
TEF_AUTOREPLACE:
FEditor.AutoReplace := not FEditor.AutoReplace;
TEF_HISTORY:
FEditor.ShowHistory;
TEF_FILLCHAR:
begin
if LReadOnly then
Exit;
var v := 'A';
if
TMultiInputBox.CharInputBox(
Self,
'Fill with character',
'Please enter the character to fill the selection with:',
v
)
then
FEditor.FillWithChar(v);
end;
TEF_SORT:
begin
if LReadOnly then
Exit;
var LFrm := TSortFrm.Create(GetParentFormSafe(Self));
try
LFrm.cbComparer.ItemIndex := 0;
LFrm.rbSelection.Enabled := FEditor.TextFile.HasSelection;
if LFrm.rbSelection.Enabled then
LFrm.rbSelection.Checked := True
else
LFrm.rbEntireFile.Checked := True;
if LFrm.ShowModal = mrOk then
begin
case LFrm.cbComparer.ItemIndex of
0:
FEditor.LineComparer := AnsiCompareText;
1:
FEditor.LineComparer := AnsiCompareStr;
2:
FEditor.LineComparer := LineComparerStrLen;
3:
FEditor.LineComparer := LineComparerIntegers;
4:
FEditor.LineComparer := LineComparerReals;
else
FEditor.LineComparer := nil;
end;
FEditor.SortReverseOrder := LFrm.cbReverse.Checked;
BeginBusyWork;
try
if LFrm.rbSelection.Checked then
FEditor.SortSelection
else
FEditor.Sort;
finally
EndBusyWork;
end;
end;
finally
LFrm.Free;
end;
end;
TEF_MAKEUNIQUE:
begin
if LReadOnly then
Exit;
FEditor.MakeLinesUnique;
end;
TEF_TRUNCLINE:
begin
if LReadOnly then
Exit;
var LFrm := TTruncateFrm.Create(GetParentFormSafe(Self));
try
if FEditor.TextFile.HasSelection then
LFrm.rbSelection.Checked := True
else
LFrm.rbEntireFile.Checked := True;
if LFrm.ShowModal = mrOk then
begin
if LFrm.rbSelection.Checked then
begin
if LFrm.rbColumn.Checked then
FEditor.TruncateAtInSelection(
StrToInt(LFrm.eColumn.Text),
#0,
False,
LFrm.cbReverse.Checked
)
else if LFrm.rbSearch.Checked then
FEditor.TruncateAtInSelection(
IfThen(LFrm.cbDirection.ItemIndex = 1, -1, 1) * (LFrm.cbOrdinal.ItemIndex + 1),
LFrm.eChr.Text[1],
LFrm.cbOffset.ItemIndex <> 0,
LFrm.cbReverse.Checked
);
end
else if LFrm.rbEntireFile.Checked then
begin
if LFrm.rbColumn.Checked then
FEditor.TruncateAt(
StrToInt(LFrm.eColumn.Text),
#0,
False,
LFrm.cbReverse.Checked
)
else if LFrm.rbSearch.Checked then
FEditor.TruncateAt(
IfThen(LFrm.cbDirection.ItemIndex = 1, -1, 1) * (LFrm.cbOrdinal.ItemIndex + 1),
LFrm.eChr.Text[1],
LFrm.cbOffset.ItemIndex <> 0,
LFrm.cbReverse.Checked
);
end
end;
finally
LFrm.Free;
end;
end;
TEF_FILTERLINES:
begin
if LReadOnly then
Exit;
var LFrm := TFilterFrm.Create(GetParentFormSafe(Self));
try
if LFrm.ShowModal = mrOk then
FEditor.Filter(LFrm.eContains.Text, LFrm.eStarts.Text, LFrm.eEnds.Text,
LFrm.cbCaseSensitive.Checked, LFrm.rbRemove.Checked);
finally
LFrm.Free;
end;
end;
TEF_TRIMRIGHT:
begin
if LReadOnly then
Exit;
FEditor.TrimRight;
end;
TEF_FIND:
Find;
TEF_FINDNEXT:
FindNext;
TEF_FINDPREV:
FindPrev;
TEF_FINDSYMB:
FindSymbol;
TEF_FINDCHR:
begin
var LFrm := TChrSearchFrm.Create(GetParentFormSafe(Self));
try
if LFrm.ShowModal = mrOk then
if LFrm.rbNonASCII.Checked then
FEditor.Find(MakeFindQuery(FQ_NONASCII))
else if LFrm.rbControl.Checked then
FEditor.Find(MakeFindQuery(FQ_CONTROL))
else if LFrm.rbNonchars.Checked then
FEditor.Find(MakeFindQuery(FQ_NONCHAR))
else if LFrm.rbBlock.Checked then
FEditor.Find(MakeFindQuery(LFrm.lbBlocks.ItemIndex + 1));
finally
LFrm.Free;
end;
end;
TEF_REPLACE:
begin
if LReadOnly then
Exit;
if FReplaceFrm = nil then
FReplaceFrm := TReplaceFrm.Create(Self);
FReplaceFrm.Editor := FEditor;
FReplaceFrm.rbSelection.Enabled := FEditor.TextFile.HasSelection;
if FReplaceFrm.rbSelection.Enabled then
FReplaceFrm.rbSelection.Checked := True
else
FReplaceFrm.rbEntireFile.Checked := True;
FReplaceFrm.Position := poDesigned;
if not FReplaceFrm.Visible then
begin
var P := ClientToScreen(ClientRect.BottomRight);
FReplaceFrm.SetBounds(
P.X - FReplaceFrm.Width - ScaleValue(12),
P.Y - FReplaceFrm.Height - ScaleValue(12),
FReplaceFrm.Width,
FReplaceFrm.Height
)
end;
FReplaceFrm.Visible := True;
FReplaceFrm.ScaleForCurrentDPI;
if FReplaceFrm.eSearch.CanFocus then
FReplaceFrm.eSearch.SetFocus;
end;
TEF_GOTO:
begin
var y := FEditor.CaretPos.Y + 1;
if
TMultiInputBox.NumInputBox(
Self,
'Go to',
'Please enter a line number to go to:',
y,
1,
FEditor.LineCount
)
then
FEditor.CaretPos := Point(0, y - 1);
end;
TEF_DATETIME:
begin
if LReadOnly then
Exit;
FEditor.EditorCommand(EDITOR_COMMAND_WRITE_DATETIME);
end;
TEF_CDATETIME:
begin
if LReadOnly then
Exit;
var LFrm := TTimeFrm.Create(GetParentFormSafe(Self));
try
if (LFrm.ShowModal = mrOk) and (LFrm.lbFormats.ItemIndex <> -1) then
FEditor.SelText := LFrm.lbFormats.Items[LFrm.lbFormats.ItemIndex];
finally
LFrm.Free;
end;
end;
TEF_LOREM:
begin
if LReadOnly then
Exit;
var N := 4;
var S := '';
if TMultiInputBox.NumInputBox(Self, 'Lorem Ipsum', 'Please enter the number of sentences to insert:', N, 1, 1024) then
begin
for var i := 0 to N - 1 do
S := S + LoremIpsum[i mod 4];
FEditor.SelText := S;
end;
end;
TEF_INSCOLOR:
begin
if LReadOnly then
Exit;
var LDlg := ColorDialog.TColorDialog.Create(GetParentFormSafe(Self));
try
if (FEditor.SelLength = 7) and (FEditor.SelText[1] = '#') then
LDlg.ColorAsHex := FEditor.SelText;
if LDlg.Execute then
FEditor.SelText := LDlg.ColorAsHex;
finally
LDlg.Free;
end;
end;
TEF_DOC:
begin
end;
TEF_ARL:
begin
var LNewForm := TUxForm.CreateNewForm<TTextEditorForm>;
LNewForm.FEditor.LoadDefaultClasses;
LNewForm.FEditor.MultiSize := True;
var TF := LNewForm.FEditor.TextFile;
TF.InsertLine('Auto-replace codes', 'Heading 2', 0);
TF.BeginAddLine;
try
for var i := 0 to TF.AutoReplaceItemCount - 1 do
with TF.AutoReplaceItems[i] do
TF.AddLine(Token + ': ' + ReplacedValue);
finally
TF.EndAddLine;
end;
TF.EditMode := emReadOnly;
TF.StrictReadOnly := True;
TF.UseLineClasses := True;
TF.FileModified := False;
TF.FileName := 'Auto-replace codes';
TF.GotoSOF;
LNewForm.FEditor.MakeUndoRoot;
LNewForm.UpdateCaption;
end;
TEF_STATS:
begin
var LFrm := TStatisticsFrm.Create(GetParentFormSafe(Self));
try
LFrm.Editor := FEditor;
LFrm.ShowModal;
finally
LFrm.Free;
end;
end;
SYN_LOW .. SYN_HIGH:
begin
if not (FEditor.FormattingProcessor is FPs[AID]) then
begin
var LOldFP := FEditor.FormattingProcessor;
if Assigned(LOldFP) then
begin
FEditor.FormattingProcessor := nil;
LOldFP.Free;
end;
if AID <> SYN_NONE then
FEditor.FormattingProcessor := FPs[AID].Create(Self);
end;
end;
else
inherited;
end;
except
UpdateCaption;
raise;
end;
end;
procedure TTextEditorForm.CmdGetState(AID: Integer; var AVisible, AEnabled, AChecked: Boolean);
begin
if FEditor = nil then
Exit;
const LReadOnly = FEditor.EditMode = emReadOnly;
const LStrictReadOnly = LReadOnly and FEditor.TextFile.StrictReadOnly;
case AID of
TEF_NEW, TEF_OPEN, TEF_SAVE, TEF_SAVEAS, TEF_HISTORY:
AVisible := not LStrictReadOnly;
TEF_RELOAD:
AEnabled := not LStrictReadOnly and FileExists(FEditor.TextFile.FileName);
TEF_DUPSEL:
AEnabled := FEditor.TextFile.HasSelection;
TEF_OPENFOLDER:
AEnabled := FileExists(FEditor.TextFile.FileName);
TEF_COPYFILENAME:
AEnabled := FileExists(FEditor.TextFile.FileName);
TEF_RULER:
AChecked := FEditor.RulerVisible;
TEF_CBEYOND:
AChecked := FEditor.CaretAfterEOL;
TEF_SHOWHIDDEN:
AChecked := FEditor.ShowHiddenCharacters;
TEF_LINEHIGHL:
AChecked := FEditor.LineHighlight;
TEF_AUTOREPLACE:
AChecked := FEditor.AutoReplace;
TEF_FILLCHAR:
AEnabled := FEditor.TextFile.HasSelection;
TEF_SORT, TEF_MAKEUNIQUE:
AEnabled := FEditor.LineCount > 1;
TEF_FINDNEXT, TEF_FINDPREV:
AEnabled := FEditor.TextFile.FindCount > 0;
TEF_FINDSYMB:
AEnabled := FEditor.TextFile.HasSelection or not FEditor.GetWord.IsEmpty;
SYN_NONE:
AChecked := FEditor.FormattingProcessor = nil;
Succ(SYN_NONE) .. SYN_HIGH:
AChecked := FEditor.FormattingProcessor is FPs[AID];
else
inherited;
end;
if LReadOnly and (IndexInt(AID, EditingCommands) <> -1) then
if LStrictReadOnly then
AVisible := False
else
AEnabled := False;
end;
constructor TTextEditorForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
FEditor := GetEditorSubclass.Create(Self);
FEditor.Parent := Self;
FEditor.Align := alClient;
FEditor.BorderType := btNone;
FEditor.OnSelChange := EditorSelChange;
FEditor.OnZoomChange := EditorZoomChange;
FEditor.OnChange := EditorChanged;
FEditor.OnModified := EditorModified;
FEditor.OnSimpleNotification := EditorSimpleNotification;
FEditor.OnPrintBegin := EditorPrintBegin;
FEditor.OnPrintProgress := EditorPrintProgress;
FEditor.OnPrintEnd := EditorPrintEnd;
FEditor.UseRuxThemes := True;
FEditor.AutoReplace := True;
FEditor.CaretAfterEOL := False;
FEditor.ErrorMessageOnReadOnlyError := False;
SetupFileNaming;
FEditor.NewFile;
FEditor.RulerDefaultFont := True;
FEditor.RulerLineStep := 5;
UpdateCaption;
StatusBar := True;
ShowToolBar := False;
LeftStatusClick := True;
RightStatusClick := True;
end;
procedure TTextEditorForm.DoInstantSearch(Sender: TObject);
begin
if FEditor = nil then
Exit;
if eFindText = nil then
Exit;
if btnMatchCase = nil then
Exit;
if btnWholeWords = nil then
Exit;
if btnCRLF = nil then
Exit;
if Sender is TUxButton then
TUxButton(Sender).Down := not TUxButton(Sender).Down;
const S = eFindText.PlainText;
var FQ := MakeFindQuery(S, btnMatchCase.Down,
btnWholeWords.Down, btnCRLF.Down);
const n = FEditor.Find(FQ);
if Assigned(lblCount) then
begin
lblCount.Visible := S.Length > 0;
if lblCount.Visible then
begin
lblCount.Caption := PrettyFormat('%d match(es)', [n]);
if Assigned(lblCount.Parent) then
lblCount.Top := (lblCount.Parent.ClientHeight - lblCount.Height) div 2;
end;
end;
end;
function TTextEditorForm.DoSave: Boolean;
begin
Result := False;
if FEditor = nil then
Exit;
if FileExists(FEditor.TextFile.FileName) then
begin
FEditor.SaveToFile(FEditor.TextFile.FileName);
Result := True;
UpdateCaption;
end
else
Result := DoSaveAs;
end;
function TTextEditorForm.DoSaveAs(AExport: Boolean): Boolean;
function SanitizeFileName(const AFileName: string): string;
begin
SetLength(Result, AFileName.Length);
var j := 0;
for var i := 1 to AFileName.Length do
if not (CharInSet(AFileName[i], ['<', '>', ':', '"', '/', '\', '|', '?', '*']) or (AFileName[i] < ' ')) then
begin
Inc(j);
Result[j] := AFileName[i];
end;
SetLength(Result, j);
end;
function TrimPunctuation(const AText: string): string;
begin
var s := 1;
var e := AText.Length;
while (s <= AText.Length) and not AText[s].IsLetterOrDigit do
Inc(s);
while (e >= 1) and not AText[e].IsLetterOrDigit do
Dec(e);
Result := Copy(AText, s, e - s + 1);
end;
function GetInitialFileName(const ATextFile: TTextFile): string;
begin
Result := '';
if not Assigned(ATextFile) then
Exit;
if ATextFile.LineCount = 0 then
Exit;
for var y := 0 to Min(ATextFile.LineCount - 1, 100) do
begin
Result := Copy(ATextFile.Lines[y], 1, 80);
Result := SanitizeFileName(TrimPunctuation(Result));
if not Result.IsEmpty then
Break;
end;
if not Result.IsEmpty then
Result := Result + '.txt';
end;
function GetTrimRight(const AFileName: TFileName): Boolean;
begin
Result :=
IndexText
(
ExtractFileExt(AFileName),
[
'.pas', '.dpr', '.xml', '.css', '.xslt', '.xsd',
'.svg', '.kml', '.htm', '.html', '.xhtml', '.asp',
'.php', '.prg'
]
) <> -1;
end;
begin
Result := False;
if FEditor = nil then
Exit(False);
var LDlg := TFileSaveDialog.Create(nil);
try
LDlg.ClientGuid := GetClientGUID.ToString;
LDlg.Options := [fdoOverWritePrompt, fdoPathMustExist];
var LDir := ExtractFileDir(FEditor.TextFile.FileName);
if DirectoryExists(LDir) then
LDlg.DefaultFolder := LDir;
var LName := ExtractFileName(FEditor.TextFile.FileName);
if (LName = '') or LName.StartsWith('New file', True) then
LDlg.FileName := GetInitialFileName(FEditor.TextFile)
else
LDlg.FileName := LName;
var LDefExt := '';
SetupFileMasks(LDlg.FileTypes, LDefExt);
if not LDefExt.IsEmpty then
LDlg.DefaultExtension := LDefExt;
begin
var LMask := LDlg.FileTypes.Add;
LMask.DisplayName := 'All files';
LMask.FileMask := '*.*';
end;
LDlg.OnExecute := SaveAsDialogExecute;
LDlg.OnFileOkClick := SaveAsDialogOnOKClick;
if LDlg.Execute then
begin
FEditor.SaveToFile(LDlg.FileName, GetTrimRight(LDlg.FileName), AExport);
Result := True;
UpdateCaption;
end;
finally
LDlg.Free;
end;
end;
procedure TTextEditorForm.EditorAbortPrint(Sender: TObject);
begin
FDoAbortPrint := True;
if
Assigned(FPrintProgressForm)
and
(FPrintProgressForm.ControlCount = 1)
and
(FPrintProgressForm.Controls[0] is TUxButton)
then
TUxButton(FPrintProgressForm.Controls[0]).Enabled := False;
end;
procedure TTextEditorForm.EditorChanged(Sender: TObject);
begin
end;
procedure TTextEditorForm.EditorModified(Sender: TObject);
begin
if Assigned(FEditor) then
UpdateCaption;
end;
procedure TTextEditorForm.EditorPrintBegin(Sender: TObject; NumSteps: Integer);
begin
if SimpleMenu <> nil then
SimpleMenu.Enabled := False;
FDoAbortPrint := False;
if FPrintProgressForm = nil then
begin
FPrintProgressForm := TUxClient.Create(Self);
FPrintProgressForm.Parent := Self;
FPrintProgressForm.Align := alClient;
FPrintProgressForm.Caption := 'Printing...';
FPrintProgressForm.OnResize := EditorPrintProgressFormResize;
FPrintProgressForm.OnClick := FocusSender;
var LPrintAbortButton := TUxButton.Create(FPrintProgressForm);
LPrintAbortButton.Parent := FPrintProgressForm;
LPrintAbortButton.Caption := 'Abort';
LPrintAbortButton.OnClick := EditorAbortPrint;
LPrintAbortButton.Left := ScaleValue(24);
LPrintAbortButton.Top := FPrintProgressForm.ClientHeight div 2 + ScaleValue(24);
LPrintAbortButton.Width := ScaleValue(96);
LPrintAbortButton.Height := ScaleValue(24);
end;
FPrintProgressForm.BringToFront;
end;
procedure TTextEditorForm.EditorPrintEnd(Sender: TObject);
begin
if SimpleMenu <> nil then
SimpleMenu.Enabled := True;
FreeAndNil(FPrintProgressForm);
end;
function TTextEditorForm.EditorPrintProgress(Sender: TObject; CurStep,
NumSteps: Integer): Boolean;
begin
Result := not FDoAbortPrint;
if Assigned(FPrintProgressForm) then
begin
if FDoAbortPrint then
FPrintProgressForm.Caption := 'Aborting...'
else if NumSteps > 0 then
FPrintProgressForm.Caption := Format('Printing... %d%%', [Round(100 * CurStep / NumSteps)])
else
FPrintProgressForm.Caption := 'Printing...'
end;
end;
procedure TTextEditorForm.EditorPrintProgressFormResize(Sender: TObject);
begin
if
Assigned(FPrintProgressForm)
and
(FPrintProgressForm.ControlCount = 1)
and
(FPrintProgressForm.Controls[0] is TUxButton)
then
TUxButton(FPrintProgressForm.Controls[0]).Top := FPrintProgressForm.ClientHeight div 2 + ScaleValue(24);
end;
procedure TTextEditorForm.EditorSelChange(Sender: TObject);
begin
UpdateStatusBar;
end;
procedure TTextEditorForm.EditorSimpleNotification(Sender: TObject;
MsgID: Cardinal; const AMsg: string);
begin
if MsgID = TextEditor.TTextEditor.EN_READONLY then
FEditorNotificationText := ''
else
FEditorNotificationText := AMsg;
UpdateStatusBar;
end;
procedure TTextEditorForm.EditorZoomChange(Sender: TObject);
begin
UpdateStatusBar;
end;
procedure TTextEditorForm.EndActive;
begin
inherited;
if Assigned(FEditor) then
FEditor.RuxAccent := False;
end;
procedure TTextEditorForm.Find(const AText: string);
begin
ShowToolBar := True;
if Assigned(eFindText) and AText.IsEmpty and eFindText.CanFocus then
begin
eFindText.SetFocus;
eFindText.SelectAll;
end;
if Assigned(eFindText) and not AText.IsEmpty then
eFindText.PlainText := AText;
end;
procedure TTextEditorForm.FindNext(Sender: TObject);
begin
if Assigned(FEditor) then
FEditor.FindNext;
end;
procedure TTextEditorForm.FindPrev(Sender: TObject);
begin
if Assigned(FEditor) then
FEditor.FindPrevious;
end;
procedure TTextEditorForm.FindSymbol;
begin
if FEditor.TextFile.HasSelection then
Find(FEditor.SelText)
else
Find(FEditor.TextFile.GetWord(GetKeyState(VK_SHIFT) < 0))
end;
procedure TTextEditorForm.FindTextChange(Sender: TObject);
begin
DoInstantSearch;
end;
procedure TTextEditorForm.FindTextKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_RETURN:
begin
DoInstantSearch;
if (GetKeyState(VK_SHIFT) shr 16) <> 0 then
FindPrev
else
FindNext;
Key := 0;
end;
VK_ESCAPE:
begin
ShowToolBar := False;
Key := 0;
if Assigned(FEditor) and FEditor.CanFocus then
FEditor.SetFocus;
end;
end;
end;
procedure TTextEditorForm.FirstShow;
begin
RequestClientSize(800, 600);
end;
procedure TTextEditorForm.FontDialogApply(Sender: TObject; Wnd: HWND);
begin
if Sender is TFontDialog then
FEditor.Font.Assign(TFontDialog(Sender).Font);
end;
function TTextEditorForm.GetClientGUID: TGUID;
const
LGUID: TGUID = '{F9410364-FE02-4BA0-A06D-F9C081EF8238}';
begin
Result := LGUID;
end;
function TTextEditorForm.GetEditorSubclass: TTextEditorClass;
begin
Result := TTextEditor;
end;
function TTextEditorForm.GetFilters: TArray<TPair<string, string>>;
begin
Result := [TPair<string, string>.Create('All files', '*.*')];
end;
function TTextEditorForm.IsVolatile: Boolean;
begin
Result := Assigned(FEditor) and not FEditor.TextFile.FileModified;
end;
procedure TTextEditorForm.LoadFromFile(const AFileName: string);
begin
inherited;
if not CheckModified then Exit;
var LBestGuessEncoding := TextEncodings.TTextEncoding.teASCII;
var LPossibleEncodings: TextEncodings.TTextEncodings := [];
var LMagicWords: TextEncodings.TTextEncodings := [];
if GuessEncodingOfFile(AFileName, LBestGuessEncoding, LPossibleEncodings, LMagicWords) then
FEditor.LoadFromFile(AFileName, GetVCLEncoding(LBestGuessEncoding))
else if teUTF8 in LPossibleEncodings then
FEditor.LoadFromFile(AFileName, GetVCLEncoding(teUTF8))
else
FEditor.LoadFromFile(AFileName, GetVCLEncoding(teWindows8bitCodepage));
ApplyFP;
UpdateCaption;
end;
procedure TTextEditorForm.PanelEvent(AEventID: Integer);
begin
case AEventID of
TUxPanel.ITEM_STATUSLEFT:
CmdExec(TEF_GOTO);
TUxPanel.ITEM_STATUSRIGHT:
CmdExec(TEF_CUSTZOOM);
end;
end;
procedure TTextEditorForm.PanelShortCut(var Msg: TWMKey; var Handled: Boolean);
begin
if GetKeyState(VK_MENU) < 0 then
begin
inherited;
Exit;
end;
case Msg.CharCode of
VK_F2:
begin
FindPrev;
Handled := True;
end;
VK_F3:
begin
if GetKeyState(VK_SHIFT) < 0 then
FindPrev
else
FindNext;
Handled := True;
end;
Ord('F'):
begin
if (GetKeyState(VK_CONTROL) < 0) and (GetKeyState(VK_SHIFT) >= 0) then
begin
Find;
Handled := True;
end;
end;
Ord('E'):
begin
if (GetKeyState(VK_CONTROL) < 0) and (GetKeyState(VK_SHIFT) >= 0) then
begin
FindSymbol;
Handled := True;
end;
end;
Ord('R'):
begin
if (GetKeyState(VK_CONTROL) < 0) and (GetKeyState(VK_SHIFT) >= 0) then
begin
MenuCmdExec(Self, TEF_REPLACE);
Handled := True;
end;
end;
Ord('G'):
begin
if (GetKeyState(VK_CONTROL) < 0) and (GetKeyState(VK_SHIFT) >= 0) then
begin
MenuCmdExec(Self, TEF_GOTO);
Handled := True;
end;
end;
Ord('S'):
begin
if (GetKeyState(VK_CONTROL) < 0) and (GetKeyState(VK_SHIFT) >= 0) then
begin
MenuCmdExec(Self, TEF_SAVE);
Handled := True;
end;
end;
Ord('P'):
begin
if GetKeyState(VK_CONTROL) < 0 then
begin
MenuCmdExec(Self, TEF_PRINT);
Handled := True;
end;
end;
end;
if not Handled then
inherited;
end;
const
CTL_ENCODING = 10;
CTL_CB_ENCODING = 100;
CTL_CB_ENCODING_UTF8 = 101;
CTL_CB_ENCODING_UTF16LE = 102;
CTL_CB_ENCODING_UTF16BE = 103;
CTL_CB_ENCODING_UTF32LE = 104;
CTL_CB_ENCODING_UTF32BE = 105;
CTL_CB_ENCODING_ASCII = 106;
CTL_CB_ENCODING_ANSI = 107;
CTL_LINEBREAK = 20;
CTL_CB_BOM = 200;
CTL_CB_LINEBREAK = 300;
CTL_CB_LINEBREAK_CRLF = 301;
CTL_CB_LINEBREAK_LF = 302;
procedure TTextEditorForm.SaveAsDialogExecute(Sender: TObject);
var
FDC: IFileDialogCustomize;
begin
if
Assigned(FEditor)
and
(Sender is TFileSaveDialog)
and
(TFileSaveDialog(Sender).Dialog.QueryInterface(IID_IFileDialogCustomize, FDC) = S_OK)
then
begin
FDC.StartVisualGroup(CTL_ENCODING, 'Encoding:');
if FDC.AddComboBox(CTL_CB_ENCODING) = S_OK then
begin
FDC.AddControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF8, 'UTF-8');
FDC.AddControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF16LE, 'UTF-16 LE');
FDC.AddControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF16BE, 'UTF-16 BE');
FDC.AddControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF32LE, 'UTF-32 LE');
FDC.AddControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF32BE, 'UTF-32 BE');
FDC.AddControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_ASCII, 'ASCII');
FDC.AddControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_ANSI, '8-bit extended ASCII');
case FEditor.TextFile.Encoding.TextEncoding of
teASCII:
FDC.SetSelectedControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_ASCII);
teWindows8bitCodepage:
FDC.SetSelectedControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_ANSI);
teUTF8:
FDC.SetSelectedControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF8);
teUTF16LE:
FDC.SetSelectedControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF16LE);
teUTF16BE:
FDC.SetSelectedControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF16BE);
teUTF32LE:
FDC.SetSelectedControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF32LE);
teUTF32BE:
FDC.SetSelectedControlItem(CTL_CB_ENCODING, CTL_CB_ENCODING_UTF32BE);
end;
end;
FDC.AddCheckButton(CTL_CB_BOM, 'Byte-order mark', FEditor.TextFile.Encoding.MagicWord);
FDC.EndVisualGroup;
FDC.StartVisualGroup(CTL_LINEBREAK, 'Line-break style:');
if FDC.AddComboBox(CTL_CB_LINEBREAK) = S_OK then
begin
FDC.AddControlItem(CTL_CB_LINEBREAK, CTL_CB_LINEBREAK_CRLF, 'CR+LF');
FDC.AddControlItem(CTL_CB_LINEBREAK, CTL_CB_LINEBREAK_LF, 'LF only');
case FEditor.TextFile.Encoding.LineBreakType of
lbtCRLF:
FDC.SetSelectedControlItem(CTL_CB_LINEBREAK, CTL_CB_LINEBREAK_CRLF);
lbtLF:
FDC.SetSelectedControlItem(CTL_CB_LINEBREAK, CTL_CB_LINEBREAK_LF);
end;
end;
FDC.EndVisualGroup;
end;
end;
procedure TTextEditorForm.SaveAsDialogOnOKClick(Sender: TObject;
var CanClise: Boolean);
var
FDC: IFileDialogCustomize;
ItemID: Cardinal;
IsChecked: LongBool;
begin
if
Assigned(FEditor)
and
(Sender is TFileSaveDialog)
and
(TFileSaveDialog(Sender).Dialog.QueryInterface(IID_IFileDialogCustomize, FDC) = S_OK)
then
begin
if FDC.GetSelectedControlItem(CTL_CB_ENCODING, ItemID) = S_OK then
begin
case ItemID of
CTL_CB_ENCODING_UTF8:
FEditor.TextFile.Encoding.SetEncoding(teUTF8);
CTL_CB_ENCODING_UTF16LE:
FEditor.TextFile.Encoding.SetEncoding(teUTF16LE);
CTL_CB_ENCODING_UTF16BE:
FEditor.TextFile.Encoding.SetEncoding(teUTF16BE);
CTL_CB_ENCODING_UTF32LE:
FEditor.TextFile.Encoding.SetEncoding(teUTF32LE);
CTL_CB_ENCODING_UTF32BE:
FEditor.TextFile.Encoding.SetEncoding(teUTF32BE);
CTL_CB_ENCODING_ASCII:
FEditor.TextFile.Encoding.SetEncoding(teASCII);
CTL_CB_ENCODING_ANSI:
FEditor.TextFile.Encoding.SetEncoding(teWindows8bitCodepage);
end;
end;
if FDC.GetCheckButtonState(CTL_CB_BOM, IsChecked) = S_OK then
FEditor.TextFile.Encoding.SetMagicWord(IsChecked);
if FDC.GetSelectedControlItem(CTL_CB_LINEBREAK, ItemID) = S_OK then
begin
case ItemID of
CTL_CB_LINEBREAK_CRLF:
FEditor.TextFile.Encoding.SetLineBreakType(lbtCRLF);
CTL_CB_LINEBREAK_LF:
FEditor.TextFile.Encoding.SetLineBreakType(lbtLF);
end;
end;
end;
end;
procedure TTextEditorForm.SetupFileMasks(AItems: TFileTypeItems; var ADefExtSansPeriod: string);
begin
var LItem := AItems.Add;
LItem.DisplayName := 'Text files';
LItem.FileMask := '*.txt';
inherited;
ADefExtSansPeriod := 'txt';
end;
procedure TTextEditorForm.SetupFileNaming;
begin
end;
procedure TTextEditorForm.SetupToolbar;
begin
inherited;
eFindText := AddToolbarControl<TTextEditor>(GetEditorSubclass);
eFindText.TextHint := 'Search the text';
eFindText.SingleLine := True;
eFindText.OnChange := FindTextChange;
eFindText.OnKeyDown := FindTextKeyDown;
btnPrev := AddToolbarControl<TUxButton>;
btnPrev.Caption := '▲';
btnPrev.Hint := 'Moves to the previous match in the buffer.';
btnPrev.OnClick := FindPrev;
btnNext := AddToolbarControl<TUxButton>;
btnNext.Caption := '▼';
btnNext.Hint := 'Moves to the next match in the buffer.';
btnNext.OnClick := FindNext;
btnMatchCase := AddToolbarControl<TUxButton>;
btnMatchCase.Caption := 'Match &case';
btnMatchCase.Hint := 'Select to distinguish between CAPITAL and small letters.';
btnMatchCase.OnClick := DoInstantSearch;
btnMatchCase.ShorterCaptions := ['&Case', '&Cc'];
btnWholeWords := AddToolbarControl<TUxButton>;
btnWholeWords.Caption := '&Whole words';
btnWholeWords.Hint := 'Select to only match phrases that are whole words (surrounded by SOL, whitespace, punctuation, or EOL.';
btnWholeWords.OnClick := DoInstantSearch;
btnWholeWords.ShorterCaptions := ['&Words', '&W'];
btnCRLF := AddToolbarControl<TUxButton>;
btnCRLF.Caption := '"\&n" as CRLF';
btnCRLF.Hint := 'Select to interpret "\n" (without quotes) as a linebreak.';
btnCRLF.OnClick := DoInstantSearch;
btnCRLF.ShorterCaptions := ['\&n'];
lblCount := AddToolbarControl<TUxLabel>;
lblCount.Caption := '';
lblCount.Hint := 'Displays the number of matches in the buffer.';
lblCount.OnClick := FocusSender;
end;
procedure TTextEditorForm.SetupToolMenu;
begin
inherited;
CreateToolMenu;
FMnuFile := SimpleMenu.AddSubmenu('File', 'Contains commands used to manage the current buffer.');
SimpleMenu.AddCommand(TEF_NEW, FMnuFile, 'New file', 'Creates a new text file in this panel.');
SimpleMenu.AddCommand(TEF_NEWWIN, FMnuFile, 'New window', 'Creates a new text file in a new editor window.');
SimpleMenu.AddCommand(TEF_OPEN, FmnuFile, 'Open...', 'Loads a file and displays it in this panel.');
SimpleMenu.AddCommand(TEF_RELOAD, FmnuFile, 'Reload', 'Reloads the file from the file system.');
SimpleMenu.AddCommand(0, FmnuFile, '-', '');
SimpleMenu.AddCommand(TEF_HISTORY, FmnuFile, 'History', 'Displays the edit history of this text file buffer.');
SimpleMenu.AddCommand(TEF_DUPBUF, FmnuFile, 'Duplicate buffer', 'Creates a new editor with a copy of this editor''s buffer.');
SimpleMenu.AddCommand(TEF_DUPSEL, FmnuFile, 'New buffer from selection', 'Creates a new editor with a buffer initially populated by the current editor''s selected text.');
SimpleMenu.AddCommand(0, FmnuFile, '-', '');
SimpleMenu.AddCommand(TEF_SAVE, FmnuFile, 'Save'#9'Ctrl+S', 'Saves any changes made to this file (or asks for a file name if the buffer does not correspond to a physical file yet).');
SimpleMenu.AddCommand(TEF_SAVEAS, FmnuFile, 'Save as...', 'Asks for a file name and saves the text buffer to that file.');
SimpleMenu.AddCommand(TEF_EXPORT, FmnuFile, 'Export...', 'Asks for a file name and saves the text buffer to that file, without changing the buffer''s file name or status.');
SimpleMenu.AddCommand(0, FmnuFile, '-', '');
SimpleMenu.AddCommand(TEF_OPENFOLDER, FmnuFile, 'Open folder', 'Opens the folder containing this file.');
SimpleMenu.AddCommand(TEF_COPYFILENAME, FmnuFile, 'Copy file name', 'Copies the buffer''s file name to clipboard.');
SimpleMenu.AddCommand(0, FmnuFile, '-', '');
SimpleMenu.AddCommand(TEF_PRINT, FmnuFile, 'Print...'#9'Ctrl+P', 'Sends this text buffer to a printer.');
SimpleMenu.AddCommand(TEF_TOXHTML, FmnuFile, 'Export to HTML', 'Creates an HTML document containing this buffer along with its formatting due to syntax highlighting or line classes.');
FMnuEdit := SimpleMenu.AddSubmenu('Edit', 'Contains commands used to edit the buffer.');
SimpleMenu.AddCommand(TEF_FILLCHAR, FmnuEdit, 'Fill with character...', 'Replaces every character in the selection with a given character.');
SimpleMenu.AddCommand(0, FmnuEdit, '-', '');
SimpleMenu.AddCommand(TEF_SORT, FmnuEdit, 'Sort lines...', 'Let''s you sort the lines of the buffer or selection.');
SimpleMenu.AddCommand(TEF_MAKEUNIQUE, FmnuEdit, 'Make lines unique', 'Removes all duplicate lines in the buffer from top to bottom.');
SimpleMenu.AddCommand(TEF_TRUNCLINE, FmnuEdit, 'Truncate lines...', 'Lets you truncate the lines of the buffer or selection according to some rule.');
SimpleMenu.AddCommand(TEF_FILTERLINES, FmnuEdit, 'Filter lines...', 'Lets you selectively keep or remove the lines of the buffer according to some rule.');
SimpleMenu.AddCommand(TEF_TRIMRIGHT, FmnuEdit, 'Trim right', 'Removes trailing whitespace from every line in the buffer.');
FMnuFind := SimpleMenu.AddSubmenu('Find', 'Contains commands used to search the buffer.');
SimpleMenu.AddCommand(TEF_FIND, FmnuFind, 'Find'#9'Ctrl+F', 'Displays and sets keyboard focus to the search panel.');
SimpleMenu.AddCommand(TEF_FINDPREV, FmnuFind, 'Previous'#9'F2', 'Moves to the previous match in the buffer.');
SimpleMenu.AddCommand(TEF_FINDNEXT, FmnuFind, 'Next'#9'F3', 'Moves to the next match in the buffer.');
SimpleMenu.AddCommand(TEF_FINDSYMB, FmnuFind, 'Find current symbol'#9'Ctrl+E', 'Highlights all instances of the selected text or the word containing the caret in the buffer.');
SimpleMenu.AddCommand(0, FmnuFind, '-', '');
SimpleMenu.AddCommand(TEF_FINDCHR, FmnuFind, 'Character search...', 'Searches the buffer for characters of a particular class or block.');
SimpleMenu.AddCommand(0, FmnuFind, '-', '');
SimpleMenu.AddCommand(TEF_REPLACE, FmnuFind, 'Replace...'#9'Ctrl+R', 'Lets you perform a search and replace operation.');
SimpleMenu.AddCommand(0, FmnuFind, '-', '');
SimpleMenu.AddCommand(TEF_GOTO, FmnuFind, 'Go to...'#9'Ctrl+G', 'Lets you move to a specific line.');
FMnuView := SimpleMenu.AddSubmenu('View', 'Contains various display options.');
SimpleMenu.AddCommand(TEF_RULER, FmnuView, 'Show ruler', 'Shows or hides the editor''s ruler.');
SimpleMenu.AddCommand(TEF_SHOWHIDDEN, FmnuView, 'Show hidden characters', 'Turns on or off the display of hidden characters.');
SimpleMenu.AddCommand(TEF_LINEHIGHL, FmnuView, 'Line highlight', 'Turns on or off the highlighting of the current line.');
FMnuInsert := SimpleMenu.AddSubmenu('Insert', 'Contains commands that insert text in the buffer.');
SimpleMenu.AddCommand(TEF_DATETIME, FmnuInsert, 'Date and time', 'Inserts the current date and time at the caret (replacing any selection).');
SimpleMenu.AddCommand(TEF_CDATETIME, FmnuInsert, 'Date or time...', 'Inserts the current date and/or time at the caret (replacing any selection).');
SimpleMenu.AddCommand(TEF_LOREM, FmnuInsert, 'Lorem ipsum...', 'Inserts a few sentences of Lorem ipsum at the caret (replacing any selection).');
SimpleMenu.AddCommand(TEF_INSCOLOR, FmnuInsert, 'Colour code...', 'Inserts a 24-bit hexadecimal RGB colour code at the caret (replacing any selection).');
SimpleMenu.AddCommand(0, FmnuInsert, '-', '');
SimpleMenu.AddCommand(TEF_IMPORT, FmnuInsert, 'Import text from file...', 'Inserts text from a file at the caret (replacing any selection).');
FMnuOptions := SimpleMenu.AddSubmenu('Options', 'Contains various behavioural options.');
SimpleMenu.AddCommand(TEF_AUTOREPLACE, FmnuOptions, 'Auto replace', 'Enables or disables automatic recognition of \chr character codes (such as \alpha, \pi, \sum, \deg, or \benzene).');
SimpleMenu.AddCommand(TEF_CBEYOND, FmnuOptions, 'Caret beyond EOL', 'Turns on or off the caret''s ability to be positioned beyond the end of each line.');
SimpleMenu.AddCommand(TEF_FONT, FmnuOptions, 'Font...', 'Lets you change the font of the editor.');
FMnuTools := SimpleMenu.AddSubmenu('Tools', 'Contains various tools.');
SimpleMenu.AddCommand(TEF_STATS, FmnuTools, 'Statistics', 'Displays statistics about the buffer, such as the number of lines, words, and characters.');
FMnuSyntax := SimpleMenu.AddSubmenu('Syntax', 'Contains the available formatting processors for syntax highlighting.');
SimpleMenu.AddCommand(SYN_NONE, FmnuSyntax, 'No interactive formatting', 'Disables syntax highlighting.', True);
SimpleMenu.AddCommand(0, FmnuSyntax, '-', '');
SimpleMenu.AddCommand(SYN_XML, FmnuSyntax, 'XML', 'Extensible Markup Language (XML)', True);
SimpleMenu.AddCommand(SYN_HTML, FmnuSyntax, 'HTML', 'Hypertext Markup Language (HTML) with Cascading Style Sheets (CSS)', True);
SimpleMenu.AddCommand(SYN_CSS, FmnuSyntax, 'CSS', 'Cascading Style Sheets (CSS)', True);
SimpleMenu.AddCommand(SYN_MW, FmnuSyntax, 'MediaWiki', 'MediaWiki markup language', True);
SimpleMenu.AddCommand(SYN_PAS, FmnuSyntax, 'Pascal', 'Pascal, Object Pascal, and Delphi', True);
SimpleMenu.AddCommand(SYN_AS, FmnuSyntax, 'Algosim', 'Algosim source code', True);
SimpleMenu.AddCommand(SYN_ASML, FmnuSyntax, 'ASML', 'Algosim Markup Language', True);
SimpleMenu.AddCommand(SYN_INI, FmnuSyntax, 'INI', 'Windows INI files', True);
FMnuHelp := SimpleMenu.AddSubmenu('Help', 'Contains documentation and reference links.');
SimpleMenu.AddCommand(TEF_ARL, FmnuHelp, 'Show auto-replace list', 'Displays the list of all currently configured auto-replace codes (like \alpha for the Greek letter alpha).');
end;
procedure TTextEditorForm.UpdateCaption;
begin
var S := '';
if Assigned(FEditor) then
begin
S := ExtractFileName(FEditor.TextFile.FileName);
if FEditor.TextFile.FileModified then
S := S + '*';
end;
Caption := S;
end;
procedure TTextEditorForm.UpdatePanelCaption;
begin
UpdateCaption;
end;
procedure TTextEditorForm.UpdateStatusBar;
begin
if not FEditorNotificationText.IsEmpty then
begin
StatusText := FEditorNotificationText;
Exit;
end;
if Assigned(FEditor) then
if FEditor.TextFile.HasSelection then
if FEditor.CaretPos.Y = FEditor.SelEndPos.Y then
StatusText :=
PrettyFormat(
'Line: %d Cols: %d–%d Len: %d'#9'%d%%',
[
FEditor.CaretPos.Y + 1,
Min(FEditor.CaretPos.X, FEditor.SelEndPos.X) + 1,
Max(FEditor.CaretPos.X, FEditor.SelEndPos.X) + 1,
FEditor.SelLength,
FEditor.Zoom
]
)
else
StatusText :=
PrettyFormat(
'Lines: %d–%d Len: %d'#9'%d%%',
[
Min(FEditor.CaretPos.Y, FEditor.SelEndPos.Y) + 1,
Max(FEditor.CaretPos.Y, FEditor.SelEndPos.Y) + 1,
FEditor.SelLength,
FEditor.Zoom
]
)
else
StatusText :=
PrettyFormat(
'Line: %d Col: %d Chr: %d'#9'%d%%',
[
FEditor.CaretPos.Y + 1,
FEditor.CaretPos.X + 1,
FEditor.SelStart + 1,
FEditor.Zoom
]
)
else
StatusText := '';
end;
procedure TSimpleMenu.AddCommand(AID: Integer; const AText, AHint: string;
ARadio: Boolean);
begin
var LMenu := TSimpleMenuItem.Create(Self);
LMenu.CmdID := AID;
LMenu.Caption := AText;
LMenu.Hint := AHint;
LMenu.OnClick := CmdInvoked;
LMenu.RadioItem := ARadio;
Items.Add(LMenu);
end;
procedure TSimpleMenu.AddCommand(AID, ASubmenuIndex: Integer; const AText,
AHint: string; ARadio: Boolean);
begin
if not InRange(ASubmenuIndex, 0, High(FSubmenus)) then
Exit;
var LMenu := TSimpleMenuItem.Create(Self);
LMenu.CmdID := AID;
LMenu.Caption := AText;
LMenu.Hint := AHint;
LMenu.OnClick := CmdInvoked;
LMenu.RadioItem := ARadio;
FSubmenus[ASubmenuIndex].Add(LMenu);
end;
procedure TSimpleMenu.AddCustomSubmenu(const AText, AHint: string;
ACtor: TCustomSubmenuCtor; AHandler: TCustomMenuItemClick);
begin
var LMenu := TCustomSubmenu.Create(Self);
LMenu.Caption := AText;
LMenu.Hint := AHint;
LMenu.Ctor := ACtor;
LMenu.Handler := AHandler;
Items.Add(LMenu);
end;
function TSimpleMenu.AddSubmenu(const AText, AHint: string): Integer;
begin
var LMenu := TMenuItem.Create(Self);
LMenu.Caption := AText;
LMenu.Hint := AHint;
Items.Add(LMenu);
FSubmenus := FSubmenus + [LMenu];
Result := High(FSubmenus);
end;
procedure TSimpleMenu.CmdInvoked(Sender: TObject);
begin
if Sender is TSimpleMenuItem then
if FEnabled and Assigned(FOnExecute) then
FOnExecute(Self, TSimpleMenuItem(Sender).CmdID);
end;
constructor TSimpleMenu.Create(AOwner: TComponent);
begin
inherited;
FEnabled := True;
end;
procedure TSimpleMenu.Popup(X, Y: Integer);
procedure InitiateSubmenu(AMenuItem: TMenuItem);
begin
for var i := 0 to AMenuItem.Count - 1 do
begin
if AMenuItem[i] is TSimpleMenuItem then
begin
var LVisible := True;
var LEnabled := FEnabled;
var LChecked := False;
if FEnabled then
FOnGetState(Self, TSimpleMenuItem(AMenuItem[i]).CmdID, LVisible, LEnabled, LChecked);
AMenuItem[i].Visible := LVisible;
AMenuItem[i].Enabled := LEnabled;
AMenuItem[i].Checked := LChecked;
end;
InitiateSubmenu(AMenuItem[i]);
if AMenuItem[i] is TCustomSubmenu then
begin
AMenuItem[i].Visible := True;
AMenuItem[i].Clear;
AMenuItem[i].NewTopLine;
end
else if not Assigned(AMenuItem[i].OnClick) then
begin
var LHasVisibleSubItem := False;
for var j := 0 to AMenuItem[i].Count - 1 do
if not AMenuItem[i].Items[j].IsLine and AMenuItem[i].Items[j].Visible then
begin
LHasVisibleSubItem := True;
Break;
end;
AMenuItem[i].Visible := LHasVisibleSubItem;
end;
end;
end;
begin
if Assigned(FOnGetState) then
InitiateSubmenu(Items);
inherited;
end;
function TImageViewerForm.ContextHelp: Boolean;
begin
TDocBrowser.ShowDocOrIndex('Image viewer', False);
Result := True;
end;
constructor TImageViewerForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
FImageViewer := TImageViewer.Create(Self);
FImageViewer.Parent := Self;
FImageViewer.Align := alClient;
FImageViewer.OnCaptionChange := ImageViewerCaptionChange;
FImageViewer.OnBitmapChanged := ImageViewerBitmapChanged;
FImageViewer.OnZoomChange := ImageViewerZoomChange;
FImageViewer.OnZoomChangeDyn := ImageViewerZoomChange;
FImageViewer.OnNewWindowReq := ImageViewerNewWindowReq;
FImageViewer.Color := clWhite;
ToolMenu := FImageViewer._PrvtCtxMenu;
StatusBar := True;
UpdateStatusBar;
end;
procedure TImageViewerForm.ImageViewerBitmapChanged(Sender: TObject);
begin
UpdateStatusBar;
end;
procedure TImageViewerForm.ImageViewerCaptionChange(Sender: TObject);
begin
Caption := FImageViewer.Caption;
end;
procedure TImageViewerForm.ImageViewerNewWindowReq(Sender: TObject);
begin
var LNewForm := TUxForm.CreateNewForm<TImageViewerForm>;
if Assigned(FImageViewer) then
begin
LNewForm.Bitmap := FImageViewer.Bitmap;
LNewForm.FImageViewer.Caption := FImageViewer.Caption;
end;
end;
procedure TImageViewerForm.ImageViewerZoomChange(Sender: TObject);
begin
UpdateStatusBar;
end;
procedure TImageViewerForm.LoadFromFile(const AFileName: string);
begin
inherited;
FImageViewer.LoadFromFile(AFileName);
end;
procedure TImageViewerForm.SetBitmap(const Value: TBitmap);
begin
if Assigned(FImageViewer) then
FImageViewer.Bitmap := Value;
end;
procedure TImageViewerForm.UpdateStatusBar;
begin
if Assigned(FImageViewer) and Assigned(FImageViewer.Bitmap) then
StatusText :=
PrettyFormat(
'%d×%d'#9'%.2fx',
[
FImageViewer.Bitmap.Width,
FImageViewer.Bitmap.Height,
FImageViewer.Zoom
]
)
else
StatusText := '';
end;
procedure TCharacterBrowser.BlockItemClick(Sender: TObject);
begin
if (Sender is TMenuItem) and Assigned(FBrowser) and not FSearchMatch then
begin
var MI := TMenuItem(Sender);
var i := MI.Tag;
if InRange(i, 0, UCD.BMPBlockCount - 1) and (UCD.Blocks[i].BlockBegin <= FBrowser.Items.Count - 1) then
begin
FBrowser.ItemIndex := UCD.Blocks[i].BlockBegin;
if Assigned(FBrowser.Selected) then
begin
FBrowser.Selected.MakeVisible(False);
const LBounds = FBrowser.Selected.DisplayRect(drBounds);
if Abs(LBounds.Top) > ScaleValue(16) then
FBrowser.Scroll(0, LBounds.Top)
end;
if FBrowser.CanFocus then
FBrowser.SetFocus;
end;
end;
end;
procedure TCharacterBrowser.BlockLabelClick(Sender: TObject);
begin
if Assigned(FBlockLabel) and Assigned(FBlockMenu) and not FSearchMatch then
begin
var P := FBlockLabel.ClientToScreen(Point(0, FBlockLabel.Height));
FBlockMenu.PopupComponent := FBlockLabel;
FBlockMenu.Popup(P.X, P.Y);
end;
end;
procedure TCharacterBrowser.BlockMenuPopup(Sender: TObject);
begin
if Assigned(FBlockLabel) and Assigned(FBlockMenu) then
for var i := 0 to FBlockMenu.Items.Count - 1 do
FBlockMenu.Items[i].Checked := FBlockMenu.Items[i].Tag = FBlockLabel.Tag;
end;
function CodepointToString(const ACodepoint: UInt32): string;
begin
if ACodepoint <= $FFFF then
Result := string(Chr(ACodepoint))
else if ACodepoint <= $10FFFF then
begin
const LCodepoint: UInt32 = ACodepoint - $10000;
const LHigh: UInt16 = $D800 or LCodepoint shr 10;
const LLow: UInt16 = $DC00 or LCodepoint and 1023;
SetLength(Result, 2);
Result[1] := Chr(LHigh);
Result[2] := Chr(LLow);
end;
end;
procedure TCharacterBrowser.BrowserCustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
if Sender = nil then
Exit;
if Item = nil then
Exit;
var R := Item.DisplayRect(drBounds);
var S: string := CodepointToString(UInt32(Item.Data));
if cdsSelected in State then
begin
Sender.Canvas.Brush.Color := Rux.TUx.ThemeData.InactiveCaptionColor;
Sender.Canvas.Pen.Color := Rux.TUx.ThemeData.InactiveCaptionTextColor;
Sender.Canvas.Font.Color := Rux.TUx.ThemeData.InactiveCaptionTextColor;
end
else
begin
Sender.Canvas.Brush.Color := clWindow;
Sender.Canvas.Pen.Color := clWindowText;
Sender.Canvas.Font.Color := clWindowText;
end;
Sender.Canvas.FillRect(R);
Sender.Canvas.Font.Height := FImages.Height;
Sender.Canvas.TextRect(R, S, [tfSingleLine, tfVerticalCenter, tfCenter]);
if cdsFocused in State then
begin
InflateRect(R, -ScaleValue(4), -ScaleValue(4));
Sender.Canvas.DrawFocusRect(R);
end;
DefaultDraw := False;
end;
procedure TCharacterBrowser.BrowserData(Sender: TObject; Item: TListItem);
begin
if Item = nil then
Exit;
var CP: Integer;
if FSearchMatch then
CP := FMatches[Item.Index]
else
CP := Item.Index;
Item.Caption := CodepointToString(CP);
Item.Data := Pointer(CP);
end;
procedure TCharacterBrowser.BrowserKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
end;
procedure TCharacterBrowser.BrowserKeyPress(Sender: TObject; var Key: Char);
begin
case Key of
^C:
if Assigned(FBrowser) and Assigned(FBrowser.Selected) then
begin
Clipboard.AsText := FBrowser.Selected.Caption;
Key := #0;
end;
end;
end;
procedure TCharacterBrowser.BrowserMenuItemClick(Sender: TObject);
begin
if FBrowser = nil then
Exit;
if FBrowser.Selected = nil then
Exit;
const LChar = FBrowser.Selected.Caption;
const LCodepoint = UInt32(FBrowser.Selected.Data);
if Sender is TMenuItem then
begin
var MI := TMenuItem(Sender);
case MI.Tag of
BRW_COPYCHAR:
Clipboard.AsText := LChar;
BRW_COPYDESC:
Clipboard.AsText := UCD.GetChrName(LCodepoint);
BRW_COPYGROUP:
Clipboard.AsText := UCD.GetChrBlock(LCodepoint);
BRW_COPYCP:
Clipboard.AsText := UCD.GetChrCodepointStr(LCodepoint);
end;
end;
end;
procedure TCharacterBrowser.BrowserMenuPopup(Sender: TObject);
begin
if FBrowser = nil then
Exit;
if FBrowserPopup = nil then
Exit;
const LEnabled = FBrowser.ItemIndex <> -1;
for var i := 0 to FBrowserPopup.Items.Count - 1 do
FBrowserPopup.Items[i].Enabled := LEnabled;
end;
procedure TCharacterBrowser.BrowserSelCntChange(Sender: TObject);
begin
UpdateStatusBar;
end;
procedure TCharacterBrowser.CmdExec(AID: Integer);
begin
if FBrowser = nil then
Exit;
if FImages = nil then
Exit;
const LOldSize = FImages.Height;
case AID of
CBF_ZOOMIN, CBF_ZOOMOUT, CBF_ZOOMDEF:
begin
var LNewSize: Integer;
case AID of
CBF_ZOOMIN:
LNewSize := Round(LOldSize * 3/2);
CBF_ZOOMOUT:
LNewSize := Round(LOldSize * 2/3);
else
LNewSize := 48;
end;
if LNewSize < 16 then
Exit;
if LNewSize > 1024 then
Exit;
FImages.Width := LNewSize;
FImages.Height := LNewSize;
FBrowser.Invalidate;
if FBrowser.Selected <> nil then
FBrowser.Selected.MakeVisible(False);
end;
CBF_FIND:
begin
if Assigned(eFindText) then
begin
eFindText.SelectAll;
if eFindText.CanFocus then
eFindText.SetFocus;
end;
end;
CBF_FONT:
begin
var LDlg := TFontDialog.Create(nil);
try
LDlg.Font.Assign(FBrowser.Font);
LDlg.Options := [fdForceFontExist, fdApplyButton];
LDlg.OnApply := FontDialogApply;
if LDlg.Execute then
begin
FBrowser.Font.Assign(LDlg.Font);
FBrowser.Invalidate;
end;
finally
LDlg.Free;
end;
end;
end;
end;
function TCharacterBrowser.ContextHelp: Boolean;
begin
TDocBrowser.ShowDocOrIndex('Character browser', False);
Result := True;
end;
constructor TCharacterBrowser.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
FFindTextTimer := TTimer.Create(Self);
FFindTextTimer.Enabled := False;
FFindTextTimer.Interval := 500;
FFindTextTimer.OnTimer := FindTextTimerTimer;
FImages := TImageList.Create(Self);
FImages.Width := 48;
FImages.Height := 48;
FBrowser := TCharacterListView.Create(Self);
FBrowser.DoubleBuffered := True;
FBrowser.Parent := Self;
FBrowser.Align := alClient;
FBrowser.BorderStyle := bsNone;
FBrowser.LargeImages := FImages;
FBrowser.MultiSelect := False;
FBrowser.RowSelect := True;
FBrowser.OwnerData := True;
FBrowser.OnData := BrowserData;
FBrowser.OnCustomDrawItem := BrowserCustomDrawItem;
FBrowser.OnKeyDown := BrowserKeyDown;
FBrowser.OnKeyPress := BrowserKeyPress;
FBrowser.ReadOnly := True;
FBrowser.HideSelection := True;
FBrowser.Items.Count := $10000;
FBrowser.OnSelCntChange := BrowserSelCntChange;
FBrowserPopup := TPopupMenu.Create(Self);
FBrowserPopup.OnPopup := BrowserMenuPopup;
var mi := TMenuItem.Create(FBrowserPopup);
mi.Caption := 'Copy character'#9'Ctrl+C';
mi.Hint := 'Copies the selected character to clipboard.';
mi.Tag := BRW_COPYCHAR;
mi.OnClick := BrowserMenuItemClick;
FBrowserPopup.Items.Add(mi);
mi := TMenuItem.Create(FBrowserPopup);
mi.Caption := 'Copy character name';
mi.Hint := 'Copies the name of the selected character to clipboard.';
mi.Tag := BRW_COPYDESC;
mi.OnClick := BrowserMenuItemClick;
FBrowserPopup.Items.Add(mi);
mi := TMenuItem.Create(FBrowserPopup);
mi.Caption := 'Copy character block';
mi.Hint := 'Copies the name of the block of the selected character to clipboard.';
mi.Tag := BRW_COPYGROUP;
mi.OnClick := BrowserMenuItemClick;
FBrowserPopup.Items.Add(mi);
mi := TMenuItem.Create(FBrowserPopup);
mi.Caption := 'Copy codepoint';
mi.Hint := 'Copies the codepoint of the selected character to clipboard.';
mi.Tag := BRW_COPYCP;
mi.OnClick := BrowserMenuItemClick;
FBrowserPopup.Items.Add(mi);
FBrowser.PopupMenu := FBrowserPopup;
StatusBar := True;
end;
procedure TCharacterBrowser.FindTextChange(Sender: TObject);
begin
FFindTextTimer.Enabled := False;
FFindTextTimer.Enabled := True;
end;
procedure TCharacterBrowser.FindTextKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_RETURN:
begin
if Assigned(FFindTextTimer) and FFindTextTimer.Enabled then
FindTextTimerTimer(Sender);
if Assigned(FBrowser) and (FBrowser.Items.Count > 0) then
FBrowser.ItemIndex := 0;
if Assigned(FBrowser) and FBrowser.CanFocus then
FBrowser.SetFocus;
Key := 0;
end;
end;
end;
procedure TCharacterBrowser.FindTextTimerTimer(Sender: TObject);
begin
if FBrowser = nil then
Exit;
if eFindText = nil then
Exit;
if FFindTextTimer = nil then
Exit;
FFindTextTimer.Enabled := False;
const S = eFindText.PlainText.Trim;
FBrowser.Items.Count := 0;
if S.IsEmpty then
begin
FSearchMatch := False;
FMatches := nil;
FBrowser.Items.Count := $10000;
FBrowser.EmptyText := '';
if Assigned(FBlockLabel) then
FBlockLabel.Cursor := crHandPoint;
end
else
begin
FMatches := UCD.SearchChrNames(S);
FSearchMatch := True;
FBrowser.Items.Count := Length(FMatches);
FBrowser.EmptyText := 'No matches';
if Assigned(FBlockLabel) then
FBlockLabel.Cursor := crDefault;
end;
FBrowser.Invalidate;
UpdateStatusBar;
end;
procedure TCharacterBrowser.FirstShow;
begin
RequestClientSize(1000, 800);
end;
procedure TCharacterBrowser.PanelShortCut(var Msg: TWMKey;
var Handled: Boolean);
begin
if GetKeyState(VK_MENU) < 0 then
begin
inherited;
Exit;
end;
if GetKeyState(VK_CONTROL) < 0 then
case Msg.CharCode of
Ord('0'), VK_NUMPAD0:
begin
CmdExec(CBF_ZOOMDEF);
Handled := True;
end;
VK_ADD, VK_OEM_PLUS:
begin
CmdExec(CBF_ZOOMIN);
Handled := True;
end;
VK_SUBTRACT, VK_OEM_MINUS:
begin
CmdExec(CBF_ZOOMOUT);
Handled := True;
end;
Ord('F'):
begin
CmdExec(CBF_FIND);
Handled := True;
end;
end;
if not Handled then
inherited;
end;
procedure TCharacterBrowser.SetupToolbar;
begin
inherited;
eFindText := AddToolbarControl<TTextEditor>;
eFindText.TextHint := 'Search by character name';
eFindText.SingleLine := True;
eFindText.OnChange := FindTextChange;
eFindText.OnKeyDown := FindTextKeyDown;
FBlockMenu := TPopupMenu.Create(Self);
FBlockMenu.OnPopup := BlockMenuPopup;
for var i := 0 to UCD.BMPBlockCount - 1 do
begin
var LMenuItem := TMenuItem.Create(FBlockMenu);
LMenuItem.Caption := UCD.Blocks[i].BlockName;
LMenuItem.Hint := 'Moves to the first codepoint in this block.';
LMenuItem.Tag := i;
LMenuItem.OnClick := BlockItemClick;
LMenuItem.RadioItem := True;
if i mod 40 = 0 then
LMenuItem.Break := mbBreak;
FBlockMenu.Items.Add(LMenuItem);
end;
FBlockLabel := AddToolbarControl<TUxLabel>;
FBlockLabel.Caption := 'Blocks';
FBlockLabel.Hint := 'Displays the block of the selected character; click to display a list of all blocks.';
FBlockLabel.Anchors := [TAnchorKind.akTop, TAnchorKind.akRight];
FBlockLabel.Cursor := crHandPoint;
FBlockLabel.OnClick := BlockLabelClick;
end;
procedure TCharacterBrowser.SetupToolMenu;
begin
inherited;
CreateToolMenu;
SimpleMenu.AddCommand(CBF_ZOOMIN, 'Zoom in', 'Makes the characters larger.');
SimpleMenu.AddCommand(CBF_ZOOMOUT, 'Zoom out', 'Makes the characters smaller.');
SimpleMenu.AddCommand(CBF_ZOOMDEF, 'Restore zoom', 'Restores the original character size.');
SimpleMenu.AddCommand(0, '-', '');
SimpleMenu.AddCommand(CBF_FIND, 'Search...', 'Lets you search the character database for a given string.');
SimpleMenu.AddCommand(0, '-', '');
SimpleMenu.AddCommand(CBF_FONT, 'Change font...', 'Lets you request a specific font to be used when rendering the glyphs in this window.');
end;
procedure TCharacterBrowser.FontDialogApply(Sender: TObject; Wnd: HWND);
begin
if FBrowser = nil then
Exit;
if Sender is TFontDialog then
begin
FBrowser.Font.Assign(TFontDialog(Sender).Font);
FBrowser.Invalidate;
end;
end;
class function TCharacterBrowser.IsDisposable: Boolean;
begin
Result := True;
end;
procedure TCharacterBrowser.UpdateStatusBar;
begin
if Assigned(FBrowser) and (FBrowser.SelCount = 1) then
begin
var LItem := FBrowser.Selected;
if Assigned(LItem) then
begin
StatusText := UCD.GetChrName(Integer(LItem.Data)) + #9 + UCD.GetChrCodepointStr(Integer(LItem.Data));
if Assigned(FBlockLabel) then
begin
var i := -1;
const LOldBlockLabelTag = FBlockLabel.Tag;
FBlockLabel.Caption := UCD.GetChrBlock(Integer(LItem.Data), i);
FBlockLabel.Visible := True;
FBlockLabel.Tag := i;
if FBlockLabel.Tag <> LOldBlockLabelTag then
FBrowser.Invalidate;
end;
end;
end
else if FSearchMatch then
begin
if Assigned(FBlockLabel) then
begin
const LOldBlockLabelTag = FBlockLabel.Tag;
FBlockLabel.Visible := False;
FBlockLabel.Caption := '';
FBlockLabel.Tag := -1;
if FBlockLabel.Tag <> LOldBlockLabelTag then
FBrowser.Invalidate;
end;
StatusText := PrettyFormat('%d match(es)', [Length(FMatches)]);
end
else
begin
if Assigned(FBlockLabel) then
begin
const LOldBlockLabelTag = FBlockLabel.Tag;
FBlockLabel.Visible := True;
FBlockLabel.Caption := 'Blocks';
FBlockLabel.Tag := -1;
if FBlockLabel.Tag <> LOldBlockLabelTag then
FBrowser.Invalidate;
end;
StatusText := '';
end;
end;
class constructor TCharacterListView.ClassCreate;
begin
Formats := [FORMATETC_UNICODETEXT];
end;
function TCharacterListView.DAdvise(const formatetc: tagFORMATETC;
advf: Integer; const advSink: IAdviseSink;
out dwConnection: Integer): HRESULT;
begin
Result := OLE_E_ADVISENOTSUPPORTED;
end;
function TCharacterListView.DUnadvise(dwConnection: Integer): HRESULT;
begin
Result := OLE_E_ADVISENOTSUPPORTED;
end;
function TCharacterListView.EnumDAdvise(out enumAdvise: IEnumSTATDATA): HRESULT;
begin
Result := OLE_E_ADVISENOTSUPPORTED;
end;
function TCharacterListView.EnumFormatEtc(dwDirection: Integer;
out enumFormatEtc: IEnumFORMATETC): HRESULT;
begin
if dwDirection = DATADIR_GET then
begin
enumFormatEtc := TEnumFormatEtc.Create;
Result := S_OK;
end
else
begin
enumFormatEtc := nil;
Result := E_NOTIMPL;
end;
end;
function TCharacterListView.GetCanonicalFormatEtc(const formatetc: tagFORMATETC;
out formatetcOut: tagFORMATETC): HRESULT;
begin
formatetcOut := formatetc;
formatetcOut.ptd := nil;
Result := DATA_S_SAMEFORMATETC;
end;
function ChrListView_CreateHGlobal(Data: pointer; Len: UInt64;
uFlags: DWORD; out hGlobal: HGLOBAL): HRESULT;
var
p: Pointer;
begin
hGlobal := GlobalAlloc(uFlags, Len);
if hGlobal <> 0 then
begin
p := GlobalLock(hGlobal);
if Assigned(p) then
begin
CopyMemory(p, Data, Len);
GlobalUnlock(hGlobal);
end
else
begin
GlobalFree(hGlobal);
hGlobal := 0;
end;
end;
Result := IfThen(hGlobal <> 0, S_OK, E_OUTOFMEMORY);
end;
function TCharacterListView.GetData(const formatetcIn: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT;
begin
FillChar(medium, SizeOf(medium), 0);
var LStr := '';
if ItemIndex <> -1 then
begin
var LItem := Selected;
if Assigned(LItem) then
LStr := LItem.Caption
end;
case GetMatchingFormatIdx(formatetcIn) of
FMT_UNICODETEXT:
begin
medium.tymed := TYMED_HGLOBAL;
Result := ChrListView_CreateHGlobal(PChar(LStr), (LStr.Length + 1) * SizeOf(Char),
GMEM_MOVEABLE, medium.hGlobal);
end;
else
Result := DV_E_FORMATETC;
end;
end;
function TCharacterListView.GetDataHere(const formatetc: tagFORMATETC;
out medium: tagSTGMEDIUM): HRESULT;
begin
Result := E_NOTIMPL;
end;
function TCharacterListView.GetMatchingFormatIdx(
const AFormatEtc: TFormatEtc): Integer;
begin
for var i := 0 to High(Formats) do
if
(Formats[i].cfFormat = AFormatEtc.cfFormat)
and
(Formats[i].tymed and AFormatEtc.tymed <> 0)
and
(Formats[i].dwAspect = AFormatEtc.dwAspect)
and
(Formats[i].lindex = AFormatEtc.lindex)
then
Exit(i);
Result := -1;
end;
function TCharacterListView.GiveFeedback(dwEffect: Longint): HRESULT;
begin
Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
procedure TCharacterListView.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
FMouseDownPoint := Point(X, Y);
FDragDetect := (Button = mbLeft) and (ItemIndex <> -1);
end;
procedure TCharacterListView.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
if FDragDetect and (csLButtonDown in ControlState) then
begin
const CxDrag = ScaleValue(GetSystemMetrics(SM_CXDRAG));
const CyDrag = ScaleValue(GetSystemMetrics(SM_CYDRAG));
if (Abs(X - FMouseDownPoint.X) > CxDrag) or (Abs(Y - FMouseDownPoint.Y) > CyDrag) then
begin
var LDropEffect := 0;
try
DoDragDrop(Self, Self, DROPEFFECT_COPY, LDropEffect);
TUxForm.RequestCleanup;
finally
ControlState := ControlState - [csLButtonDown];
end;
end;
end
end;
procedure TCharacterListView.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
FMouseDownPoint := Point(-1, -1);
FDragDetect := False;
end;
function TCharacterListView.QueryContinueDrag(fEscapePRessed: BOOL;
grfKeyState: Longint): HRESULT;
begin
if fEscapePressed then
Result := DRAGDROP_S_CANCEL
else if grfKeyState and MK_LBUTTON = 0 then
Result := DRAGDROP_S_DROP
else
Result := S_OK;
end;
function TCharacterListView.QueryGetData(
const formatetc: tagFORMATETC): HRESULT;
begin
Result := IfThen(GetMatchingFormatIdx(formatetc) <> -1, S_OK, S_FALSE);
end;
function TCharacterListView.SetData(const formatetc: tagFORMATETC;
var medium: tagSTGMEDIUM; fRelease: LongBool): HRESULT;
begin
Result := E_NOTIMPL;
end;
function TCharacterListView.TEnumFormatEtc.Clone(
out Enum: IEnumFormatEtc): HResult;
begin
try
Enum := TEnumFormatEtc.Create;
TEnumFormatEtc(Enum).FIndex := Self.FIndex;
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TCharacterListView.TEnumFormatEtc.Next(celt: Longint; out elt;
pceltFetched: PLongint): HResult;
begin
if (celt <= 0) or ((celt > 1) and (pceltFetched = nil)) then
Exit(E_INVALIDARG);
var count := 0;
var p := PFormatEtc(@elt);
while (FIndex <= High(Formats)) and (count < celt) do
begin
p^ := Formats[FIndex];
Inc(p);
Inc(count);
Inc(FIndex);
end;
if Assigned(pceltFetched) then
pceltFetched^ := count;
Result := IfThen(count = celt, S_OK, S_FALSE);
end;
function TCharacterListView.TEnumFormatEtc.Reset: HResult;
begin
FIndex := 0;
Result := S_OK;
end;
function TCharacterListView.TEnumFormatEtc.Skip(celt: Longint): HResult;
begin
if FIndex + celt <= High(Formats) then
begin
Inc(FIndex, celt);
Result := S_OK;
end
else
Result := S_FALSE;
end;
class procedure TDbgLogForm.AppEventsException(Sender: TObject; E: Exception);
begin
DoLog(E);
end;
class constructor TDbgLogForm.ClassCreate;
begin
FInstances := TList<TDbgLogForm>.Create;
FDebugLog := TList<TDebugLogItem>.Create;
FAppEvents := TApplicationEvents.Create(nil);
FAppEvents.OnException := AppEventsException;
end;
class destructor TDbgLogForm.ClassDestroy;
begin
FreeAndNil(FAppEvents);
FreeAndNil(FDebugLog);
FreeAndNil(FInstances);
end;
class procedure TDbgLogForm.ClearLog;
begin
if Assigned(FDebugLog) then
begin
FDebugLog.Clear;
DebugLogAppended;
end;
end;
procedure TDbgLogForm.CmdExec(AID: Integer);
begin
case AID of
DLF_CLEAR:
begin
ClearLog;
end;
DLF_COPYALL:
begin
if Assigned(FDebugLog) and (FDebugLog.Count > 0) then
begin
var L := TArray<string>(nil);
SetLength(L, FDebugLog.Count);
for var i := 0 to High(L) do
L[i] := DateTimeToStdStrMS(FDebugLog[i].Time) + #9 + FDebugLog[i].Text;
Clipboard.AsText := string.Join(#13#10, L);
end;
end;
DLF_TOEDITOR:
begin
if Assigned(FDebugLog) and (FDebugLog.Count > 0) then
begin
var L := TArray<string>(nil);
SetLength(L, FDebugLog.Count);
for var i := 0 to High(L) do
L[i] := DateTimeToStdStrMS(FDebugLog[i].Time) + #9 + FDebugLog[i].Text;
const S = string.Join(#13#10, L);
var LNewForm := TUxForm.CreateNewForm<TTextEditorForm>;
LNewForm.Editor.TextFile.PlainText := S;
LNewForm.Editor.TextFile.GotoSOF;
LNewForm.Editor.TextFile.ClearUndoHistory;
LNewForm.Editor.TextFile.AddUndoRecord(SUndoNewFile, UID_UNKNOWN);
LNewForm.Editor.TextFile.FileModified := False;
LNewForm.Editor.TextFile.FileName := Self.Caption;
LNewForm.UpdateCaption;
end;
end;
end;
end;
procedure TDbgLogForm.CmdGetState(AID: Integer; var AVisible, AEnabled, AChecked: Boolean);
begin
case AID of
DLF_CLEAR, DLF_COPYALL, DLF_TOEDITOR:
AEnabled := Assigned(FDebugLog) and (FDebugLog.Count > 0);
end;
end;
constructor TDbgLogForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
FListView := TListViewEx.Create(Self);
FListView.Parent := Self;
FListView.Align := alClient;
FListView.BorderStyle := bsNone;
FListView.ViewStyle := vsReport;
FListView.ShowColumnHeaders := False;
var LCol := FListView.Columns.Add;
LCol.Caption := 'Time';
LCol.Width := 150;
LCol := FListView.Columns.Add;
LCol.Caption := 'Message';
LCol.Width := 400;
LCol.AutoSize := True;
FListView.RowSelect := True;
FListView.ReadOnly := True;
FListView.ColumnClick := False;
FListView.MultiSelect := True;
FListView.OwnerData := True;
FListView.OnData := ListViewData;
FListView.OnSelCntChange := ListViewSelCntChange;
if Assigned(FDebugLog) then
FListView.Items.Count := FDebugLog.Count;
if Assigned(FInstances) then
FInstances.Add(Self);
StatusBar := True;
end;
class procedure TDbgLogForm.DebugLogAppended;
begin
if Assigned(FInstances) then
for var LInstance in FInstances do
LInstance.RefreshLogView;
end;
destructor TDbgLogForm.Destroy;
begin
if Assigned(FInstances) then
FInstances.Remove(Self);
inherited;
end;
class procedure TDbgLogForm.DoLog(const AItem: TDebugLogItem);
begin
if Assigned(FDebugLog) then
begin
FDebugLog.Add(AItem);
DebugLogAppended;
end;
end;
class procedure TDbgLogForm.DoLog(const S: string);
begin
var LItem := Default(TDebugLogItem);
LItem.Time := Now;
LItem.Text := S;
DoLog(LItem);
end;
class procedure TDbgLogForm.DoLog(const S: string; E: Exception);
begin
if E = nil then
begin
DoLog(S);
Exit;
end;
var LItem := Default(TDebugLogItem);
LItem.Time := Now;
LItem.Text := S + #32 + E.ClassName + ': ' + E.Message;
DoLog(LItem);
end;
class procedure TDbgLogForm.DoLog(E: Exception);
begin
if E = nil then
Exit;
var LItem := Default(TDebugLogItem);
LItem.Time := Now;
LItem.Text := E.ClassName + ': ' + E.Message;
DoLog(LItem);
end;
class function TDbgLogForm.GetLog: TArray<string>;
begin
Result := nil;
if FDebugLog = nil then
Exit;
SetLength(Result, FDebugLog.Count);
for var i := 0 to FDebugLog.Count - 1 do
Result[i] :=
DateTimeToStdStrMS(FDebugLog[i].Time) + #9 + FDebugLog[i].Text;
end;
class function TDbgLogForm.IsDisposable: Boolean;
begin
Result := True;
end;
procedure TDbgLogForm.ListViewData(Sender: TObject; Item: TListItem);
begin
if Self = nil then
Exit;
if FListView = nil then
Exit;
if Item = nil then
Exit;
if FDebugLog = nil then
Exit;
if not InRange(Item.Index, 0, FDebugLog.Count - 1) then
Exit;
Item.Caption := DateTimeToStdStr(FDebugLog[Item.Index].Time);
Item.SubItems.Add(FDebugLog[Item.Index].Text);
end;
procedure TDbgLogForm.ListViewSelCntChange(Sender: TObject);
begin
UpdateStatusBar;
end;
procedure TDbgLogForm.RefreshLogView;
begin
if FListView = nil then
Exit;
if not HandleAllocated then
Exit;
FListView.LockDrawing;
try
if FDebugLog = nil then
FListView.Items.Count := 0
else
FListView.Items.Count := FDebugLog.Count;
FListView.Invalidate;
FListView.AdjustColumns;
finally
FListView.UnlockDrawing;
end;
FListView.Scroll(0, -Integer.MaxValue);
UpdateStatusBar;
end;
procedure TDbgLogForm.SetupToolMenu;
begin
inherited;
CreateToolMenu;
SimpleMenu.AddCommand(DLF_CLEAR, 'Clear log', 'Clears the debug log for this session.');
SimpleMenu.AddCommand(DLF_COPYALL, 'Copy all', 'Copies the entire log to clipboard.');
SimpleMenu.AddCommand(DLF_TOEDITOR, 'To editor', 'Opens the current full log in a new text editor panel.');
end;
procedure TDbgLogForm.UpdateStatusBar;
begin
StatusText := PrettyFormat('%d item(s) %d selected',
[FListView.Items.Count, FListView.SelCount]);
end;
procedure TClockForm.ClockNewSec(Sender: TObject);
begin
if Assigned(FClock) and FClock.ShowSeconds then
StatusText := FormatDateTime('yyyy-mm-dd'#9'hh:nn:ss', Now)
else
StatusText := FormatDateTime('yyyy-mm-dd'#9'hh:nn', Now)
end;
procedure TClockForm.CmdExec(AID: Integer);
begin
if FClock = nil then
Exit;
case AID of
CLF_SHOWSECONDS:
FClock.ShowSeconds := not FClock.ShowSeconds;
end;
end;
procedure TClockForm.CmdGetState(AID: Integer; var AVisible, AEnabled, AChecked: Boolean);
begin
if FClock = nil then
Exit;
case AID of
CLF_SHOWSECONDS:
AChecked := FClock.ShowSeconds;
end;
end;
constructor TClockForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
FClock := TClockCtl.Create(Self);
FClock.Parent := Self;
FClock.Align := alClient;
FClock.OnNewSec := ClockNewSec;
StatusBar := True;
end;
destructor TClockForm.Destroy;
begin
inherited;
end;
class function TClockForm.IsDisposable: Boolean;
begin
Result := True;
end;
procedure TClockForm.SetupToolMenu;
begin
inherited;
CreateToolMenu;
SimpleMenu.AddCommand(CLF_SHOWSECONDS, 'Show seconds', 'Enables or disables the display of seconds.');
end;
procedure TUxClientLayer.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.ExStyle := Params.ExStyle or WS_EX_LAYERED;
end;
procedure TUxClientLayer.CreateWnd;
begin
inherited;
SetLayeredWindowAttributes(Handle, 0, 128, LWA_ALPHA);
end;
constructor TPanelClassRec.Create(const AName: string;
const AExts: TArray<string>; const AFormClass: TCustomFormClass;
const AClassLevel: Integer);
begin
Name := AName;
Exts := AExts;
FormClass := AFormClass;
ClassLevel := AClassLevel;
end;
constructor TUxDockSite.Create(AOwner: TComponent);
begin
inherited;
FOwnerCtl := AOwner as TWinControl;
if not Supports(FOwnerCtl, IUxDockSite, FDockSite) then
raise Exception.Create('TUxDockSite.Create: Owner doesn''t implement IUxDockSite.');
FInsertionPoint := -1;
FInsertionPointAnimator := TTimer.Create(Self);
FInsertionPointAnimator.Enabled := False;
FInsertionPointAnimator.Interval := GetCaretBlinkTime;
FInsertionPointAnimator.OnTimer := InsertionPointAnimatorTimer;
end;
function TUxDockSite.DragEnter(const dataObj: IDataObject; grfKeyState: Integer;
pt: TPoint; var dwEffect: Integer): HRESULT;
begin
try
TUxContainer.BeginLayout;
except
on E: Exception do
PanelLog('TUxDockSite.DragEnter: TUxContainer.BeginLayout exception: ', E);
end;
FDragDataObject := dataObj;
dwEffect := GetDropEffect;
FInsertionPoint := FDockSite.FindInsertionPoint(FOwnerCtl.ScreenToClient(pt));
FInsertionPointAnimationStep := False;
if Assigned(FInsertionPointAnimator) then
FInsertionPointAnimator.Enabled := True;
FOwnerCtl.Invalidate;
Result := S_OK;
end;
function TUxDockSite.DragLeave: HRESULT;
begin
FDragDataObject := nil;
FInsertionPoint := -1;
if Assigned(FInsertionPointAnimator) then
FInsertionPointAnimator.Enabled := False;
FOwnerCtl.Invalidate;
Result := S_OK;
try
TUxContainer.EndLayout;
except
on E: Exception do
PanelLog('TUxDockSite.DragLeave: TUxContainer.EndLayout exception: ', E);
end;
end;
function TUxDockSite.DragOver(grfKeyState: Integer; pt: TPoint;
var dwEffect: Integer): HRESULT;
begin
dwEffect := GetDropEffect;
FInsertionPoint := FDockSite.FindInsertionPoint(FOwnerCtl.ScreenToClient(pt));
FOwnerCtl.Invalidate;
Result := S_OK;
end;
function TUxDockSite.Drop(const dataObj: IDataObject; grfKeyState: Integer;
pt: TPoint; var dwEffect: Integer): HRESULT;
begin
try
try
Result := S_OK;
dwEffect := GetDropEffect;
var medium := Default(TStgMedium);
if dataObj.GetData(FORMATETC_ASPANEL, medium) = S_OK then
begin
try
if medium.tymed = TYMED_HGLOBAL then
begin
var LData: PPanelOleRec := GlobalLock(medium.hGlobal);
if Assigned(LData) then
try
if LData.Sign = PanelOleHeader then
begin
if LData.PID = GetCurrentProcessId then
begin
if Assigned(TUxPanel.Instances) then
for var LInstance in TUxPanel.Instances do
if LInstance = LData.Obj then
begin
if LInstance.Parent = FOwnerCtl then
FDockSite.MovePanel(LInstance, FInsertionPoint)
else
begin
if LInstance.Parent is TUxContainer then
TUxContainer(LInstance.Parent).RemovePanel(LInstance)
else
LInstance.Parent := nil;
FDockSite.InsertPanel(LInstance, FInsertionPoint);
end;
Break;
end;
end;
end
else
Result := E_UNEXPECTED;
finally
GlobalUnlock(medium.hGlobal);
end;
end
else
Result := E_UNEXPECTED;
finally
ReleaseStgMedium(medium);
end;
end
else if dataObj.GetData(FORMATETC_UNICODETEXT, medium) = S_OK then
begin
try
if medium.tymed = TYMED_HGLOBAL then
begin
var LData: PChar := GlobalLock(medium.hGlobal);
if Assigned(LData) then
try
var LPnl := TUxPanel.CreateWith('Text editor');
FDockSite.InsertPanel(LPnl, FInsertionPoint);
var LEd: TTextEditorForm;
if LPnl.TryGetMainChild<TTextEditorForm>(LEd) then
begin
LEd.Editor.PlainText := LData;
LEd.Editor.TextFile.ClearUndoHistory;
LEd.Editor.TextFile.AddUndoRecord(SUndoMouseCopyExtSrc, UID_DRAGDROP);
end;
finally
GlobalUnlock(medium.hGlobal);
end
else
Result := E_UNEXPECTED;
end
else
Result := E_UNEXPECTED;
finally
ReleaseStgMedium(medium);
end;
end
else if dataObj.GetData(FORMATETC_HDROP, medium) = S_OK then
begin
try
if medium.tymed = TYMED_HGLOBAL then
begin
var LData: Pointer := GlobalLock(medium.hGlobal);
if Assigned(LData) then
try
const LFileCount = DragQueryFile(NativeUInt(LData), $FFFFFFFF, nil, 0);
if LFileCount > 0 then
begin
SetLength(FDropList, LFileCount);
for var i := 0 to LFileCount - 1 do
begin
const LSize = DragQueryFile(NativeUInt(LData), i, nil, 0);
var LFileName := '';
SetLength(LFileName, LSize + 1);
var LLen := DragQueryFile(NativeUInt(LData), i, PChar(LFileName), LFileName.Length);
if LLen < Cardinal(LFileName.Length) then
SetLength(LFileName, LLen);
FDropList[i] := LFileName;
end;
if FDropListTimer = nil then
begin
FDropListTimer := TTimer.Create(Self);
FDropListTimer.OnTimer := DropListTimerTimer;
FDropListTimer.Interval := 100;
end;
FDropListTimer.Tag := FInsertionPoint;
FDropListTimer.Enabled := True;
end;
finally
GlobalUnlock(medium.hGlobal);
end
else
Result := E_UNEXPECTED;
end
else
Result := E_UNEXPECTED;
finally
ReleaseStgMedium(medium);
end;
end
else
Result := E_UNEXPECTED;
FInsertionPoint := -1;
FOwnerCtl.Invalidate;
except
on E: Exception do
begin
PanelLog('TUxDockSite.Drop: ', E);
Result := E_UNEXPECTED;
end;
end;
finally
TUxContainer.EndLayout;
end;
end;
procedure TUxDockSite.DropListTimerTimer(Sender: TObject);
begin
if FDropListTimer = nil then
Exit;
if Sender <> FDropListTimer then
Exit;
FDropListTimer.Enabled := False;
for var LFileName in FDropList do
begin
const LExt = ExtractFileExt(LFileName).Trim(['.']).ToLower;
var LFormClass: TCustomFormClass := TUxPanel.PanelClassFromName('Text editor', TTextEditorForm);
for var LPanelClass in TUxPanel.FPanelClasses do
if IndexStr(LExt, LPanelClass.Value.Exts) <> -1 then
begin
LFormClass := LPanelClass.Value.FormClass;
Break;
end;
var LPanel := TUxPanel.CreateWith(LFormClass);
FDockSite.InsertPanel(LPanel, FDropListTimer.Tag);
var LPanelForm := TPanelForm(nil);
if LPanel.TryGetMainChild<TPanelForm>(LPanelForm) then
LPanelForm.LoadFromFile(LFileName);
end;
FDropList := nil;
end;
function TUxDockSite.GetDropEffect: Integer;
begin
if Assigned(FDragDataObject) and (FDragDataObject.QueryGetData(FORMATETC_ASPANEL) = S_OK) then
Result := DROPEFFECT_MOVE
else if Assigned(FDragDataObject) and (FDragDataObject.QueryGetData(FORMATETC_UNICODETEXT) = S_OK) then
Result := DROPEFFECT_COPY
else if Assigned(FDragDataObject) and (FDragDataObject.QueryGetData(FORMATETC_HDROP) = S_OK) then
Result := DROPEFFECT_COPY
else
Result := DROPEFFECT_NONE;
end;
procedure TUxDockSite.InsertionPointAnimatorTimer(Sender: TObject);
begin
if FInsertionPoint = -1 then
begin
if Assigned(FInsertionPointAnimator) then
FInsertionPointAnimator.Enabled := False;
Exit;
end;
FInsertionPointAnimationStep := not FInsertionPointAnimationStep;
if Assigned(FOwnerCtl) then
FOwnerCtl.Invalidate;
end;
procedure RegisterPanelClass(AClass: TCustomFormClass);
begin
end;
constructor TScaleMonitor.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited;
FTimer := TTimer.Create(Self);
FTimer.Interval := 100;
FTimer.OnTimer := ScaleTimerTimer;
FLabel := TLabel.Create(Self);
FLabel.Parent := Self;
FLabel.Align := alClient;
FLabel.Alignment := taCenter;
FLabel.Layout := tlCenter;
FLabel.OnClick := FocusSender;
end;
class function TScaleMonitor.IsDisposable: Boolean;
begin
Result := True;
end;
procedure TScaleMonitor.ScaleTimerTimer(Sender: TObject);
begin
if Assigned(FLabel) then
FLabel.Caption := PixelsPerInch.ToString + ' ppi'#13#10 + FScaleFactor.ToString;
end;
class function TObjBrowser.GetColumns: TArray<TListForm.TColumnRec>;
begin
Result :=
[
CR('Type', 200, csmText),
CR('Class', 200, csmText),
CR('Name', 200, csmText)
];
end;
class function TObjBrowser.GetData: TArray<TListForm.TDataRow>;
begin
if Assigned(TUxPanel.Instances) then
for var LInst in TUxPanel.Instances do
begin
var LMainChild := TCustomForm(nil);
var LMainChildClassName := '';
if LInst.TryGetMainChild<TCustomForm>(LMainChild) then
LMainChildClassName := LMainChild.ClassName;
Result := Result + [DataRow(['TUxPanel', LInst.ClassName + '>' + LMainChildClassName, LInst.Caption], NativeUInt(LInst))];
end;
if Assigned(TUxForm.FInstances) then
for var LInst in TUxForm.FInstances do
Result := Result + [DataRow(['TUxForm', LInst.ClassName, LInst.Caption], NativeUInt(LInst))];
if Assigned(TUxContainer.Instances) then
for var LInst in TUxContainer.Instances do
Result := Result + [DataRow(['TUxContainer', LInst.ClassName, LInst.Caption], NativeUInt(LInst))];
if Assigned(TManagedVisCtl2D.Instances) then
for var LInst in TManagedVisCtl2D.Instances do
Result := Result + [DataRow(['TManagedVisCtl2D', LInst.Value.ClassName, LInst.Key], NativeUInt(LInst.Value))];
if Assigned(TManagedVisCtl3D.Instances) then
for var LInst in TManagedVisCtl3D.Instances do
Result := Result + [DataRow(['TManagedVisCtl3D', LInst.Value.ClassName, LInst.Key], NativeUInt(LInst.Value))];
end;
procedure TObjBrowser.PopupMenuPopup(Sender: TObject);
begin
inherited;
if Assigned(FmiDefault) then
FmiDefault.Visible := False;
if Assigned(FmiDelete) then
FmiDelete.Visible := False;
end;
function TObjBrowser.RowIdentity: TListForm.TRowIdentity;
begin
Result := riData;
end;
procedure TCustomSubmenuItem.Click;
begin
inherited;
if Parent is TCustomSubmenu then
TCustomSubmenu(Parent).Handler(TCustomSubmenu(Parent), CmdID, ObjRef, GUID);
end;
constructor TCustomSubmenuItem.CreateAndInit(AOwner: TComponent;
const AData: TMenuItemRec);
begin
inherited Create(AOwner);
Caption := AData.Caption;
Hint := AData.Hint;
Enabled := AData.Enabled;
Checked := AData.Checked;
RadioItem := AData.RadioItem;
CmdID := AData.CmdID;
ObjRef := AData.ObjRef;
GUID := AData.GUID;
OnClick := DummyClick;
end;
procedure TCustomSubmenuItem.DummyClick(Sender: TObject);
begin
end;
procedure TCustomSubmenu.Click;
begin
inherited;
for var i := Count - 1 downto 1 do
Delete(i);
if Assigned(Ctor) then
begin
var LMenuItems := Ctor();
for var LMenuItem in LMenuItems do
Add(TCustomSubmenuItem.CreateAndInit(Self, LMenuItem));
end;
end;
procedure TPopupMenu2.Popup(X, Y: Integer);
const
Flags: array[Boolean, TPopupAlignment] of Word =
((TPM_LEFTALIGN, TPM_RIGHTALIGN, TPM_CENTERALIGN),
(TPM_RIGHTALIGN, TPM_LEFTALIGN, TPM_CENTERALIGN));
Buttons: array[TTrackButton] of Word = (TPM_RIGHTBUTTON, TPM_LEFTBUTTON);
var
AFlags: Integer;
begin
if (Tag = STARTMENU_TAG) and InRange(RTLVersion, 33, 35) then
begin
DoPrePopupWork(X, Y);
AFlags := Flags[UseRightToLeftAlignment, Alignment] or Buttons[TrackButton] or
(Byte(MenuAnimation) shl 10) or TPM_BOTTOMALIGN;
TrackPopupMenu(Items.Handle, AFlags, X, Y, 0 , PopupList.Window, nil);
DoClose;
end
else
inherited;
end;
procedure TPopupMenuHelper.DoPrePopupWork(X, Y: Integer);
begin
SetPopupPoint(Point(X, Y));
with Self do SetBiDiModeFromPopupControl;
DoPopup(Self);
Items.DoPrePopupWork;
AdjustBiDiBehavior;
end;
procedure TMenuItemHelper.DoPrePopupWork;
begin
with Self do
begin
InternalRethinkHotkeys(False);
InternalRethinkLines(False);
RebuildHandle;
end;
end;
procedure TUxLayoutPanel.AddPanels(L: TList<TUxLayoutPanel>);
begin
if Assigned(L) then
L.Add(Self);
end;
constructor TUxLayoutPanel.Create(const APanelClassName: string);
begin
PanelClassName := APanelClassName;
end;
procedure TUxLayoutStack.AddPanels(L: TList<TUxLayoutPanel>);
begin
if Assigned(Items) then
for var LItem in Items do
LItem.AddPanels(L);
end;
constructor TUxLayoutStack.Create(AOrientation: TUxContainerOrientation);
begin
Orientation := AOrientation;
Items := TObjectList<TUxLayoutItem>.Create;
end;
destructor TUxLayoutStack.Destroy;
begin
FreeAndNil(Items);
inherited;
end;
procedure TUxLayoutItem.AddPanels(L: TList<TUxLayoutPanel>);
begin
end;
function TUxLayoutItem.Panels: TArray<TUxLayoutPanel>;
begin
var L := TList<TUxLayoutPanel>.Create;
try
AddPanels(L);
Result := L.ToArray;
finally
L.Free;
end;
end;
procedure TUxLabel.Paint;
begin
Font.PixelsPerInch := 96;
Font.Size := ScaleValue(9);
Canvas.Font.PixelsPerInch := 96;
Canvas.Font.Size := ScaleValue(9);
inherited;
end;
initialization
GInvFS := TFormatSettings.Invariant;
GInvFS_Pretty := TFormatSettings.Invariant;
GInvFS_Pretty.ThousandSeparator := #$2009;
RegisterPanelClass(TWndMgrForm);
RegisterPanelClass(TUxColorForm);
RegisterPanelClass(TTextEditorForm);
RegisterPanelClass(TImageViewerForm);
RegisterPanelClass(TCharacterBrowser);
RegisterPanelClass(TDbgLogForm);
RegisterPanelClass(TClockForm);
RegisterPanelClass(TScaleMonitor);
RegisterPanelClass(TObjBrowser);
end.