2371 lines
82 KiB
ObjectPascal
2371 lines
82 KiB
ObjectPascal
/// 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) 2022 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) 2022
|
|
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)<L then
|
|
Aligned := alCenter else
|
|
Aligned := alLeft;
|
|
if Aligned=alCenter then begin
|
|
UnSetBit64(fFieldNameTruncated,ACol);
|
|
XInc := L shr 1;
|
|
{$ifdef MSWINDOWS}
|
|
SetTextAlign(Handle,TA_CENTER);
|
|
{$else}
|
|
aTextStyle.Alignment := taCenter;
|
|
{$endif}
|
|
end else begin
|
|
SetBit64(fFieldNameTruncated,ACol);
|
|
XInc := 2;
|
|
end;
|
|
if WithMark then
|
|
inc(XInc,CheckBoxWidth+4);
|
|
{$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); // direct translated text centered draw
|
|
{$endif}
|
|
if Aligned=alCenter then
|
|
{$ifdef MSWINDOWS}
|
|
SetTextAlign(Handle,TA_LEFT);
|
|
{$else}
|
|
aTextStyle.Alignment := taLeftJustify;
|
|
{$endif}
|
|
Font.Style := [];
|
|
if fCurrentFieldOrder=ACol then begin
|
|
// sorted field: draw sort indicator
|
|
x := Rect.Right-8;
|
|
if fFieldOrder[ACol] then begin
|
|
Points[0].X := x+5; // ascending order arrow
|
|
Points[1].X := x;
|
|
Points[2].X := x-5;
|
|
end else begin
|
|
Points[0].X := x-5; // descending order arrow
|
|
Points[1].X := x+5;
|
|
Points[2].X := x;
|
|
end;
|
|
y := Rect.Bottom-9;
|
|
if fFieldOrder[ACol] then begin
|
|
Points[0].Y := y-5; // ascending order arrow
|
|
Points[1].Y := y+5;
|
|
Points[2].Y := y-5
|
|
end else begin
|
|
Points[0].Y := y+5; // descending order arrow
|
|
Points[1].Y := y+5;
|
|
Points[2].Y := y-5
|
|
end;
|
|
Brush.Color := clWhite; // fill the arrow content
|
|
Polygon(Points);
|
|
Pen.Color := clLtGray; // draw the arrow border
|
|
MoveTo(Points[0].X,Points[0].Y);
|
|
LineTo(Points[1].X,Points[1].Y);
|
|
Pen.Color := clGray;
|
|
LineTo(Points[2].X,Points[2].Y);
|
|
LineTo(Points[0].X,Points[0].Y);
|
|
end;
|
|
end else begin
|
|
// 2. field value rows
|
|
L := Rect.Right-Rect.Left;
|
|
if WithMark then
|
|
dec(L,CheckBoxWidth+4);
|
|
Aligned := self.Aligned[ACol];
|
|
case Aligned of
|
|
alCenter: begin
|
|
{$ifdef MSWINDOWS}
|
|
SetTextAlign(Handle,TA_CENTER);
|
|
{$else}
|
|
aTextStyle.Alignment := taCenter;
|
|
{$endif}
|
|
XInc := L shr 1;
|
|
end;
|
|
alRight: begin
|
|
{$ifdef MSWINDOWS}
|
|
SetTextAlign(Handle,TA_RIGHT);
|
|
{$else}
|
|
aTextStyle.Alignment := taRightJustify;
|
|
{$endif}
|
|
XInc := L-4;
|
|
end else
|
|
XInc := 4;
|
|
end;
|
|
if WithMark then
|
|
inc(XInc,CheckBoxWidth+4);
|
|
if Assigned(OnValueText) and OnValueText(Table,ACol,ARow,StringValue) then begin
|
|
L := length(StringValue);
|
|
if L>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)<cardinal(Table.FieldCount) then
|
|
if ARow=0 then
|
|
if (ssCtrl in Shift) or (Button<>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<CheckBoxWidth+4) then
|
|
if HeaderCheckboxSelectsInsteadOfSort then
|
|
// toggle selection
|
|
if MarkAvailable then
|
|
SetMark(actUnmarkAll) else
|
|
SetMark(actmarkAllEntries) else
|
|
// sort Marked[] first
|
|
SortForce(-1,true) else
|
|
if fCurrentFieldOrder=ACol then
|
|
// same column -> 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<CheckBoxWidth+4) then begin
|
|
if Marked[ARow] then // on click: invert current Marked[] checkbox state
|
|
fMouseDownMarkedValue := markOff else
|
|
fMouseDownMarkedValue := markOn;
|
|
Marked[ARow] := (fMouseDownMarkedValue=markOn);
|
|
end;
|
|
TDrawGrid(Owner).Invalidate;
|
|
end;
|
|
|
|
resourcestring
|
|
sPutMarkedRowFirst = 'Sort marked rows first';
|
|
|
|
procedure TSQLTableToGrid.DrawGridMouseMove(Sender: TObject;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
var ACol, ARow: integer;
|
|
begin
|
|
if NotDefined then // avoid any possible GPF
|
|
exit;
|
|
TDrawGrid(Owner).MouseToCell(X, Y, ACol, ARow);
|
|
if cardinal(ACol)>=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<CheckBoxWidth+4) and
|
|
((Hint=nil) or (Hint.Col<>-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)<cardinal(Table.FieldCount)) then
|
|
if fCurrentFieldOrder=ACol then
|
|
// same column -> 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)<Table.FieldCount then
|
|
SetLength(fAligned,Table.FieldCount);
|
|
fAligned[aCol] := Value;
|
|
end;
|
|
|
|
|
|
function TSQLTableToGrid.GetCustomFormat(aCol: cardinal): string;
|
|
begin
|
|
if (self=nil) or (Table=nil) or (aCol>=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)<Table.FieldCount then
|
|
SetLength(fCustomFormat,Table.FieldCount);
|
|
fCustomFormat[aCol] := Value;
|
|
end;
|
|
|
|
procedure TSQLTableToGrid.SetAligned(const aCols: array of cardinal; aAlign: TSQLTableToGridAlign);
|
|
var i: integer;
|
|
begin
|
|
if Table<>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)<n then // need to allocate/expand fMarked[] array?
|
|
SetLength(fMarked,n); // initializes all expanded bytes to 0
|
|
if Value then
|
|
SetBitPtr(pointer(fMarked),RowIndex) else
|
|
UnSetBitPtr(pointer(fMarked),RowIndex)
|
|
end;
|
|
|
|
procedure TSQLTableToGrid.SetMark(aAction: TSQLAction);
|
|
var i: integer;
|
|
V: Int64;
|
|
current: TDateTime;
|
|
TimeMin, TimeMax: TTimeLogBits;
|
|
const
|
|
DIFFTIME: array[actMarkOlderThanOneDay..actMarkOlderThanOneYear] of double =
|
|
(1,7,31,183,365); // 183 = more or less half a year
|
|
begin
|
|
if NotDefined then
|
|
exit;
|
|
with TDrawGrid(Owner) do
|
|
case aAction of
|
|
actMarkAllEntries:
|
|
for i := 1 to RowCount do
|
|
Marked[i] := true;
|
|
actUnMarkAll:
|
|
if 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 (Result<MinValue) then begin
|
|
Text := MinValue;
|
|
if RaiseExceptionOnError then
|
|
raise ESynLabeledEdit.CreateFmt(SErrorFieldTooSmall,
|
|
[EditLabel.Caption,string(MinValue)]);
|
|
end;
|
|
if RangeChecking and (Result>MaxValue) 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: PtrInt;
|
|
begin
|
|
for i := 0 to high(ctrls) do
|
|
ObjArrayAddOnce(fTracked, ctrls[i]);
|
|
end;
|
|
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('Synopse',[TSynLabeledEdit]);
|
|
end;
|
|
|
|
|
|
initialization
|
|
{$ifdef FPC}
|
|
// LCL/Lazarus components expect UTF-8 encoding for strings
|
|
CurrentAnsiConvert := UTF8AnsiConvert;
|
|
{$endif FPC}
|
|
|
|
end.
|
|
|