/// Grid to display database content for mORMot // - this unit is a part of the freeware mORMot framework, // licensed under a MPL/GPL/LGPL tri-license; version 1.18 unit mORMotUI; (* This file is part of Synopse mORMot framework. Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** Version: MPL 1.1/GPL 2.0/LGPL 2.1 The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is Synopse mORMot framework. The Initial Developer of the Original Code is Arnaud Bouchez. Portions created by the Initial Developer are Copyright (C) 2020 the Initial Developer. All Rights Reserved. Contributor(s): - kevinday - MartinEckes Alternatively, the contents of this file may be used under the terms of either the GNU General Public License Version 2 or later (the "GPL"), or the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), in which case the provisions of the GPL or the LGPL are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of either the GPL or the LGPL, and not to allow others to use your version of this file under the terms of the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the GPL or the LGPL. If you do not delete the provisions above, a recipient may use your version of this file under the terms of any one of the MPL, the GPL or the LGPL. ***** END LICENSE BLOCK ***** Fill a TDrawGrid with data from our database engine ***************************************************** - associate TSQLTable content to a TDrawGrid - display UTF-8 values with true unicode characters - column size is calculated from data size - field sort by left/right arrow keys or clicking on first row - incremental key lookup for direct search inside displayed values - Ctrl + click on a cell to display its full unicode content - ID column can be hidden on demand, but IDs still remaining in memory Initial version: 2008 March, by Arnaud Bouchez Version 1.4 - February 8, 2010 - whole Synopse SQLite3 database framework released under the GNU Lesser General Public License version 3, instead of generic "Public Domain" Version 1.5 - February 19, 2010 - User Interface Query action implementation Version 1.8 - added TSynIntegerLabeledEdit component (e.g. used in SQLite3UIOptions) Version 1.9 - improved Delphi 2009/2010 UnicodeString compatibility - fix some issues, and complete implementation of marking from time elapsed Version 1.9.2 - new ForceRefresh parameter to the TSQLTableToGrid.Refresh method Version 1.13 - now compiles with Delphi 6 - new TSQLTableToGrid.SelectedRecordCreate method - added generic TSynLabeledEdit to handle Integer, Int64, Currency and double kind of values Version 1.14 - fixed issue with MaxValue if RangeChecking not enabled Version 1.15 - compatibility with Delphi XE2 - new TSQLTableToGrid.SetFieldFixedWidth method - new TSQLTableToGrid.FieldTitleTruncatedNotShownAsHint property - fixed issue on TDrawGrid events when TSQLTableToGrid is destroyed Version 1.16 - new FillStringGrid() function, ready to fill a regular TStringGrid - includes new TSynAnsiConvert classes for handling Ansi charsets Version 1.17 - global functions AddApplicationToFirewall() and AddPortToFirewall() are now compatible with Windows XP, Vista and Seven - renamed on purpose Version 1.18 - renamed SQLite3UI.pas to mORMotUI.pas - introducing TSQLPropInfo* classes to decouple ORM definitions from RTTI - fix TSynLabeledEdit.IsValid for currency kind of values - ensure TSQLTableToGrid.Create() uses TDrawGrid font to compute row height - new TSQLTableToGrid.Aligned[] property: replace former SetCentered() method, allowing right cell alignment - and associated SetAligned() / SetAlignedByType() methods as expected by feature request [749dfbdb6a] - new TSQLTableToGrid.CustomFormat[] format, for custom numerical or date/time mask - and associated SetCustomFormatByType() methods - added TSQLTableToGrid.HeaderCheckboxSelectsInsteadOfSort property to toggle global selection instead of sorting the marked items first - see feature request [a41b5dd805] - added AutoResizeColumns optional parameter to TSQLTableToGrid.Refresh() - see feature request [c2e1ff324b] - added TSQLTableToGrid.OnSort event handler - see request [bffff9b4c3] - added some values to TSQLAction - thanks kevinday for the patch - get rid of mORMoti18n dependency *) interface {$I Synopse.inc} uses {$ifdef MSWINDOWS} Windows, {$endif MSWINDOWS} {$ifdef FPC} LCLType, LCLProc, LCLIntf, LMessages, {$endif FPC} Types, DateUtils, SynCommons, mORMot, SysUtils, Classes, Messages, Variants, {$ifdef WITHUXTHEME} Themes, {$endif WITHUXTHEME} Graphics, StdCtrls, Controls, Grids, Buttons, ExtCtrls, Forms; type /// a THintWindow descendant, with an internal delay to auto-hide // - this component can be used directly with the hint text to be displayed // (companion to the controls Hint properties and Application.ShowHint) // - you can specify a time interval for the popup window to be hidden // - this component expects UTF-8 encoded text, and displays it as Unicode THintWindowDelayed = class(THintWindow) private fRow: integer; fCol: integer; protected fTimerEnabled: boolean; fFontColor: TColor; fUTF8Text: RawUTF8; /// called after a Hide call procedure VisibleChanging; override; /// used to hide the popup hint after a delay {$ifdef FPC} procedure WMTimer(var Message: TLMTimer); message LM_TIMER; {$else} procedure WMTimer(var Msg: TWMTimer); message WM_TIMER; {$endif} /// overridden method, Unicode ready procedure Paint; override; public /// initializes the component constructor Create(aOwner: TComponent); override; /// releases component resources and memory destructor Destroy; override; /// displays the appropriate Hint Text at a specified screen position // - Text is decoded from UTF-8 to Unicode before display // - Time is the maximum text display delay, in milliseconds procedure ShowDelayedUTF8(const Text: RawUTF8; X,Y,Time: integer; FontColor: TColor; AlignLeft: boolean=false); overload; /// displays the appropriate Hint Text at a position relative to a control // - Text is decoded from UTF-8 to Unicode before display // - Time is the maximum text display delay, in milliseconds procedure ShowDelayedUTF8(const Text: RawUTF8; Origin: TControl; X,Y,Time: integer; FontColor: TColor; AlignLeft: boolean=false); overload; /// displays the appropriate Hint Text at a specified screen position // - if string is AnsiString (i.e. for Delphi 2 to 2007), Text is decoded into // Unicode (using the current i18n code page) before display // - Time is the maximum text display delay, in milliseconds procedure ShowDelayedString(const Text: string; X,Y,Time: integer; FontColor: TColor; AlignLeft: boolean=false); overload; {$ifdef HASINLINE}inline;{$endif} /// displays the appropriate Hint Text at a position relative to a control // - Text is decoded from Ansi to Unicode (using the current i18n code page) before display // - Time is the maximum text display delay, in milliseconds procedure ShowDelayedString(const Text: string; Origin: TControl; X,Y,Time: integer; FontColor: TColor; AlignLeft: boolean=false); overload; {$ifdef HASINLINE}inline;{$endif} /// overridden method, Unicode ready function CalcHintRect(MaxWidth: Integer; const AHint: RawUTF8; AData: Pointer): TRect; reintroduce; /// the column number when the hint is displayed property Col: integer read fCol; /// the row number when the hint is displayed property Row: integer read fRow; end; /// kind of event used to change some text on the fly for grid display // - expect generic string Text, i.e. UnicodeString for Delphi 2009/2010, // ready to be used with the VCL for all Delphi compiler versions // - if the cell at FiieldIndex/RowIndex is to have a custom content, // shall set the Text variable content and return TRUE // - if returns FALSE, the default content will be displayed TValueTextEvent = function(Sender: TSQLTable; FieldIndex, RowIndex: Integer; var Text: string): boolean of object; /// kind of event used to change some text on the fly for popup hint // - expect generic string Text, i.e. UnicodeString for Delphi 2009/2010, // ready to be used with the VCL for all Delphi compiler versions THintTextEvent = function(Sender: TSQLTable; FieldIndex, RowIndex: Integer; var Text: string): boolean of object; /// kind of event used to display a menu on a cell right click TRightClickCellEvent = procedure(Sender: TSQLTable; ACol, ARow, MouseX, MouseY: Integer) of object; /// the available alignments of a TSQLTableToGrid cell TSQLTableToGridAlign = (alLeft, alCenter, alRight); /// a hidden component, used for displaying a TSQLTable in a TDrawGrid // - just call TSQLTableToGrid.Create(Grid,Table) to initiate the association // - the Table will be released when no longer necessary // - any former association by TSQLTableToGrid.Create() will be overridden // - handle unicode, column size, field sort, incremental key lookup, hide ID // - Ctrl + click on a cell to display its full unicode content TSQLTableToGrid = class(TComponent) private {$ifdef FPC} fOnSelectCell: TOnSelectCellEvent; {$else} fOnSelectCell: TSelectCellEvent; {$endif} fOnRightClickCell: TRightClickCellEvent; fClient: TSQLRestClientURI; {$ifdef FPC} fOnDrawCellBackground: TOnDrawCell; {$else} fOnDrawCellBackground: TDrawCellEvent; {$endif} fMarked: TByteDynArray; fMarkAllowed: boolean; fMouseDownMarkedValue: (markNone,markOn,markOff); fTruncAsHint: Boolean; fHeaderCheckboxSelectsInsteadOfSort: Boolean; fOnSelectCellProcessing: boolean; fFieldIndexTimeLogForMark: integer; function GetMarked(RowIndex: integer): boolean; procedure SetMarked(RowIndex: integer; const Value: boolean); function GetMarkAvailable: boolean; function GetDrawGrid: TDrawGrid; function GetMarkedIsOnlyCurrrent: boolean; function GetMarkedTotalCount: integer; // function because field information may be set manually after Create function GetFieldIndexTimeLogForMark: integer; function GetAlign(aCol: cardinal): TSQLTableToGridAlign; procedure SetAlign(aCol: cardinal; Value: TSQLTableToGridAlign); function GetCustomFormat(aCol: cardinal): string; procedure SetCustomFormat(aCol: cardinal; const Value: string); function GetGridColumnWidths: RawUTF8; procedure SetGridColumnWidths(const Value: RawUTF8); protected fOnValueText: TValueTextEvent; fOnHintText: THintTextEvent; fOnSort: TNotifyEvent; /// associated TSQLTable result to be displayed fTable: TSQLTable; /// true if the specific field is in Ascending order fFieldOrder: array of boolean; /// current field number used for field fCurrentFieldOrder: integer; /// avoid resizing columns on height change only fLastWidth: cardinal; /// contain the key to be searched fIncrementalSearch: RawUTF8; /// true if row is changed by incremental key lookup fIncrementalSearchMove: boolean; /// used to display some hint text fHint: THintWindowDelayed; /// text of this field must be aligned as set by Aligned[] property fAligned: array of TSQLTableToGridAlign; /// custom formats as set by CustomFormat[] property fCustomFormat: array of string; /// text of this column/field name has been truncated fFieldNameTruncated: Int64; /// used by OnTableUpdate() event fOnTableUpdateID: TIDDynArray; /// return true if a GPF may occur function NotDefined: boolean; public /// fill a TDrawGrid with the results contained in a TSQLTable constructor Create(aOwner: TDrawGrid; aTable: TSQLTable; aClient: TSQLRestClientURI); reintroduce; /// release the hidden object // - will be called by the parent Grid when it is destroyed // - will be called by any future TSQLTableToGrid.Create() association // - free the associated TSQLTable and its memory content // - will reset the Grid overridden events to avoid GPF destructor Destroy; override; /// called by the owner TDrawGrid to draw a Cell from the TSQLTable data // - the cell is drawn using direct Win32 Unicode API // - the first row (fixed) is drawn as field name (centered bold text with // sorting order displayed with a triangular arrow) procedure DrawCell(Sender: TObject; ACol, ARow: Longint; Rect: TRect; State: TGridDrawState); /// called by the owner TDrawGrid when a Cell is selected procedure DrawGridSelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean); /// called by the owner TDrawGrid when a Cell is clicked by the mouse // - check if the first (fixed) row is clicked: then change sort order // - Ctrl + click to display its full unicode content (see HintText to customize it) procedure DrawGridMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); /// called by the owner TDrawGrid when the mouse is unclicked over a Cell procedure DrawGridMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); /// called by the owner TDrawGrid when the mouse is over a Cell procedure DrawGridMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); /// called by the owner TDrawGrid when the user presses a key // - used for incremental key lookup procedure DrawGridKeyPress(Sender: TObject; var Key: Char); /// called by the owner TDrawGrid when the user presses a key // - used for LEFT/RIGHT ARROW column order change procedure DrawGridKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); /// call this procedure to automaticaly resize the TDrawString columns // - can be used as TSQLTableToGrid.From(DrawGrid).Resize(); procedure Resize(Sender: TObject); /// display a popup Hint window at a specified Cell position // - expect generic string Text, i.e. UnicodeString for Delphi 2009/2010, // ready to be used with the VCL for all Delphi compiler versions procedure ShowHintString(const Text: string; ACol, ARow, Time: integer; FontColor: TColor=clBlack); /// if the ID column is available, hides it from the grid procedure IDColumnHide; /// toggle the sort order of a specified column procedure SortChange(ACol: integer); /// set a specified column for sorting // - if ACol=-1, then the Marked[] rows are shown first, in current sort procedure SortForce(ACol: integer; Ascending: boolean; ARow: integer=-1); /// get the ID of the first selected row, 0 on error (no ID field e.g.) // - useful even if ID column was hidden with IDColumnHide function SelectedID: TID; /// retrieve the record content of the first selected row, nil on error // - record type is retrieved via Table.QueryTables[0] (if defined) // - warning: it's up to the caller to Free the created instance after use // (you should e.g. embedd the process in a try...finally block): // ! Rec := Grid.SelectedRecordCreate; // ! if Rec<>nil then // ! try // ! DoSomethingWith(Rec); // ! finally // ! Rec.Free; // ! end; // - useful even if ID column was hidden with IDColumnHide function SelectedRecordCreate: TSQLRecord; /// set individual column alignment property Aligned[aCol: cardinal]: TSQLTableToGridAlign read GetAlign write SetAlign; /// set columns number which must be aligned to non default left layout // - a faster overload to Aligned[] property procedure SetAligned(const aCols: array of cardinal; aAlign: TSQLTableToGridAlign); /// set column alignment for a given type // - a faster overload to Aligned[] property procedure SetAlignedByType(aFieldType: TSQLFieldType; aAlign: TSQLTableToGridAlign); /// set individual column custom format // - as handled by TSQLTable.ExpandAsString() method, i.e. Format() or // FormatFloat()/FormatCurrency() mask for sftFloat or sftCurrency, or // FormatDateTime() mask for sftDateTime, sftDateTimeMS, sftTimeLog, sftModTime, // sftCreateTime, sftUnixTime, sftUnixMSTime) property CustomFormat[aCol: cardinal]: string read GetCustomFormat write SetCustomFormat; /// set a custom format for all columns of a given type // - a faster overload to CustomFormat[] property // - only support the field types and formats handled by CustomFormat[] property procedure SetCustomFormatByType(aFieldType: TSQLFieldType; const aCustomFormat: string); /// force the mean of characters length for every field // - supply a string with every character value is proportionate to // the corresponding column width // - if the character is lowercase, the column is set as centered // - if aMarkAllowed is set, a first checkbox column is added, for // reflecting and updating the Marked[] field values e.g. // - if Lengths='', will set some uniform width, left aligned procedure SetFieldLengthMean(const Lengths: RawUTF8; aMarkAllowed: boolean); /// force all columns to have a specified width, in pixels procedure SetFieldFixedWidth(aColumnWidth: integer); /// force refresh paint of Grid from Table data // - return true if Table data has been successfully retrieved from Client // and if data was refreshed because changed since last time // - if ForceRefresh is TRUE, the Client is not used to retrieve the data, // which must be already refreshed before this call // - if AutoResizeColumns is TRUE, the column visual width will be re-computed // from the actual content - set it to FALSE to avoid it function Refresh(ForceRefresh: Boolean=false; AutoResizeColumns: Boolean=true): boolean; /// call this procedure after a refresh of the data // - current Row will be set back to aID // - called internal by Refresh function above procedure AfterRefresh(const aID: TID; AutoResizeColumns: boolean); /// you can call this method when the list is no more on the screen // - it will hide any pending popup Hint windows, for example procedure PageChanged; /// perform the corresponding Mark/Unmark[All] Action procedure SetMark(aAction: TSQLAction); /// retrieve the Marked[] bits array function GetMarkedBits: pointer; /// read-only access to a particular row values, as VCL text // - Model is one TSQLModel instance (used to display TRecordReference) // - returns the text as generic string, ready to be displayed via the VCL // after translation, for sftEnumerate, sftTimeLog, sftRecord and all other // properties // - uses OnValueText property Event if defined by caller function ExpandRowAsString(Row: integer; Client: TObject): string; /// retrieve the associated TSQLTableToGrid from a specific TDrawGrid class function From(Grid: TDrawGrid): TSQLTableToGrid; /// used by TSQLRestClientURI.UpdateFromServer() to let the client // perform the rows update (for Marked[]) procedure OnTableUpdate(State: TOnTableUpdateState); /// associated TDrawGrid // - just typecast the Owner as TDrawGrid property DrawGrid: TDrawGrid read GetDrawGrid; /// associated TSQLTable to be displayed property Table: TSQLTable read fTable; /// associated Client used to retrieved the Table data property Client: TSQLRestClientURI read fClient; /// used to display some hint text property Hint: THintWindowDelayed read fHint; /// assign an event here to customize the background drawing of a cell {$ifdef FPC} property OnDrawCellBackground: TOnDrawCell read fOnDrawCellBackground write fOnDrawCellBackground; {$else} property OnDrawCellBackground: TDrawCellEvent read fOnDrawCellBackground write fOnDrawCellBackground; {$endif} /// true if Marked[] is available (add checkboxes at the left side of every row) property MarkAllowed: boolean read fMarkAllowed; /// true if any Marked[] is checked property MarkAvailable: boolean read GetMarkAvailable; /// true if only one entry is in Marked[], and it is the current one property MarkedIsOnlyCurrrent: boolean read GetMarkedIsOnlyCurrrent; /// returns the number of item marked or selected // - if no item is marked, it return 0 even if a row is currently selected property MarkedTotalCount: integer read GetMarkedTotalCount; /// retrieves if a row was previously marked // - first data row index is 1 property Marked[RowIndex: integer]: boolean read GetMarked write SetMarked; /// retrieve or define the column widths of this grid, as text // - as a CSV list of the associated DrawGrid.ColWidths[] values property GridColumnWidths: RawUTF8 read GetGridColumnWidths write SetGridColumnWidths; /// retrieves the index of the sftTimeLog first field // - i.e. the field index which can be used for Marked actions // - equals -1 if not such field exists property FieldIndexTimeLogForMark: integer read GetFieldIndexTimeLogForMark; /// current field number used for current table sorting property CurrentFieldOrder: integer read fCurrentFieldOrder; /// set to FALSE to display the column title as hint when truncated on screen property FieldTitleTruncatedNotShownAsHint: boolean read fTruncAsHint write fTruncAsHint; /// set to TRUE to let the header check box select/unselect all rows // instead of sorting them // - may be more conventional use of this header check box property HeaderCheckboxSelectsInsteadOfSort: boolean read fHeaderCheckboxSelectsInsteadOfSort write fHeaderCheckboxSelectsInsteadOfSort; /// override this event to customize the text display in the table property OnValueText: TValueTextEvent read fOnValueText write fOnValueText; /// override this event to customize the Ctrl+Mouse click popup text property OnHintText: THintTextEvent read fOnHintText write fOnHintText; /// override this event to customize the Mouse click on a data cell {$ifdef FPC} property OnSelectCell: TOnSelectCellEvent read fOnSelectCell write fOnSelectCell; {$else} property OnSelectCell: TSelectCellEvent read fOnSelectCell write fOnSelectCell; {$endif} /// override this event to customize the Mouse right click on a data cell property OnRightClickCell: TRightClickCellEvent read fOnRightClickCell write fOnRightClickCell; /// override this event to be notified when the content is sorted property OnSort: TNotifyEvent read fOnsort write fOnsort; end; type /// exception class raised by TSynIntegerLabeledEdit ESynLabeledEdit = class(Exception); /// diverse kind of values which may be edited by a TSynLabeledEdit TSynLabeledEditKind = (sleInteger, sleInt64, sleCurrency, sleDouble); /// TLabeledEdit with optional boundaries check of a Variant value TSynLabeledEdit = class(TLabeledEdit) protected FMaxValue: Variant; FMinValue: Variant; FAdditionalHint: string; FKind: TSynLabeledEditKind; FRangeChecking: boolean; function IsValid(const Txt: string; var ToValue: Variant): Boolean; procedure SetValue(const Value: Variant); function GetValue: Variant; procedure KeyPress(var Key: char); override; procedure MouseMove(Shift: TShiftState; X, Y: integer); override; public /// if true, GetValue() will raise an ESynVariantLabeledEdit exception on // any Variant value range error, when the Value property is read RaiseExceptionOnError: boolean; /// convert the entered Variant value into a textual representation function ToString(NumberOfDigits: integer): string; reintroduce; /// return TRUE if the entered value is inside the boundaries function ValidateValue: boolean; /// create the component instance constructor Create(AOwner: TComponent); override; published /// the kind of value which is currently edited by this TSynLabeledEdit property Kind: TSynLabeledEditKind read fKind write fKind default sleInteger; /// the entered value // - getting this property will check for in range according to the // current MinValue/MaxValue boundaries, if RangeChecking is set // - if RangeChecking is not set, could return a NULL variant for no data // - it will sound a beep in case of any out of range // - it will also raise a ESynVariantLabeledEdit exception if // RaiseExceptionOnError is set to TRUE (equals FALSE by default) property Value: Variant read GetValue write SetValue; /// set to TRUE if MinValue/MaxValue properties must be checked when // reading Value property property RangeChecking: boolean read fRangeChecking write fRangeChecking; /// lowest allowed Variant value property MinValue: Variant read FMinValue write FMinValue; /// highest allowed Variant value property MaxValue: Variant read FMaxValue write FMaxValue; /// some additional popup hint to be displayed // - by default, the allowed range is displayed: 'Min. Value: #, Max. Value: #' // - you can specify here some additional text to be displayed when the mouse // is hover the component property AdditionalHint: string read FAdditionalHint write FAdditionalHint; end; /// allow to track and load/save UI components as JSON // - may be used to persist TEdit / TCheckBox / TComboBox values on a form // when the application leaves TUIComponentsPersist = class protected fTracked: array of TComponent; fFileName: TFileName; fLoadedJson: RawUTF8; function GetFileName: TFileName; public /// would track .Text and .Checked properties only procedure TrackControls(const ctrls: array of TComponent); /// fill all tracked controls properties from the supplied JSON object procedure LoadFromVariant(const aDoc: variant); /// save all tracked controls properties as a JSON object function SaveToVariant: variant; /// fill all tracked controls properties from a local JSON file procedure LoadFromFile; /// save all tracked controls properties as JSON in a local file procedure SaveToFile; /// the local JSON file used for persistence // - is set to 'executablename.default' if none is specified property FileName: TFileName read GetFileName write fFileName; end; /// register the TSynIntegerLabeledEdit component in the IDE toolbar // - not necessary for the mORMot framework to run: since all User Interface // is created from code, and not from the Delphi IDE, you don't have to register // anything unless you define your own forms including those components procedure Register; resourcestring SErrorFieldNotValid = 'Field "%s"'#13'does not contain a valid %s value'; SErrorFieldTooSmall = 'Field "%s"'#13'is too small, value must be >= %s'; SErrorFieldTooLarge = 'Field "%s"'#13'is too large, value must be <= %s'; SMinMaxValue = 'Min. Value: %s, Max. Value: %s'; {$ifndef FPC} {$define VISTAFORM} {$endif} {$ifdef VISTAFORM} {$R SQLite3UI.RES} type /// Vista-enabled TForm descendant // - this form will have a button in the TaskBar // - this form will hide the default Delphi application virtual form // - this form can be with no caption bar using SetNoCaption method TVistaForm = class(TForm) protected fNoCaption: TPanel; fNoCaptionLabel: TLabel; fMinimizeBtn: TSpeedButton; fMaximizeBtn: TSpeedButton; fCloseBtn: TSpeedButton; procedure NoCaptionMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure BtnClick(Sender: TObject); procedure CreateParams(var Params: TCreateParams); override; procedure WMSyscommand(var M: TMessage); message WM_SYSCOMMAND; public /// call this method to hide the Caption bar and replace it with a TPanel procedure SetNoCaption(aTopMostPanel: TPanel; aLabelLeft: integer); /// the TPanel instance replacing the Caption bar property NoCaptionPanel: TPanel read fNoCaption; /// the TLabel instance created on NoCaptionPanel to replace the Caption bar property NoCaptionLabel: TLabel read fNoCaptionLabel; end; /// low level VCL routine in order to hide the application from Windows task bar // - don't use it directly: it's called by TVistaForm.CreateParams() procedure HideAppFormTaskBarButton; {$endif} /// draw a CheckBox in the Canvas Handle of the Wwindow hWnd, in the middle // of the Rect coordinates // - use theming under XP, Vista and Seven procedure DrawCheckBox(hWnd: THandle; Handle: HDC; const Rect: TRect; Checked: boolean); {$ifdef MSWINDOWS} /// test if the ClearType is enabled for font display // - ClearType is a software technology that improves the readability of text // on liquid crystal display (LCD) monitors function IsClearTypeEnabled: boolean; /// enable the ClearType font display // - under Windows 2000, standard font smoothing is forced, since Clear Type // was introduced with XP procedure ClearTypeEnable; /// create an Icon // - return the .lnk file name (i.e. Name+'.lnk') function CreateAnIcon (const Name, Description, Path, Parameters, WorkingDir, IconFilename: TFileName; const IconIndex: Integer; const RunMinimized: Boolean = false): TFileName; /// get the corresponding windows folder, from its ID function GetShellFolderPath(const FolderID: Integer): string; const CSIDL_PROGRAMS = $0002; CSIDL_DOCUMENTS = $0005; CSIDL_COMMON_PROGRAMS = $0017; CSIDL_COMMON_STARTMENU = $0016; CSIDL_COMMON_DESKTOPDIRECTORY = $0019; /// allow an application to access the network through the Windows firewall // - works on Windows WP, Vista and Seven // - caller process must have the administrator rights (this is the case // for a setup program) procedure AddApplicationToFirewall(const EntryName, ApplicationPathAndExe: string); /// open a firewall port on the current computer // - works on Windows XP, Vista and Seven // - caller process must have the administrator rights (this is the case // for a setup program) procedure AddPortToFirewall(const EntryName: string; PortNumber: cardinal); {$endif MSWINDOWS} /// fill TStringGrid.Cells[] with the supplied data // - will be slower than the TSQLTableToGrid method, but will work on // a non standard TDrawGrid component // - it will display date & time and enumerates as plain text, and handle // the header properly (using the current mORMoti18n.pas language settings, if any) // - the Client optional parameter will be used to display any RecordRef column // - all data will be stored within the TStringGrid: you can safely release the // Source data after having called this procedure procedure FillStringGrid(Source: TSQLTable; Dest: TStringGrid; Client: TSQLRest=nil); implementation uses {$ifdef ISDELPHIXE3}System.UITypes,{$endif} {$ifdef MSWINDOWS}ShellApi, ComObj, Activex,Shlobj, {$endif} VarUtils; {$ifdef MSWINDOWS} procedure CreateShellLink (const Filename, Description, ShortcutTo, Parameters, WorkingDir, IconFilename: String; const IconIndex: Integer; const RunMinimized: Boolean); { Creates a lnk file named Filename, with a description of Description, which points to ShortcutTo. } var Obj: IUnknown; SL: IShellLink; PF: IPersistFile; WideFilename: WideString; begin Obj := CreateComObject(CLSID_ShellLink); SL := Obj as IShellLink; SL.SetPath(pointer(ShortcutTo)); SL.SetArguments(pointer(Parameters)); if WorkingDir <> '' then SL.SetWorkingDirectory(pointer(WorkingDir)); if IconFilename <> '' then SL.SetIconLocation(pointer(IconFilename), IconIndex); SL.SetDescription(pointer(Description)); PF := Obj as IPersistFile; WideFilename := Filename; PF.Save(PWideChar(WideFilename), True); { Delphi 3+ automatically releases COM objects when they go out of scope } end; function GetShellFolderPath(const FolderID: Integer): string; var pidl: PItemIDList; Buffer: array[0..MAX_PATH-1] of Char; Malloc: IMalloc; begin Result := ''; if Win32MajorVersion<4 then Exit; if SUCCEEDED(SHGetSpecialFolderLocation(0, FolderID, pidl)) then begin if SHGetPathFromIDList(pidl, Buffer) then begin Result := Buffer; if Result[length(Result)]<>'\' then Result := Result+'\'; end; if not FAILED(SHGetMalloc(Malloc)) then Malloc.Free(pidl); end; end; function CreateAnIcon (const Name, Description, Path, Parameters, WorkingDir, IconFilename: TFileName; const IconIndex: Integer; const RunMinimized: Boolean = false): TFileName; var Dir: TFileName; begin result := Name + '.lnk'; Dir := ExtractFilePath(result); if Dir='' then begin if Win32Platform=VER_PLATFORM_WIN32_NT then Dir := GetShellFolderPath(CSIDL_COMMON_DESKTOPDIRECTORY) else Dir := GetShellFolderPath(CSIDL_DESKTOPDIRECTORY); if Dir[length(Dir)]='\' then result := Dir+result else result := Dir+'\'+result; end; if not DirectoryExists(Dir) then begin Dir := ExpandFilename(Dir); if not CreateDirectory(pointer(Dir), nil) then exit; SHChangeNotify(SHCNE_MKDIR, SHCNF_PATH, pointer(Dir), nil); SHChangeNotify(SHCNE_UPDATEDIR, SHCNF_PATH or SHCNF_FLUSH, pointer(ExtractFilePath(Dir)), nil); end; CreateShellLink(result, Description, Path, Parameters, WorkingDir, IconFilename, IconIndex, RunMinimized); SHChangeNotify(SHCNE_CREATE, SHCNF_PATH, pointer(result), nil); SHChangeNotify(SHCNE_UPDATEDIR, SHCNF_PATH or SHCNF_FLUSH, pointer(ExtractFilePath(result)), nil); end; const NET_FW_PROFILE_DOMAIN = 0; NET_FW_PROFILE_STANDARD = 1; NET_FW_PROFILE2_PRIVATE = 2; NET_FW_PROFILE2_PUBLIC = 4; NET_FW_IP_VERSION_ANY = 2; NET_FW_IP_PROTOCOL_UDP = 17; NET_FW_IP_PROTOCOL_TCP = 6; NET_FW_SCOPE_ALL = 0; NET_FW_SCOPE_LOCAL_SUBNET = 1; NET_FW_ACTION_ALLOW = 1; function GetXPFirewall(var fwMgr, profile: OleVariant): boolean; begin result := (Win32Platform=VER_PLATFORM_WIN32_NT) and (Win32MajorVersion>5) or ((Win32MajorVersion=5) and (Win32MinorVersion>0)); if result then // need Windows XP at least try fwMgr := CreateOleObject('HNetCfg.FwMgr'); profile := fwMgr.LocalPolicy.CurrentProfile; except on E: Exception do result := false; end; end; function GetVistaSevenFirewall(var fwMgr, rule: OleVariant; const Description: string): boolean; begin result := (Win32Platform=VER_PLATFORM_WIN32_NT) and (Win32MajorVersion>5); if result then // need Windows Vista at least try fwMgr := CreateOleObject('HNetCfg.FwPolicy2'); rule := CreateOleObject('HNetCfg.FWRule'); rule.Name := Description; rule.Description := Description; rule.Protocol := NET_FW_IP_PROTOCOL_TCP; rule.Enabled := true; rule.Profiles := NET_FW_PROFILE2_PRIVATE OR NET_FW_PROFILE2_PUBLIC; rule.Action := NET_FW_ACTION_ALLOW; except on E: Exception do result := false; end; end; procedure AddApplicationToFirewall(const EntryName, ApplicationPathAndExe: string); var fwMgr, profile, app, rule: OleVariant; begin if Win32MajorVersion<6 then begin if GetXPFirewall(fwMgr,profile) and profile.FirewallEnabled then begin app := CreateOLEObject('HNetCfg.FwAuthorizedApplication'); app.ProcessImageFileName := ApplicationPathAndExe; app.Name := EntryName; app.Scope := NET_FW_SCOPE_ALL; app.IpVersion := NET_FW_IP_VERSION_ANY; app.Enabled := true; profile.AuthorizedApplications.Add(app); end; end else if GetVistaSevenFirewall(fwMgr,rule,EntryName) then begin rule.ApplicationName := ApplicationPathAndExe; fwMgr.Rules.Add(rule); end; end; procedure AddPortToFirewall(const EntryName: string; PortNumber: cardinal); var fwMgr, profile, port, rule: OleVariant; begin if Win32MajorVersion<6 then begin if GetXPFirewall(fwMgr,profile) and profile.FirewallEnabled then begin port := CreateOLEObject('HNetCfg.FWOpenPort'); port.Name := EntryName; port.Protocol := NET_FW_IP_PROTOCOL_TCP; port.Port := PortNumber; port.Scope := NET_FW_SCOPE_ALL; port.Enabled := true; profile.GloballyOpenPorts.Add(port); end; end else if GetVistaSevenFirewall(fwMgr,rule,EntryName) then begin rule.LocalPorts := PortNumber; fwMgr.Rules.Add(rule); end; end; const // for Delphi 6 compilation SPI_GETFONTSMOOTHINGTYPE = $200A; SPI_SETFONTSMOOTHINGTYPE = $200B; FE_FONTSMOOTHINGSTANDARD = $0001; FE_FONTSMOOTHINGCLEARTYPE = $0002; function IsClearTypeEnabled: boolean; // see http://blogs.msdn.com/michkap/archive/2008/03/01/7971061.aspx var MType, SmoothFonts: DWORD; begin SmoothFonts := 0; SystemParametersInfo(SPI_GETFONTSMOOTHING, 1, @SmoothFonts, 0); SystemParametersInfo(SPI_GETFONTSMOOTHINGTYPE, 0, @MType, 0); result := boolean(SmoothFonts) and (MType=FE_FONTSMOOTHINGCLEARTYPE); end; procedure ClearTypeEnable; var MType, SmoothFonts: DWORD; begin if (Win32MajorVersion<5) or IsClearTypeEnabled then exit; // no font smoothing before Win2K SystemParametersInfo(SPI_GETFONTSMOOTHING, 1, @SmoothFonts, 0); if not boolean(SmoothFonts) then SystemParametersInfo(SPI_SETFONTSMOOTHING, 1, nil, SPIF_UPDATEINIFILE or SPIF_SENDCHANGE); if (Win32MajorVersion=5) and (Win32MinorVersion=0) then MType := FE_FONTSMOOTHINGSTANDARD else // no Clear Type on Win2K MType := FE_FONTSMOOTHINGCLEARTYPE; SystemParametersInfo(SPI_SETFONTSMOOTHINGTYPE, 0, Pointer(MType), SPIF_UPDATEINIFILE or SPIF_SENDCHANGE); end; /// attempt to change the scroll bar size -> need Grids.pas rewrite -> buggy procedure SetScrollVPage(Handle: HWND; aPage, aMax: Integer); var ScrollInfo: TScrollInfo; begin if Handle=0 then exit; with ScrollInfo do begin cbSize := SizeOf(ScrollInfo); fMask := SIF_ALL; GetScrollInfo(Handle, SB_VERT, ScrollInfo); if nMin>=nMax then exit; if nMax<>127 then exit; fMask := SIF_DISABLENOSCROLL or SIF_PAGE or SIF_RANGE; if aMax<=0 then nPage := 1 else begin nPage := 30; inc(nMax,nPage); end; end; SetScrollInfo(Handle, SB_VERT, ScrollInfo, true); end; {$endif MSWINDOWS} { THintWindowDelayed } constructor THintWindowDelayed.Create(aOwner: TComponent); begin inherited Create(aOwner); Color := $C0FFFF; fFontColor := clBlack; { if aOwner.InheritsFrom(TSQLTableToGrid) and // done by ParentFont := true not TSQLTableToGrid(aOwner).NotDefined then Canvas.Font := TDrawGrid(TSQLTableToGrid(aOwner).Owner).Canvas.Font; } end; destructor THintWindowDelayed.Destroy; begin Hide; inherited; end; procedure THintWindowDelayed.ShowDelayedUTF8(const Text: RawUTF8; X, Y, Time: integer; FontColor: TColor; AlignLeft: boolean=false); var R: TRect; begin if self=nil then exit; Hide; if Text='' then exit; // no text to show R := CalcHintRect(512, Text, nil); if not AlignLeft then dec(X,R.Right-R.Left); // align right inc(R.Left,X); inc(R.Right,X); inc(R.Top,Y); inc(R.Bottom,Y); ActivateHint(R,UTF8ToString(Text)); // perform Caption := Text fUTF8Text := Text; // so it will work with Delphi 2009/2010 if Time<>0 then begin if fTimerEnabled then KillTimer(Handle,1) else fTimerEnabled := true; SetTimer(Handle,1,Time,nil); end; fFontColor := FontColor; Show; end; procedure THintWindowDelayed.ShowDelayedUTF8(const Text: RawUTF8; Origin: TControl; X, Y, Time: integer; FontColor: TColor; AlignLeft: boolean=false); begin with Origin.ClientToScreen(Point(X,Y)) do ShowDelayedUTF8(Text,X,Y,Time,FontColor,AlignLeft); end; function THintWindowDelayed.CalcHintRect(MaxWidth: Integer; const AHint: RawUTF8; AData: Pointer): TRect; var U: RawUnicode; // faster than a WideString begin // unicode version Result := Rect(0, 0, MaxWidth, 0); U := Utf8DecodeToRawUnicode(AHint); {$ifdef MSWINDOWS}DrawTextW{$else}DrawText{$endif}(Canvas.Handle, pointer(U), length(U) shr 1, Result, DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX {$ifndef FPC}or DrawTextBiDiModeFlagsReadingOnly{$endif}); Inc(Result.Right, 6); Inc(Result.Bottom, 2); end; procedure THintWindowDelayed.Paint; var R: TRect; U: RawUnicode; // faster than a WideString begin // unicode version R := ClientRect; Inc(R.Left, 2); Inc(R.Top, 2); Canvas.Font.Color := fFontColor; U := Utf8DecodeToRawUnicodeUI(fUTF8Text); {$ifdef MSWINDOWS}DrawTextW{$else}DrawText{$endif}(Canvas.Handle, pointer(U), -1, R, DT_LEFT or DT_NOPREFIX or DT_WORDBREAK {$ifndef FPC}or DrawTextBiDiModeFlagsReadingOnly{$endif}); end; procedure THintWindowDelayed.VisibleChanging; begin try if fTimerEnabled and Visible then begin // are we in a Hide process? KillTimer(Handle,1); fTimerEnabled := false; fRow := -1; if HandleAllocated then ReleaseHandle; end; finally inherited VisibleChanging; end; end; {$ifdef FPC} procedure THintWindowDelayed.WMTimer(var Message: TLMTimer); {$else} procedure THintWindowDelayed.WMTimer(var Msg: TWMTimer); {$endif} begin Hide; fRow := -1; end; procedure THintWindowDelayed.ShowDelayedString(const Text: string; X, Y, Time: integer; FontColor: TColor; AlignLeft: boolean=false); begin ShowDelayedUTF8(StringToUTF8(Text),X,Y,Time,FontColor,AlignLeft); end; procedure THintWindowDelayed.ShowDelayedString(const Text: string; Origin: TControl; X, Y, Time: integer; FontColor: TColor; AlignLeft: boolean=false); begin with Origin.ClientToScreen(Point(X,Y)) do ShowDelayedUTF8(StringToUTF8(Text),X,Y,Time,FontColor,AlignLeft); end; { TSQLTableToGrid } resourcestring sErrorTSQLTableToGridNoData = '%s didn''t receive any data for %s'; constructor TSQLTableToGrid.Create(aOwner: TDrawGrid; aTable: TSQLTable; aClient: TSQLRestClientURI); begin if aTable=nil then raise Exception.CreateFmt(sErrorTSQLTableToGridNoData,[ClassName,aOwner.Name]); From(aOwner).Free; // any old association will be overridden by this instance inherited Create(aOwner); fTable := aTable; fClient := aClient; fHint := THintWindowDelayed.Create(self); aOwner.RowCount := 2; // first reset row count, to avoid flicking aOwner.FixedRows := 1; aOwner.Canvas.Font := aOwner.Font; with aOwner.Canvas.TextExtent('jQH'#$00B0';') do aOwner.DefaultRowHeight := cy+4; aOwner.Options := [goFixedHorzLine,goFixedVertLine,goVertLine, goHorzLine,goColSizing,goRowSelect,goThumbTracking]; // no goRangeSelect aOwner.FixedCols := 0; aOwner.ColCount := Table.FieldCount; SetLength(fFieldOrder,Table.FieldCount); // auto filled to false fCurrentFieldOrder := Table.FieldIndex( pointer(SQLGetOrder(Table.QuerySQL))); // get 'ORDER BY' field index if fCurrentFieldOrder>=0 then fFieldOrder[fCurrentFieldOrder] := true; // mark 'ORDER BY' field ascending fFieldIndexTimeLogForMark := -2; // so GetFieldIndexTimeLogForMark will get it aOwner.OnDrawCell := DrawCell; aOwner.OnMouseMove := DrawGridMouseMove; aOwner.OnMouseDown := DrawGridMouseDown; aOwner.OnMouseUp := DrawGridMouseUp; aOwner.OnSelectCell := DrawGridSelectCell; aOwner.OnKeyPress := DrawGridKeyPress; aOwner.OnKeyDown := DrawGridKeyDown; if Table.RowCount>0 then aOwner.RowCount := Table.RowCount+1; end; destructor TSQLTableToGrid.Destroy; begin if (Owner<>nil) and Owner.InheritsFrom(TDrawGrid) then with TDrawGrid(Owner) do begin // reset the Grid overridden events to avoid GPF OnDrawCell := nil; OnMouseMove := nil; OnMouseDown := nil; OnMouseUp := nil; OnSelectCell := nil; OnKeyPress := nil; OnKeyDown := nil; end; FreeAndNil(fTable); inherited; end; class function TSQLTableToGrid.From(Grid: TDrawGrid): TSQLTableToGrid; var i: integer; begin if Grid<>nil then for i := 0 to Grid.ComponentCount-1 do begin result := pointer(Grid.Components[i]); if result.InheritsFrom(TSQLTableToGrid) and (result.Owner=Grid) then exit; end; result := nil; end; const CheckBoxWidth = 13; {$WARN SYMBOL_DEPRECATED OFF} // for ThemeServices procedure DrawCheckBox(hWnd: THandle; Handle: HDC; const Rect: TRect; Checked: boolean); const {$ifdef WITHUXTHEME} XPState: array[boolean] of TThemedButton = ( tbCheckBoxUncheckedNormal, tbCheckBoxCheckedNormal); {$endif} Win32State: array[boolean] of cardinal = ( DFCS_BUTTONCHECK, DFCS_BUTTONCHECK or DFCS_CHECKED); var DrawRect: TRect; begin DrawRect.Left := Rect.Left+(Rect.Right-Rect.Left-CheckBoxWidth)shr 1; DrawRect.Top:= Rect.Top+2; DrawRect.Right := DrawRect.Left + CheckBoxWidth; DrawRect.Bottom := DrawRect.Top + CheckBoxWidth; {$ifdef WITHUXTHEME} if ThemeServices.ThemesEnabled then begin // Windows XP and later: use theming ThemeServices.DrawElement(handle, ThemeServices.GetElementDetails(XPState[Checked]), DrawRect); end else {$endif} DrawFrameControl(Handle,DrawRect,DFC_BUTTON,Win32State[Checked]); end; {$ifndef MSWINDOWS} function ExtTextOutW(DC: HDC; X, Y: Integer; Options: LongInt; Rect: PRect; Str: PWideChar; Count: LongInt; Dx: ObjPas.PInteger): Boolean; var TempStr: UTF8String; L:integer; begin TempStr := RawUnicodeToUtf8(Str,Count,L); Result := ExtTextOut(DC, X, Y, Options, Rect, PChar(TempStr),L, Dx); end; {$endif} procedure TSQLTableToGrid.DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); var Options, x,y, L, i, XInc: integer; StringValue: string; // generic string type, VCL ready Points: array[0..2] of TPoint; WithMark: boolean; Aligned: TSQLTableToGridAlign; tmp: array[0..255] of WideChar; // 255 chars is wide enough inside a cell {$ifndef MSWINDOWS} aTextStyle: TTextStyle; {$endif} begin // default cell draw if NotDefined then exit; if Assigned(OnDrawCellBackground) then OnDrawCellBackground(Owner,ACol,ARow,Rect,State); if (cardinal(ARow)>cardinal(Table.RowCount)) or (cardinal(ACol)>=cardinal(Table.FieldCount)) then // avoid any possible GPF exit; with TDrawGrid(Owner).Canvas do begin {$ifndef MSWINDOWS} aTextStyle := TextStyle; {$endif} Options := ETO_CLIPPED {$ifndef FPC}or TextFlags{$endif}; if Brush.Style <> bsClear then Options := Options or ETO_OPAQUE; WithMark := fMarkAllowed and (ACol=0); if ARow=0 then begin // 1. 1st row = field name: bold + centered translated text, with sort indicator if not Assigned(OnValueText) or not OnValueText(Table,ACol,0,StringValue) then StringValue := Table.GetCaption(0,ACol); // auto translated if not Assigned(OnDrawCellBackground) then Font.Style := [fsBold]; L := Rect.Right-Rect.Left; if WithMark then dec(L,CheckBoxWidth+4); if TextWidth(StringValue)255 then L := 255; // avoid blank cell drawing for huge content {$ifndef MSWINDOWS} TextStyle := aTextStyle; TextRect(Rect,Rect.Left+XInc,Rect.Top+2,StringValue); {$else} ExtTextOut(Handle, Rect.Left+XInc, Rect.Top+2, Options, @Rect, pointer(StringValue), L, nil); // translated text {$endif} end else case Table.ExpandAsString(ARow,ACol,Client,StringValue,GetCustomFormat(ACol)) of // very fast response (calculated once) sftBoolean: // display boolean as checkbox if Assigned(Table.Get(ARow,ACol)) then DrawCheckBox(TDrawGrid(Owner).Handle, Handle, Rect, PWord(Table.Get(ARow,ACol))^<>ord('0')) // fast StrComp(,'0') else DrawCheckBox(TDrawGrid(Owner).Handle, Handle, Rect, False); sftInteger, sftFloat, sftCurrency, sftEnumerate, sftTimeLog, sftRecord, sftDateTime, sftDateTimeMS, sftUnixTime, sftUnixMSTime: begin {$ifndef MSWINDOWS} TextStyle := aTextStyle; TextRect(Rect,Rect.Left+XInc,Rect.Top+2,StringValue); {$else} ExtTextOut(Handle, Rect.Left+XInc, Rect.Top+2, Options, @Rect, pointer(StringValue), length(StringValue), nil); // translated short text {$endif} end; //sftID,sftTID: // proposal: display ID as TSQLRecord content? better compute it in SELECT else begin // normal field value: unicode text (even with Delphi 2-2007 VCL), left aligned {$ifndef MSWINDOWS} StringValue := Table.GetU(ARow,ACol); for i := 0 to Length(StringValue)-1 do // replace #13,#10 chars in the grid with spaces if StringValue[i]<' ' then StringValue[i] := ' '; TextStyle := aTextStyle; TextRect(Rect,Rect.Left+XInc,Rect.Top+2,StringValue); {$else} L := Table.GetWP(ARow,ACol,tmp,high(tmp)); for i := 0 to L-1 do // replace #13,#10 chars in the grid with spaces if tmp[i]<' ' then tmp[i] := ' '; // direct unicode text draw ExtTextOutW(Handle, Rect.Left+XInc, Rect.Top+2, Options, @Rect, tmp, L, nil); {$endif} end; end; if Aligned<>alLeft then {$ifdef MSWINDOWS} SetTextAlign(Handle,TA_LEFT); {$else} aTextStyle.Alignment := taLeftJustify; {$endif} end; if WithMark then begin // draw left side checkbox with Marked[] value inc(Rect.Left,2); Rect.Right := Rect.Left+CheckBoxWidth; if ARow=0 then WithMark := HeaderCheckboxSelectsInsteadOfSort and (MarkedTotalCount+1=TDrawGrid(Owner).RowCount) else WithMark := Marked[ARow]; DrawCheckBox(TDrawGrid(Owner).Handle, Handle,Rect,WithMark); end; end; end; procedure TSQLTableToGrid.SortForce(ACol: integer; Ascending: boolean; ARow: integer=-1); var MIDs: TIDDynArray; begin if NotDefined or (ACol>=Table.FieldCount) then // we allow ACol<0 (see below) exit; if ARow<0 then ARow := TDrawGrid(Owner).Row; // keep current row selected if none specified if ACol<0 then begin // if ACol=-1, then the Marked[] rows are shown first, in current sort if fMarked=nil then exit; // no Marked[] rows to put in first place ARow := Table.IDColumnHiddenValue(ARow); // current row Table.SortBitsFirst(fMarked[0]); TDrawGrid(Owner).Row := Table.RowFromID(ARow); // no PageChanged here end else begin if fMarked<>nil then Table.IDArrayFromBits(fMarked[0],MIDs); // save current marked entries fFieldOrder[ACol] := Ascending; fCurrentFieldOrder := ACol; Table.SortFields(ACol,fFieldOrder[ACol],@ARow); if MIDs<>nil then Table.IDArrayToBits(fMarked[0],MIDs); // restore marked entries TDrawGrid(Owner).Row := ARow; // reselect row after sort (+ Invalidate) PageChanged; // hide any pending popup Hint e.g. end; if Assigned(OnSort) then OnSort(TDrawGrid(Owner)); end; procedure TSQLTableToGrid.DrawGridMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var ACol, ARow: integer; Hint: string; // generic string type, for VCL begin if NotDefined then // avoid any possible GPF exit; fMouseDownMarkedValue := markNone; TDrawGrid(Owner).MouseToCell(X, Y, ACol, ARow); if cardinal(ACol)mbLeft) then begin // Ctrl or right button pressed -> display first row as hint ShowHintString(UTF8ToString(Table.Get(ARow,ACol)),ACol,ARow,4000); end else begin // first row -> sort fields if fMarkAllowed and (X toggle sorting order SortForce(ACol,not fFieldOrder[ACol]) else // column changed -> sort ascending first SortForce(ACol,true); end else // not first row: data if (Button=mbRight) and (ssRight in Shift) and Assigned(OnRightClickCell) then OnRightClickCell(Table,ACol,ARow,X,Y) else if (ssCtrl in Shift) or (Button<>mbLeft) then begin if not Assigned(OnHintText) or not OnHintText(Table,ACol,ARow,Hint) then Table.ExpandAsString(ARow,ACol,Client,Hint); // Hint := IntToStr(SelectedID); ShowHintString(Hint,ACol,ARow,4000); end else if (Button=mbLeft) and (ACol=0) and fMarkAllowed and (X=cardinal(Table.FieldCount) then exit; if ARow=0 then begin // over the checkbox left of the first row: show appropriate hint if (ACol=0) and fMarkAllowed and (fMarked<>nil) and (X-1) or (Hint.Row<>0)) then begin if not HeaderCheckboxSelectsInsteadOfSort then begin ShowHintString(sPutMarkedRowFirst,0,0,1000); Hint.fCol := -1; // column = -1 for checkbox end; end else // over the first row, i.e. column name: show hint if name was truncated if (not FieldTitleTruncatedNotShownAsHint) and GetBit64(fFieldNameTruncated,ACol) and ((Hint=nil) or (Hint.Col<>ACol) or (Hint.Row<>0)) then ShowHintString(Table.GetCaption(0,ACol),ACol,0,1000); end else // select/unselect checkbox left of data rows if (ACol=0) and fMarkAllowed and (fMouseDownMarkedValue<>markNone) and (X<=CheckBoxWidth+4) then Marked[ARow] := (fMouseDownMarkedValue=markOn); end; procedure TSQLTableToGrid.DrawGridMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin fMouseDownMarkedValue := markNone; // reset Marked[] checkbox state end; procedure TSQLTableToGrid.DrawGridSelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean); begin if NotDefined then // avoid any possible GPF exit; if not fIncrementalSearchMove then fIncrementalSearch := ''; // reset incremental key lookup if Assigned(OnSelectCell) and not fOnSelectCellProcessing then try fOnSelectCellProcessing := true; // avoid endless loop or GPF OnSelectCell(Sender,ACol,ARow,CanSelect); finally fOnSelectCellProcessing := false; end; end; procedure TSQLTableToGrid.Resize(Sender: TObject); var i: integer; width,tot: cardinal; begin if NotDefined then // avoid any possible GPF exit; width := TDrawGrid(Owner).ClientWidth-GetSystemMetrics(SM_CXBORDER)*4; if (width=fLastWidth) then exit; // draw if necessary fLastWidth := width; tot := Table.FieldLengthMeanSum; for i := 0 to Table.FieldCount-1 do TDrawGrid(Owner).ColWidths[i] := (width*Table.FieldLengthMean(i))div tot; // with TDrawGrid(Owner) do SetScrollVPage(Handle,ClientHeight div DefaultRowHeight,RowCount-FixedRows); end; function TSQLTableToGrid.NotDefined: boolean; begin result := (self=nil) or (Owner=nil) or (Table=nil) or not Owner.InheritsFrom(TDrawGrid); end; procedure TSQLTableToGrid.DrawGridKeyPress(Sender: TObject; var Key: Char); var F,R: integer; begin // incremental key lookup if NotDefined then // avoid any possible GPF exit; if Key=#27 then // ESC key reset the lookup string fIncrementalSearch := '' else if Key=#8 then begin // BACKDEL key delete last lookup char if fIncrementalSearch<>'' then SetLength(fIncrementalSearch,length(fIncrementalSearch)-1); end else if Key>=' ' then if (Key=' ') and (fIncrementalSearch='') then begin // space with no lookup key -> allow mark/unmark current one R := TDrawGrid(Owner).Row; if fMarkAllowed and (R>0) then begin Marked[R] := not Marked[R]; inc(R); if R<=Table.RowCount then TDrawGrid(Owner).Row := R else // and go to next row TDrawGrid(Owner).Invalidate; end; exit; end else fIncrementalSearch := fIncrementalSearch+RawUTF8(NormToUpper[AnsiChar(Key)]); if fIncrementalSearch='' then begin if fHint<>nil then fHint.Hide; exit; // nothing to search end; // search from the next row F := fCurrentFieldOrder; R := Table.SearchValue(fIncrementalSearch,TDrawGrid(Owner).Row+1,fCurrentFieldOrder,Client); if R=0 then begin // not found: search from the beginning R := Table.SearchValue(fIncrementalSearch,1,fCurrentFieldOrder,Client); if R=0 then begin // not found in this field: search in all fields R := Table.SearchValue(fIncrementalSearch,TDrawGrid(Owner).Row+1,@F,Client); if R=0 then // not found: search from the beginning R := Table.SearchValue(fIncrementalSearch,1,@F,Client); end; end; if R>0 then begin fIncrementalSearchMove := true; // DrawGridSelectCell() won't reset fIncremental TDrawGrid(Owner).Row := R; fIncrementalSearchMove := false; ShowHintString(UTF8ToString(fIncrementalSearch),F,R,2000,clNavy); end else // not found: display searched string in red ShowHintString(UTF8ToString(fIncrementalSearch)+'?',fCurrentFieldOrder, TDrawGrid(Owner).Row,2000,clRed); end; procedure TSQLTableToGrid.ShowHintString(const Text: string; ACol, ARow, Time: integer; FontColor: TColor=clBlack); begin if NotDefined then // avoid any possible GPF exit; if Text='' then begin if fHint<>nil then fHint.Hide; exit; end; fHint.fCol := ACol; fHint.fRow := ARow; with TDrawGrid(Owner).CellRect(ACol,ARow) do fHint.ShowDelayedString(Text,TDrawGrid(Owner),Right,Top+2,Time,FontColor); end; procedure TSQLTableToGrid.DrawGridKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); var F: integer; begin if NotDefined or (Shift<>[]) then // avoid any possible GPF exit; case Key of VK_LEFT: // LEFT ARROW key sort previous column if fCurrentFieldOrder>0 then F := fCurrentFieldOrder-1 else F := Table.FieldCount-1; VK_RIGHT: // RIGHT ARROW key sort next column if fCurrentFieldOrder>=Table.FieldCount-1 then F := 0 else F := fCurrentFieldOrder+1; else exit; end; SortChange(F); Key := 0; // we proceed this key -> caller will ignore it end; procedure TSQLTableToGrid.SortChange(ACol: integer); begin if not NotDefined and (cardinal(ACol) toggle sorting order SortForce(ACol,not fFieldOrder[ACol]) else // column changed -> sort ascending first SortForce(ACol,true); end; procedure TSQLTableToGrid.IDColumnHide; begin if NotDefined or not Table.IDColumnHide then exit; TDrawGrid(Owner).ColCount := Table.FieldCount; // we loose one column fCurrentFieldOrder := -1; // force no previous column -> always ascending order SortChange(0); end; function TSQLTableToGrid.SelectedID: TID; begin if NotDefined then result := 0 else result := Table.IDColumnHiddenValue(TDrawGrid(Owner).Row); end; function TSQLTableToGrid.SelectedRecordCreate: TSQLRecord; var aID: integer; RecordType: TSQLRecordClass; begin aID := SelectedID; if (aID<=0) or (fClient=nil) then result := nil else begin RecordType := TSQLRecordClass(Table.QueryRecordType); if (RecordType=nil) or not RecordType.InheritsFrom(TSQLRecord) then result := nil else result := RecordType.Create(fClient,aID); end; end; function TSQLTableToGrid.GetAlign(aCol: cardinal): TSQLTableToGridAlign; begin if (self=nil) or (Table=nil) or (aCol>=cardinal(length(fAligned))) or (aCol>=Cardinal(Table.FieldCount)) then result := alLeft else result := fAligned[aCol]; end; procedure TSQLTableToGrid.SetAlign(aCol: cardinal; Value: TSQLTableToGridAlign); begin if (self=nil) or (Table=nil) or (aCol>=Cardinal(Table.FieldCount)) then exit; if length(fAligned)=cardinal(length(fCustomFormat))) or (aCol>=Cardinal(Table.FieldCount)) then result := '' else result := fCustomFormat[aCol]; end; procedure TSQLTableToGrid.SetCustomFormat(aCol: cardinal; const Value: string); begin if (self=nil) or (Table=nil) or (aCol>=Cardinal(Table.FieldCount)) then exit; if length(fCustomFormat)nil then for i := 0 to high(aCols) do SetAlign(aCols[i],aAlign); end; procedure TSQLTableToGrid.SetAlignedByType(aFieldType: TSQLFieldType; aAlign: TSQLTableToGridAlign); var i: integer; begin if (self=nil) or (Table=nil) then exit; for i := 0 to Table.FieldCount-1 do if Table.FieldType(i)=aFieldType then SetAlign(i,aAlign); end; procedure TSQLTableToGrid.SetCustomFormatByType(aFieldType: TSQLFieldType; const aCustomFormat: string); var i: integer; begin if (self=nil) or (Table=nil) then exit; for i := 0 to Table.FieldCount-1 do if Table.FieldType(i)=aFieldType then SetCustomFormat(i,aCustomFormat); end; procedure TSQLTableToGrid.PageChanged; begin if (Self<>nil) and (Hint<>nil) then Hint.Hide; end; function TSQLTableToGrid.Refresh(ForceRefresh: Boolean=false; AutoResizeColumns: Boolean=true): boolean; var Refreshed: boolean; aID: integer; begin if self=nil then result := false else begin aID := Table.IDColumnHiddenValue(TDrawGrid(Owner).Row); if ForceRefresh then result := true else result := Client.UpdateFromServer([Table],Refreshed) and Refreshed; if result then AfterRefresh(aID,AutoResizeColumns); end; end; procedure TSQLTableToGrid.AfterRefresh(const aID: TID; AutoResizeColumns: boolean); var CurrentRow: integer; Bulk: boolean; begin with TDrawGrid(Owner) do begin if Table.RowCount=0 then RowCount := 2 else RowCount := Table.RowCount+1; if Table.FieldCount<>ColCount then begin // we get results from a void table for the first time ColCount := Table.FieldCount; SetLength(fFieldOrder,Table.FieldCount); end; CurrentRow := Table.RowFromID(aID); if CurrentRow=0 then CurrentRow := 1; Row := CurrentRow; TopRow := 1; Invalidate; end; if AutoResizeColumns then Resize(nil); if Assigned(OnSelectCell) then OnSelectCell(Owner,0,CurrentRow,Bulk); // refresh details end; procedure TSQLTableToGrid.SetFieldLengthMean(const Lengths: RawUTF8; aMarkAllowed: boolean); var L, i: integer; c: AnsiChar; Means: array of cardinal; begin if self=nil then Exit; fMarkAllowed := aMarkAllowed; L := length(Lengths); if L=0 then begin SetLength(Means,Table.FieldCount); for i := 0 to Table.FieldCount-1 do Means[i] := 10; // some fixed width end else if Table.FieldCount=L then begin SetLength(Means,L); for i := 0 to L-1 do begin c := Lengths[i+1]; if c in ['a'..'z'] then begin Aligned[i] := alCenter; dec(c,32); end; Means[i] := ord(c)+(1-ord('A')); end; Table.SetFieldLengthMean(Means); end; if aMarkAllowed then Table.FieldLengthMeanIncrease(0,2); // space for Marked[] checkbox e.g. end; procedure TSQLTableToGrid.SetFieldFixedWidth(aColumnWidth: integer); var i: integer; begin with TDrawGrid(Owner) do for i := 0 to ColCount-1 do ColWidths[i] := aColumnWidth; end; function TSQLTableToGrid.GetGridColumnWidths: RawUTF8; var i: integer; w: RawUTF8; begin result := ''; if self<>nil then with TDrawGrid(Owner) do for i := 0 to ColCount-1 do begin Int32ToUtf8(ColWidths[i],w); if i=0 then result := w else result := result+','+w; end; end; procedure TSQLTableToGrid.SetGridColumnWidths(const Value: RawUTF8); var P: PUTF8Char; i,w: integer; begin if self=nil then exit; P := pointer(Value); with TDrawGrid(Owner) do for i := 0 to ColCount-1 do begin w := GetNextItemCardinal(P); if w=0 then w := 100; ColWidths[i] := w; end; end; function TSQLTableToGrid.GetMarked(RowIndex: integer): boolean; begin dec(RowIndex); if (self=nil) or (fMarked=nil) or (cardinal(RowIndex)>=cardinal(length(fMarked)shl 3)) then result := false else result := GetBitPtr(pointer(fMarked),RowIndex); end; procedure TSQLTableToGrid.SetMarked(RowIndex: integer; const Value: boolean); var n: integer; begin dec(RowIndex); if (self=nil) or (cardinal(RowIndex)>=cardinal(Table.RowCount)) then exit; n := (Table.RowCount shr 3)+1; if length(fMarked)nil then Finalize(fMarked); actmarkInverse: for i := 1 to RowCount do Marked[i] := not Marked[i]; else if FieldIndexTimeLogForMark >= 0 then begin // use TDateTime calculation because TTimeLog is not duration compatible current := Trunc(NowUTC); case aAction of actMarkToday: begin TimeMin.From(current, true); TimeMax.From(current + 1, true); end; actMarkThisWeek: begin TimeMin.From(StartOfTheWeek(current), true); TimeMax.From(EndOfTheWeek(current) + 1, true); end; actMarkThisMonth: begin TimeMin.From(StartOfTheMonth(current), true); TimeMax.From(EndOfTheMonth(current) + 1, true); end; actMarkYesterday: begin TimeMin.From(current - 1, true); TimeMax.From(current, true); end; actMarkLastWeek: begin TimeMin.From(IncWeek(StartOfTheWeek(current), -1), true); TimeMax.From(StartOfTheWeek(current), true); end; actMarkLastMonth: begin TimeMin.From(IncMonth(StartOfTheMonth(current), -1), true); TimeMax.From(StartOfTheMonth(current), true); end; actMarkOlderThanOneDay..actMarkOlderThanOneYear: begin TimeMin.Value := 1; // = 1 second after Jesus' birth = not <> 0 TimeMax.From(NowUTC - DIFFTIME[aAction],true); end; else exit; end; for i := 1 to RowCount do begin SetInt64(Table.Get(i, fFieldIndexTimeLogForMark), V); if (V>=TimeMin.Value) and (V<=TimeMax.Value) then Marked[i] := true; end; end; end; TDrawGrid(Owner).Invalidate; // refresh screen end; function TSQLTableToGrid.GetMarkAvailable: boolean; var i: integer; begin result := fMarkAllowed and (fMarked<>nil); if not result then exit; for i := 0 to Table.RowCount-1 do // very any bit is realy set if GetBitPtr(pointer(fMarked),i) then exit; result := false; end; function TSQLTableToGrid.GetMarkedIsOnlyCurrrent: boolean; begin with TDrawGrid(Owner) do result := fMarkAllowed and (fMarked<>nil) and Marked[Row] and (GetBitsCount(fMarked[0],RowCount)=1); end; function TSQLTableToGrid.GetMarkedTotalCount: integer; begin with TDrawGrid(Owner) do if not fMarkAllowed or (fMarked=nil) then result := 0 else result := GetBitsCount(fMarked[0],RowCount); end; function TSQLTableToGrid.ExpandRowAsString(Row: integer; Client: TObject): string; var F, i: integer; Text: string; // generic VCL-ready string begin result := ''; if (self=nil) or (cardinal(Row)>cardinal(Table.RowCount)) or (Table.FieldCount<=0) then exit; for F := 0 to Table.FieldCount-1 do begin if (not Assigned(OnValueText)) or (not OnValueText(Table,F,Row,text)) then Table.ExpandAsString(Row,F,Client,Text); i := pos(#13,Text); // trim multi-line text to first line if i>0 then SetLength(Text,i-1); if (F>0) and (text<>'') then text := ' '+text; result := result+text; end; end; procedure TSQLTableToGrid.OnTableUpdate(State: TOnTableUpdateState); begin if (self=nil) or (fMarked=nil) then exit; // wrong parameters case State of tusPrepare: // save current marked entries if fMarked<>nil then begin Table.IDArrayFromBits(fMarked[0],fOnTableUpdateID); exit; // don't Finalize(fOnTableUpdateID) end; tusChanged: // restore marked entries if fOnTableUpdateID<>nil then Table.IDArrayToBits(fMarked[0],fOnTableUpdateID); end; // tusNoChange or tusChanged: release IDs memory if fOnTableUpdateID<>nil then Finalize(fOnTableUpdateID); end; function TSQLTableToGrid.GetMarkedBits: pointer; begin result := fMarked; end; function TSQLTableToGrid.GetDrawGrid: TDrawGrid; begin if self=nil then result := nil else result := TDrawGrid(Owner); end; function TSQLTableToGrid.GetFieldIndexTimeLogForMark: integer; var F: integer; begin if Self=nil then begin result := -1; exit; end; if fFieldIndexTimeLogForMark=-2 then begin fFieldIndexTimeLogForMark := -1; for F := 0 to Table.FieldCount-1 do if Table.FieldType(F)=sftTimeLog then begin fFieldIndexTimeLogForMark := F; break; end; end; result := fFieldIndexTimeLogForMark; end; { TVistaForm } {$ifdef VISTAFORM} var AppFormTaskBarButtonHidden: boolean = false; procedure HideAppFormTaskBarButton; {$ifdef ISDELPHI2007ANDUP} begin end; {$else} var ExtendedStyle: Integer; begin if AppFormTaskBarButtonHidden then exit; AppFormTaskBarButtonHidden := true; ShowWindow(Application.Handle, SW_HIDE); ExtendedStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE); SetWindowLong(Application.Handle, GWL_EXSTYLE, ExtendedStyle and not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW); ShowWindow(Application.Handle, SW_SHOW); Application.DialogHandle := Application.Handle; end; {$endif} procedure TVistaForm.BtnClick(Sender: TObject); begin if Sender=fCloseBtn then Close else if Sender=fMinimizeBtn then WindowState := wsMinimized else if (Sender=fMaximizeBtn) or Sender.InheritsFrom(TLabel) then if WindowState=wsMaximized then WindowState := wsNormal else WindowState := wsMaximized; end; procedure TVistaForm.CreateParams(var Params: TCreateParams); begin HideAppFormTaskBarButton; // check if not already hidden inherited; {$ifndef ISDELPHI2007ANDUP} Params.ExStyle := Params.ExStyle and not WS_EX_TOOLWINDOW or WS_EX_APPWINDOW; // this form will appear in the TaskBar {$endif} if fNoCaption<>nil then begin Params.ExStyle := Params.ExStyle or WS_EX_STATICEDGE; Params.Style := Params.Style or WS_SIZEBOX; end; end; procedure TVistaForm.NoCaptionMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); const SC_DRAGMOVE = $F012; begin if Button = mbLeft then begin ReleaseCapture; Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0); end; end; procedure TVistaForm.SetNoCaption(aTopMostPanel: TPanel; aLabelLeft: integer); const BUT_SIZE = 16; procedure SetEvent(Event: TMouseEvent); var i: integer; begin if fNoCaption<>nil then begin fNoCaption.OnMouseDown := Event; for i := 0 to fNoCaption.ComponentCount-1 do if fNoCaption.Components[i].InheritsFrom(TLabel) then with TLabel(fNoCaption.Components[i]) do if not Assigned(OnClick) then OnMouseDown := Event; end; end; var R: integer; function Btn(const ResName: string): TSpeedButton; begin dec(R,BUT_SIZE+1); result := TSpeedButton.Create(aTopMostPanel); result.Parent := aTopMostPanel; result.SetBounds(R,2,BUT_SIZE+1,BUT_SIZE); result.Anchors := [akRight, akTop]; result.Glyph.LoadFromResourceName(HInstance,ResName); result.OnClick := BtnClick; result.Flat := true; end; begin if aTopMostPanel=fNoCaption then exit; SetEvent(nil); fNoCaption := aTopMostPanel; if aTopMostPanel<>nil then begin fNoCaptionLabel := TLabel.Create(aTopMostPanel); R := aTopMostPanel.ClientWidth-4; fCloseBtn := Btn('ButClose'); fMaximizeBtn := Btn('ButMax'); fMinimizeBtn := Btn('ButMin'); with fNoCaptionLabel do begin Parent := aTopMostPanel; Transparent := true; AutoSize := false; SetBounds(aLabelLeft,2,R-aLabelLeft,20); Anchors := [akLeft, akRight, akBottom, akTop]; Alignment := Classes.taCenter; OnDblClick := BtnClick; end; SetEvent(NoCaptionMouseDown); BorderStyle := bsNone; {$ifdef ISDELPHI2007ANDUP} RecreateWnd; {$endif} end else BorderStyle := bsSizeable; end; procedure TVistaForm.WMSyscommand(var M: TMessage); begin {$ifdef ISDELPHI2007ANDUP} inherited; {$else} case (M.WParam and $FFF0) of SC_MINIMIZE, SC_RESTORE, SC_MAXIMIZE: begin M.Result := DefWindowProc(Handle, M.Msg, M.WParam, M.LParam); ShowWindow(Application.Handle, SW_HIDE); end; else inherited; end; {$endif} end; {$endif} { TSynLabeledEdit } constructor TSynLabeledEdit.Create(AOwner: TComponent); begin inherited; ShowHint := True; MaxValue := 100; MinValue := 1; Text := ''; end; function TSynLabeledEdit.GetValue: Variant; var Txt: string; begin Txt := trim(Text); if Txt='' then if RangeChecking then begin result := MinValue; Text := MinValue; end else VarClear(result) else begin if not IsValid(Txt,result) then begin if RaiseExceptionOnError then raise ESynLabeledEdit.CreateFmt(SErrorFieldNotValid, [EditLabel.Caption, GetEnumCaption(TypeInfo(TSynLabeledEditKind),Kind)]); if RangeChecking then result := MinValue else VarClear(result); end; end; if RangeChecking and (ResultMaxValue) then begin Text := MaxValue; if RaiseExceptionOnError then raise ESynLabeledEdit.CreateFmt(SErrorFieldTooLarge, [EditLabel.Caption,string(MaxValue)]); end; end; function TSynLabeledEdit.IsValid(const Txt: string; var ToValue: Variant): Boolean; var err: integer; resInt32: integer; resInt64: Int64; resDouble: Double; resCurrency: Currency; begin result := false; case Kind of sleInteger: begin val(Txt,resInt32,err); if err<>0 then exit; ToValue := resInt32; end; sleInt64: begin val(Txt,resInt64,err); if err<>0 then exit; ToValue := resInt64; end; sleCurrency: begin val(Txt,resDouble,err); if err<>0 then exit; resCurrency := resDouble; ToValue := resCurrency; end; sleDouble: begin val(Txt,resDouble,err); if err<>0 then exit; ToValue := resDouble; end; end; result := true; end; procedure TSynLabeledEdit.KeyPress(var Key: char); Var Temp: Variant; TempString: string; begin inherited; if Key=#8 then exit; if Key=',' then Key := '.'; if (Kind in [sleInteger,sleInt64]) and (Key='.') then Key := #0; if ((Key<'0') or (Key>'9')) and (Key<>'.') then begin Key := #0; Beep; exit; end; TempString := Text; if (TempString=#0) or (Self.SelText=TempString) then exit; Insert(Key, TempString, Self.SelStart + 1); if IsValid(TempString,Temp) and RangeChecking and (Temp>MaxValue) then begin Key := #0; Beep; end; end; procedure TSynLabeledEdit.MouseMove(Shift: TShiftState; X,Y: integer); var H: string; begin inherited; if RangeChecking then H := format(SMinMaxValue,[string(FMinValue),string(FMaxValue)]); if FAdditionalHint <> '' then H := trim(FAdditionalHint + #13#10 + H); Hint := H; end; procedure TSynLabeledEdit.SetValue(const Value: Variant); begin Text := Value; end; function TSynLabeledEdit.ToString(NumberOfDigits: integer): string; var numberOfMissingDigits: integer; begin Result := Value; numberOfMissingDigits := NumberOfDigits - Length(Result); if numberOfMissingDigits > 0 then Result := StringOfChar('0', numberOfMissingDigits) + Result; end; function TSynLabeledEdit.ValidateValue: boolean; var V: Variant; begin result := IsValid(Text,V); if RangeChecking and result then result := (V>=MinValue) and (V<=MaxValue); end; procedure FillStringGrid(Source: TSQLTable; Dest: TStringGrid; Client: TSQLRest); var C,R: integer; s: string; begin if (Source=nil) or (Dest=nil) then exit; // avoid GPF Dest.ColCount := Source.FieldCount; Dest.RowCount := Source.RowCount+1; for R := 0 to Source.RowCount+1 do for C := 0 to Source.FieldCount-1 do begin Source.ExpandAsString(R,C,Client,s); // will do all the magic Dest.Cells[C,R] := s; end; end; { TUIComponentsPersist } function TUIComponentsPersist.GetFileName: TFileName; begin if fFileName = '' then fFileName := ChangeFileExt(ExeVersion.ProgramFileName, '.default'); result := fFileName; end; procedure TUIComponentsPersist.LoadFromFile; begin fLoadedJson := StringFromFile(FileName); LoadFromVariant(_JsonFast(fLoadedJson)); end; procedure TUIComponentsPersist.LoadFromVariant(const aDoc: variant); var i: integer; prop: PPropInfo; doc: PDocVariantData; v: PVariant; function HasProp(const PropName: ShortString): boolean; begin result := false; if not doc^.GetAsPVariant(ToUTF8(fTracked[i].Name), v) then exit; prop := ClassFieldPropWithParents(fTracked[i].ClassType, PropName); result := prop <> nil; end; begin doc := _Safe(aDoc); if doc^.Count = 0 then exit; for i := 0 to high(fTracked) do if HasProp('Text') then Prop^.SetGenericStringValue(fTracked[i], SynCommons.VariantToString(v^)) else if HasProp('Checked') then Prop^.SetOrdValue(fTracked[i], ord(boolean(v^))); end; procedure TUIComponentsPersist.SaveToFile; var json: RawUTF8; begin json := _Safe(SaveToVariant)^.ToJSON('', '', jsonHumanReadable); if json <> fLoadedJson then begin FileFromString(json, FileName); fLoadedJson := json; end; end; function TUIComponentsPersist.SaveToVariant: variant; var i: integer; prop: PPropInfo; doc: TDocVariantData; name: RawUTF8; function HasProp(const PropName: ShortString): boolean; begin prop := ClassFieldPropWithParents(fTracked[i].ClassType, PropName); result := prop <> nil; if result then name := ToUTF8(fTracked[i].Name); end; begin doc.InitFast; for i := 0 to high(fTracked) do if HasProp('Text') then doc.AddValue(name, ToUTF8(Prop^.GetGenericStringValue(fTracked[i]))) else if HasProp('Checked') then doc.AddValue(name, boolean(Prop^.GetOrdValue(fTracked[i]))); result := variant(doc); end; procedure TUIComponentsPersist.TrackControls(const ctrls: array of TComponent); var i: integer; begin for i := 0 to high(ctrls) do ObjArrayAddOnce(fTracked, ctrls[i]); end; procedure Register; begin RegisterComponents('Synopse',[TSynLabeledEdit]); end; end.