3080 lines
108 KiB
ObjectPascal
3080 lines
108 KiB
ObjectPascal
/// ORM-driven Office 2007 Toolbar for mORMot
|
|
// - this unit is a part of the freeware Synopse mORMot framework,
|
|
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
|
unit mORMotToolBar;
|
|
|
|
interface
|
|
|
|
{
|
|
|
|
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
|
|
|
|
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 *****
|
|
|
|
|
|
Handle a Toolbar for CRUD/ORM actions
|
|
***************************************
|
|
|
|
- full Office 2007 Ribbon menus are created directly from code
|
|
- every database table has its own Ribbon tab
|
|
- every Ribbon tab has its own buttons, corresponding to actions, as
|
|
defined in the code in a custom enumeration type
|
|
|
|
Initial version: 2008 March, by Arnaud Bouchez
|
|
|
|
Version 1.1 - 14 January 2009
|
|
- attempt to reach Delphi 2009/2010 compilation (string=UnicodeString):
|
|
the UNICODE conditional will adapt the framework to these compilers
|
|
(you shouldn't have to set any other conditional define)
|
|
|
|
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.8
|
|
- possibility to add a background picture to the ribbon pages
|
|
(creating a TSQLAdvPage class from TAdvPage with a BackgroundPicture
|
|
property, or directly by supplied a CSV resource name to SetToolBarGroups)
|
|
|
|
Version 1.9
|
|
- improved Delphi 2009/2010 UnicodeString compatibility
|
|
- add TMS components stylers coherency update
|
|
- added TSQLRibbon to factorize most used Ribbon-related User Interface
|
|
data, functions and events in one class
|
|
|
|
Version 1.9.2
|
|
- allow TSQLRibbon.CreateReport() method not to delete the current content
|
|
of the report (useful to specify a custom header/footer before calling
|
|
the default CreateReport implementation)
|
|
- new TSQLRibbon.Refresh method added
|
|
- new AddToReport method to append the specified database Table Content
|
|
to the report
|
|
|
|
Version 1.13
|
|
- now uses TSQLRecord.RecordProps instead of lowest level RTTI calls
|
|
- by default, will use only VCL components to create the Ribbon; can use
|
|
proprietary TMS component pack if USETMSPACK global conditional is defined
|
|
|
|
Version 1.15
|
|
- TSQLRibbon.AddToReport method can work with self=nil
|
|
|
|
Version 1.16
|
|
- includes new TSynAnsiConvert classes for handling Ansi charsets
|
|
|
|
Version 1.18
|
|
- renamed SQLite3ToolBar.pas as mORMotToolBar.pas
|
|
- introducing TSQLPropInfo* classes to decouple ORM definitions from RTTI
|
|
- added aHeaderCheckboxSelectsInsteadOfSort optional parameter to
|
|
TSQLLister, TSQLRibbon and TSQLRibbonTab constructors - see [a41b5dd805]
|
|
|
|
}
|
|
|
|
uses
|
|
Windows, Consts, Dialogs, ShellAPI,
|
|
SysUtils, Forms, Classes, Messages, Graphics,
|
|
ImgList, Controls, Grids, ExtCtrls, Menus,
|
|
{$ifdef USETMSPACK}
|
|
AdvOfficePager, AdvToolBar, AdvGlowButton, AdvMenus, AdvShapeButton, AdvPreviewMenu,
|
|
AdvToolBarStylers, AdvPreviewMenuStylers, AdvOfficePagerStylers,
|
|
AdvOfficeStatusBarStylers, AdvPanel,
|
|
TaskDialog, TaskDialogEx, GDIPicture,
|
|
{$else}
|
|
StdCtrls, ComCtrls, SynTaskDialog, Buttons, CommCtrl,
|
|
{$endif USETMSPACK}
|
|
SynCommons, SynTable, SynGdiPlus, SynZip,
|
|
mORMot, mORMotReport, mORMotUI, mORMoti18n, mORMotUILogin;
|
|
|
|
|
|
type
|
|
/// used to mark which shortcut keys have already been affected
|
|
TFreeShortCutSet = set of ord('A')..ord('Z');
|
|
|
|
/// a simple object to get one char shortcuts from caption value
|
|
{$ifdef USERECORDWITHMETHODS}TFreeShortCut = record
|
|
{$else}TFreeShortCut = object{$endif}
|
|
public
|
|
/// bit set for already used short cut, from 'A' to 'Z'
|
|
Values: TFreeShortCutSet;
|
|
/// attempt to create free shortcut of one char length, from
|
|
// a Caption: try every character of aCaption, from left to right
|
|
// - returns '' if no shortcut calculation was possible
|
|
function FindFreeShortCut(const aCaption: string): string;
|
|
end;
|
|
|
|
|
|
{$ifndef USETMSPACK}
|
|
type
|
|
/// a Vista-enabled TForm descendant
|
|
// - this form will have a button in the TaskBar
|
|
// - this form will hide the default Delphi application virtual form
|
|
TSynForm = TVistaForm;
|
|
|
|
/// a popup menu to be displayed
|
|
TSynPopupMenu = TPopupMenu;
|
|
|
|
/// a button on the Ribbon toolbars, corresponding to one action
|
|
TSynToolButton = class(TToolButton)
|
|
private
|
|
public
|
|
/// this class will have AutoSize set to true
|
|
constructor Create(aOwner: TComponent); override;
|
|
/// display drop down menu
|
|
procedure DoDropDown;
|
|
/// the associated image list, i.e. TToolBar(Owner).Images
|
|
function Images: TCustomImageList;
|
|
end;
|
|
|
|
/// a toolbar on a Ribbon page
|
|
TSynToolBar = class(TToolBar)
|
|
public
|
|
/// create a button on the toolbar
|
|
function CreateToolButton(ButtonClick: TNotifyEvent;
|
|
iAction, ImageListFirstIndex: integer; const ActionName, ActionHints: string;
|
|
var ShortCutUsed: TFreeShortCut; ButtonWidth: integer;
|
|
Images: TCustomImageList): TSynToolButton;
|
|
end;
|
|
|
|
/// a Ribbon page, which will contain some toolbars for a TSQLRecord class
|
|
TSynPage = class(TTabSheet)
|
|
protected
|
|
fToolBar: array of TSynToolBar;
|
|
fToolBarCaptionsCount: integer;
|
|
function GetToolBarCount: integer;
|
|
function GetToolBar(aIndex: integer): TSynToolBar;
|
|
function GetToolBarNextLeft(var Last: TSynToolBar): integer;
|
|
public
|
|
/// add a TSynToolBar to the page list
|
|
// - then call TSynToolBar.CreateToolButton to add some buttons
|
|
function CreateToolBar(AddToList: boolean=true): TSynToolBar;
|
|
/// call this event when all toolbars have been created
|
|
// - it will create the captions under the toolbars
|
|
// - can be call multiple times, when a toolbar has been added and filled
|
|
// will all its buttons
|
|
procedure ToolBarCreated;
|
|
/// number of TSynToolBar in the page list
|
|
property ToolBarCount: integer read GetToolBarCount;
|
|
/// access to the TSynToolBar list of this page
|
|
property ToolBars[aIndex: integer]: TSynToolBar read GetToolBar;
|
|
end;
|
|
|
|
/// the ribbon pager, which will contain one page per TSQLRecord class
|
|
TSynPager = class(TPageControl)
|
|
private
|
|
function GetActivePageIndex: integer;
|
|
procedure SetActivePageIndex(const Value: integer);
|
|
function GetHelpButton: TSynToolButton;
|
|
function GetCaption: TLabel;
|
|
protected
|
|
fHelpToolBar: TSynToolBar;
|
|
fHelpButton: TSynToolButton;
|
|
fTopMostPanel, fTopPanel: TPanel;
|
|
procedure Change; override;
|
|
function GetSynPage(aIndex: integer): TSynPage; {$ifdef HASINLINE}inline;{$endif}
|
|
procedure GroupLabelClick(Sender: TObject);
|
|
public
|
|
/// create the ribbon pager on a form
|
|
// - reserve some above space for groups, caption and min/max/close buttons,
|
|
// so that FormNoCaption method can be called later
|
|
class function CreatePager(aOwner: TCustomForm; NoTabVisible: boolean=false): TSynPager;
|
|
/// add a page instance
|
|
function AddPage(aPage: TSynPage): integer; overload;
|
|
/// create a new page with the specified caption
|
|
function AddPage(const aCaption: string): integer; overload;
|
|
/// create a group label starting for the given page indexes
|
|
function TabGroupsAdd(TabIndexStart, TabIndexEnd: integer; const aCaption: string): TLabel;
|
|
/// hide TSynForm caption bar and put caption and buttons at groups right
|
|
procedure FormNoCaption;
|
|
/// mimic TTabSheet.Pages property
|
|
property Pages[aIndex: Integer]: TSynPage read GetSynPage;
|
|
/// force OnChange event to be triggered
|
|
property ActivePageIndex: integer read GetActivePageIndex write SetActivePageIndex;
|
|
/// the help button to be available on the ribbon
|
|
property HelpButton: TSynToolButton read GetHelpButton;
|
|
/// the label on TopMostPanel, i.e. the TSynForm(Owner).NoCaption
|
|
property Caption: TLabel read GetCaption;
|
|
/// the panel added above the pager, containing groups, caption and buttons
|
|
property TopMostPanel: TPanel read fTopMostPanel;
|
|
/// the panel containing this TSynPager
|
|
property TopPanel: TPanel read fTopPanel;
|
|
published
|
|
/// publish this property, e.g. to close a tab by a double click
|
|
property OnDblClick;
|
|
end;
|
|
|
|
/// body pager used to display the list and the report on the client screen
|
|
TSynBodyPager = TSynPager;
|
|
|
|
/// body page used to display the list and the report on the client screen
|
|
TSynBodyPage = TSynPage;
|
|
|
|
|
|
const
|
|
bsCheck = tbsCheck;
|
|
|
|
TOOLBAR_HEIGHT = 114;
|
|
TOOLBAR_GROUPS_HEIGHT = 20;
|
|
TOOLBAR_TAB_HEIGHT = 22;
|
|
|
|
|
|
{$else USETMSPACK}
|
|
type
|
|
TSynToolButton = TAdvGlowButton;
|
|
TSynPopupMenu = TAdvPopupMenu;
|
|
TSynBodyPage = TAdvOfficePage;
|
|
TSynBodyPager = TAdvOfficePager;
|
|
|
|
/// Vista-enabled TAdvToolBarForm descendant
|
|
// - this form will have a button in the TaskBar
|
|
// - this form will hide the default Delphi application virtual form
|
|
TSynForm = class(TAdvToolBarForm)
|
|
protected
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
procedure WMSyscommand(var M: TMessage); message WM_SYSCOMMAND;
|
|
end;
|
|
|
|
/// a TMS toolbar
|
|
TSynToolBar = class(TAdvToolBar)
|
|
public
|
|
function CreateToolButton(ButtonClick: TNotifyEvent;
|
|
iAction, ImageListFirstIndex: integer; const ActionName, ActionHints: string;
|
|
var ShortCutUsed: TFreeShortCut; ButtonWidth: integer;
|
|
Images: TCustomImageList): TSynToolButton;
|
|
end;
|
|
|
|
/// a TMS ribbon page with an optional background picture
|
|
// - the background picture is right-aligned
|
|
// - if the bitmap width is not wide enough for the page, it's tiled
|
|
TSynPage = class(TAdvPage)
|
|
private
|
|
fBackgroundPicture: TGDIPPicture;
|
|
fBackgroundPictureStored: boolean;
|
|
fBackgroundPictureTiledWidth: integer;
|
|
protected
|
|
procedure Paint; override;
|
|
function GetToolBar(aIndex: integer): TSynToolBar;
|
|
public
|
|
destructor Destroy; override;
|
|
/// add a TSynToolBar to the page list
|
|
// - then call TSynToolBar.CreateToolButton to add some buttons
|
|
function CreateToolBar: TSynToolBar;
|
|
function ToolBarCount: integer;
|
|
property ToolBars[aIndex: integer]: TSynToolBar read GetToolBar;
|
|
/// set a picture to this property to draw it on background
|
|
// - the picture must be available and freed when the page is no longer
|
|
// needed: another possibility is to set the BackgroundPictureStored
|
|
// property to TRUE
|
|
property BackgroundPicture: TGDIPPicture read fBackgroundPicture write fBackgroundPicture;
|
|
/// if this property is TRUE, the corresponding picture will be freed
|
|
// when the instance will be released
|
|
property BackgroundPictureStored: boolean read fBackgroundPictureStored write fBackgroundPictureStored;
|
|
/// the pixel widths used for left-tiling the background bitmap
|
|
// - default value is 200 pixels
|
|
property BackgroundPictureTiledWidth: integer read fBackgroundPictureTiledWidth
|
|
write fBackgroundPictureTiledWidth;
|
|
end;
|
|
|
|
/// a TMS pager
|
|
TSynPager = class(TAdvToolBarPager)
|
|
protected
|
|
function GetSynPage(aIndex: integer): TSynPage;
|
|
{$ifdef HASINLINE}inline;{$endif}
|
|
function GetSynPageCount: integer;
|
|
{$ifdef HASINLINE}inline;{$endif}
|
|
public
|
|
/// create the ribbon pager on a form
|
|
class function CreatePager(aOwner: TCustomForm; NoTabVisible: boolean=false): TSynPager;
|
|
/// add page instance
|
|
function AddPage(aPage: TSynPage): integer; overload;
|
|
/// create a new page with the specified caption
|
|
function AddPage(const aCaption: string): integer; overload;
|
|
/// mimic TTabSheet.Pages property
|
|
property Pages[aIndex: Integer]: TSynPage read GetSynPage;
|
|
/// mimic TTabSheet.PageCount property
|
|
property PageCount: Integer read GetSynPageCount;
|
|
end;
|
|
|
|
{$endif USETMSPACK}
|
|
|
|
type
|
|
TSQLLister = class;
|
|
|
|
/// this event is called when a button is pressed
|
|
// - here ActionValue contains the ordinal value of the custom button
|
|
TSQLListerEvent = procedure(Sender: TObject;
|
|
RecordClass: TSQLRecordClass;
|
|
ActionValue: integer) of object;
|
|
|
|
/// this event is called after actMark*/actUnmarkAll has been executed
|
|
TMarkActionEvent = procedure(Sender: TObject;
|
|
RecordClass: TSQLRecordClass;
|
|
MarkAction: TSQLAction) of object;
|
|
|
|
/// a hidden component, used for handling toolbar buttons of actions
|
|
// to be performed on a TSQLRecordClass list
|
|
TSQLLister = class(TComponent)
|
|
private
|
|
fClient: TSQLRestClient;
|
|
fPager: TSynPager;
|
|
fPage: TSynPage;
|
|
fOnButtonClick: TSQLListerEvent;
|
|
fOnMarkAction: TMarkActionEvent;
|
|
fClass: TSQLRecordClass;
|
|
fActionMax: cardinal;
|
|
fActionHints: string;
|
|
fGrid: TDrawGrid;
|
|
fTableToGrid: TSQLTableToGrid;
|
|
fMenu: TSynPopupMenu;
|
|
fImageList16: TImageList;
|
|
fImageList32: TImageList;
|
|
fReportDetailedIndex: integer;
|
|
fCreateSubMenuLastAction: integer;
|
|
fCreateSubMenuLastButton: TSynToolButton;
|
|
fCreateSubMenuLastMenu: TMenuItem;
|
|
protected
|
|
fShortCutUsed: TFreeShortCut;
|
|
fCurrentSelectedRow: integer;
|
|
function isActionButton(One: TObject): integer;
|
|
procedure ActionButtonClick(Sender: TObject);
|
|
procedure OnRightClickCell(Sender: TSQLTable; ACol, ARow, MouseX, MouseY: Integer);
|
|
procedure OnSelectCell(Sender: TObject; ACol, ARow: Longint; var CanSelect: Boolean);
|
|
public
|
|
/// retrieve the page index from a TSQLRecordClass
|
|
// - the TSynPage tag property contains integer(aClass)
|
|
class function FindPage(aOwner: TSynPager; aClass: TSQLRecordClass): integer;
|
|
/// add a page (if not already) for a corresponding TSQLRecordClass
|
|
// - the TSynPage tag property will contain integer(aClass)
|
|
// - the TSynPage caption is expanded and translated from aClass with
|
|
// LoadResStringTranslate(aClass.SQLTableName) or taken directly from
|
|
// CustomCaption if a value is specified (with translation if CustomCaptionTranslate
|
|
// is set)
|
|
class function AddPage(aOwner: TSynPager; aClass: TSQLRecordClass;
|
|
const CustomCaption: string; CustomCaptionTranslate: boolean): TSynPage;
|
|
|
|
/// initialize the lister for a specified Client and Class
|
|
// - the possible actions are retrieved from the Client TSQLModel
|
|
// - a single page is used for a list of records, specified by their unique class
|
|
// - a single page can share multiple toolbars
|
|
// - both TImagelist will be used to display some images in Action buttons
|
|
// (32 pixels wide) and Popup Menu (16 pixels wide)
|
|
// - if aGrid has no associated TSQLTableToGrid, a default one is created
|
|
// retrieving a list of records with aGridSelect about the aClass Table
|
|
// from aClient, with the ID column hidden
|
|
// (no TSQLTableToGrid will be created if aGridSelect is '')
|
|
// - aOnButtonClick is called with a specified action if a button is clicked,
|
|
// or with ActionValue=0 each time a row is selected
|
|
constructor Create(aOwner: TComponent; aClient: TSQLRestClientURI;
|
|
aClass: TSQLRecordClass; aGrid: TDrawGrid; aIDColumnHide: boolean;
|
|
aPager: TSynPager; aImageList32,aImageList16: TImageList;
|
|
aOnButtonClick: TSQLListerEvent; aOnValueText: TValueTextEvent;
|
|
const aGridSelect: RawUTF8= '*';
|
|
aHideDisabledButtons: boolean=false;
|
|
aHeaderCheckboxSelectsInsteadOfSort: Boolean=false); reintroduce; overload;
|
|
/// same as above, but with a specified TSQLTable
|
|
constructor Create(aOwner: TComponent; aClient: TSQLRestClientURI;
|
|
aClass: TSQLRecordClass; aGrid: TDrawGrid; aIDColumnHide: boolean;
|
|
aPager: TSynPager; aImageList32,aImageList16: TImageList;
|
|
aOnButtonClick: TSQLListerEvent; aOnValueText: TValueTextEvent;
|
|
aTable: TSQLTable; aHideDisabledButtons, aHeaderCheckboxSelectsInsteadOfSort: boolean); reintroduce; overload;
|
|
|
|
/// add or update a ToolBar with a specific actions set
|
|
// - a single page can share multiple toolbars, which caption name must be
|
|
// identical between calls for geniune buttons
|
|
// - if the ToolBar is already existing, the status of its Action buttons
|
|
// is enabled or disabled according to the actions set
|
|
// - aActions must point to a set of enumerates, as defined by
|
|
// Client.Model.SetActions(TypeInfo(..))
|
|
// - first call once this procedure to create the toolbar buttons, then
|
|
// call it again to update the enable/disable status of the buttons
|
|
function SetToolBar(const aToolBarName: string; const aActions;
|
|
ActionIsNotButton: pointer): TSynToolBar;
|
|
/// can be used by any TSQLTableToGrid
|
|
// - to draw marked rows with a highlighted color
|
|
// - with respect to the Toolbar theming
|
|
procedure OnDrawCellBackground(Sender: TObject; ACol, ARow: Longint;
|
|
Rect: TRect; State: TGridDrawState);
|
|
/// create a menu item, and add it to a menu
|
|
function NewMenuItem(Menu: TPopupMenu; const aCaption: string;
|
|
ImageIndex: integer=-1; SubMenu: TMenuItem=nil; OnClick: TNotifyEvent=nil;
|
|
itemEnabled: boolean=true): TMenuItem;
|
|
/// find associate Button for an action
|
|
function FindButton(ActionIndex: integer): TSynToolButton;
|
|
/// retrieve a ready to be displayed hint for a specified action
|
|
// - returns the Hint caption of the corresponding button, or '' if not existing
|
|
function ActionHint(const Action): string;
|
|
/// find associate popup Menu item for an action
|
|
function FindMenuItem(ActionIndex: integer): TMenuItem;
|
|
/// create a sub menu item to both button and menu item for an action
|
|
// - if aCaption is '', erase any previous menu
|
|
procedure CreateSubMenuItem(const aCaption: string; ActionIndex: integer;
|
|
OnClick: TNotifyEvent; ImageIndex: integer=-1; Tag: integer=0;
|
|
itemEnabled: boolean=true);
|
|
|
|
/// the associated Client
|
|
property Client: TSQLRestClient read fClient;
|
|
/// the associated record class
|
|
property RecordClass: TSQLRecordClass read fClass;
|
|
/// the associated Grid display
|
|
property Grid: TDrawGrid read fGrid;
|
|
/// the associated TSQLTableToGrid hidden component
|
|
property TableToGrid: TSQLTableToGrid read fTableToGrid;
|
|
/// the associated Page on the Office 2007 menu
|
|
property Page: TSynPage read fPage;
|
|
/// TImagelist used to display some images in Action buttons
|
|
property ImageList32: TImageList read fImageList32;
|
|
/// TImagelist used to display some images in Action buttons
|
|
property ImageList16: TImageList read fImageList16;
|
|
/// the Popup Menu, displayed with the Grid
|
|
property Menu: TSynPopupMenu read fMenu;
|
|
/// the Hints captions to be displayed on the screen
|
|
// - must be set before SetToolBar() method call
|
|
// - one action (starting with actMark) each line
|
|
property ActionHints: string read fActionHints write fActionHints;
|
|
/// set to to a "Details" level, according to the bsCheck button pushed
|
|
// - set to the Action index which is currently available
|
|
property ReportDetailedIndex: integer read fReportDetailedIndex;
|
|
/// a callback event, triggerred after actMark*/actUnmarkAll has been executed
|
|
property OnMarkAction: TMarkActionEvent read fOnMarkAction write fOnMarkAction;
|
|
end;
|
|
|
|
/// create one or more toolbars in a ribbon page, according to an enumeration
|
|
// of actions
|
|
// - use a similar layout and logic as TSQLLister.SetToolBar() method above
|
|
// - to be used for custom forms (e.g. preview or edit) or to add some
|
|
// custom buttons to a previously created one by TSQLLister.SetToolBar()
|
|
// - simply set the associated objects via the Init() method, then call
|
|
// AddToolBar() for every toolbar which need to be created
|
|
{$ifdef USERECORDWITHMETHODS}TSQLCustomToolBar = record
|
|
{$else}TSQLCustomToolBar = object{$endif}
|
|
public
|
|
Page: TSynPage;
|
|
ActionHints: string;
|
|
ActionsEnum: PEnumType;
|
|
ButtonClick: TNotifyEvent;
|
|
ShortCutUsed: TFreeShortCut;
|
|
ImageList: TImageList;
|
|
Buttons: array of TSynToolButton;
|
|
Toolbars: array of TSynToolBar;
|
|
ImageListFirstIndex: integer;
|
|
/// call this method first to initialize the ribbon
|
|
// - if aToolbarOrPage is a TCustomForm, this form will became a
|
|
// - if aToolbarOrPage is a TSynPager descendant, a new page is created
|
|
// and added to this TSynPager, and used for toolbars adding
|
|
// - if aToolbarOrPage is a TSynPage descendant, the toolbar is added to
|
|
// this specified Page
|
|
procedure Init(aToolbarOrPage: TControl; aEnum: PTypeInfo;
|
|
aButtonClick: TNotifyEvent; aImageList: TImageList; const aActionHints: string;
|
|
aImageListFirstIndex: integer=0);
|
|
/// call this method for every toobar, with appropriate bits set for its buttons
|
|
function AddToolBar(const ToolBarName: string; ActionsBits: pointer=nil;
|
|
ButtonWidth: integer=60): TSynToolBar;
|
|
/// create a popup menu item for a button
|
|
// - call with aCaption void to clear the menu first
|
|
// - then call it for every menu entry
|
|
function CreateSubMenuItem(aButtonIndex: integer; const aCaption: string;
|
|
aOnClick: TNotifyEvent; aTag: integer=0): TMenuItem;
|
|
end;
|
|
|
|
/// this event provide the action values for a specified toolbar
|
|
// - first call is to test the action presence, with TestEnabled=false
|
|
// - a special call is made with ToolBarIndex=-1, in which A should be
|
|
// filled with the marking actions
|
|
// - second call is to test the action enable/disable state, with
|
|
// TestEnabled=true
|
|
// - in all cases, should return any customized toolbar caption name, or ''
|
|
TSQLRibbonSetActionEvent = function(TabIndex, ToolbarIndex: integer;
|
|
TestEnabled: boolean; var A): string of object;
|
|
|
|
/// used to store the options status
|
|
TPBooleanDynArray = array of PBoolean;
|
|
|
|
|
|
/// store the UI elements and data, one per each Table
|
|
TSQLRibbonTab = class
|
|
private
|
|
function GetCurrentID: TID;
|
|
protected
|
|
/// event called by ReportClick(), set by CustomReportPopupMenu()
|
|
FReportPopupClick: TNotifyEvent;
|
|
/// used by ReportPopup() method:
|
|
FReportPopupParams: PEnumType;
|
|
FReportPopupParamsEnabled: pointer;
|
|
FReportPopupValues: TPBooleanDynArray;
|
|
/// triggered when a report popup menu is displayed
|
|
procedure ReportPopup(Sender: TObject);
|
|
/// used internaly to display the report popup menu via the "View" options
|
|
// - can be used to display the same popup menu from another toolbar
|
|
procedure ReportOptionEvent(Sender: TObject; ClientPoint, ScreenPoint: TPoint);
|
|
public
|
|
/// associated TSQLRecord
|
|
Table: TSQLRecordClass;
|
|
/// associated TSQLRecord index in database Model
|
|
TableIndex: integer;
|
|
/// associated Tab settings used to create this Ribbon Tab
|
|
Parameters: PSQLRibbonTabParameters;
|
|
/// associate Tab in the Ribbon
|
|
Tab: TSynPage;
|
|
/// the "View" toolbar on the associated Ribbon Tab
|
|
ViewToolBar: TSynToolBar;
|
|
/// associate Client Body Page
|
|
Page: TSynBodyPage;
|
|
/// the frame containing associated the List, left side of the Page
|
|
FrameLeft: TFrame;
|
|
/// associated table list
|
|
List: TDrawGrid;
|
|
/// allows List resizing
|
|
FrameSplit: TSplitter;
|
|
/// to provide the List with data from Client
|
|
TableToGrid: TSQLTableToGrid;
|
|
/// to associate Class, Actions, Ribbon and Toolbars
|
|
Lister: TSQLLister;
|
|
/// the frame containing associated Details, right side to the list
|
|
FrameRight: TFrame;
|
|
/// the associated Report, to display the page
|
|
// - exists if aTabParameters.Layout is not llClient, and if
|
|
// aTabParameters.NoReport is false
|
|
Report: TGDIPages;
|
|
/// a current record value
|
|
CurrentRecord: TSQLRecord;
|
|
/// create all the UI elements for a specific Table/Class
|
|
// - create a new page for this Table/Class
|
|
// - populate this page with available Toolbars
|
|
// - populate all Toolbars with action Buttons
|
|
constructor Create(ToolBar: TSynPager; Body: TSynBodyPager;
|
|
aImageList32,aImageList16: TImageList; var aPagesShortCuts: TFreeShortCut;
|
|
const aTabParameters: TSQLRibbonTabParameters;
|
|
Client: TSQLRestClientURI; aUserRights: TSQLFieldBits;
|
|
aOnValueText: TValueTextEvent;
|
|
SetAction: TSQLRibbonSetActionEvent;
|
|
const ActionsTBCaptionCSV, ActionsHintCaption: string; ActionIsNotButton: pointer;
|
|
aOnActionClick: TSQLListerEvent; ViewToolbarIndex: integer;
|
|
aHideDisabledButtons, aHeaderCheckboxSelectsInsteadOfSort: boolean);
|
|
/// retrieve CurrentRecord from server
|
|
function Retrieve(Client: TSQLRestClient; ARow: integer; ForUpdate: boolean=false): boolean;
|
|
/// ask the User where to perform an Action
|
|
// - return 100 if "Apply to Selected" was choosen
|
|
// - return 101 if "Apply to Marked" was choosen
|
|
// - return any other value if Cancel or No was choosen
|
|
function AskForAction(const ActionCaption, aTitle: string; Client: TSQLRest;
|
|
DontAskIfOneRow, ReturnMarkedIfSomeMarked: boolean): integer;
|
|
/// release associated memory
|
|
destructor Destroy; override;
|
|
/// used to customize the popup menu of the associated Report
|
|
// - this method expect two standard handlers, and a custom enumeration type
|
|
// together with its (bit-oriented) values for the current Ribbon Tab
|
|
// - caller must supply an array of boolean pointers to reflect the
|
|
// checked state of every popup menu item entry
|
|
procedure CustomReportPopupMenu(OnClick: TNotifyEvent;
|
|
ParamsEnum: PTypeInfo; ParamsEnabled: pointer; const Values: array of PBoolean);
|
|
/// add the report options to the specified menu
|
|
procedure AddReportPopupMenuOptions(Menu: TPopupMenu; OnClick: TNotifyEvent);
|
|
/// triggered when a report popup menu item is clicked
|
|
procedure ReportClick(Sender: TObject);
|
|
{ /// retrieve the Hint value for a particular action
|
|
function ActionHint(const Action): string; }
|
|
/// pointers to every popup meu items data
|
|
property ReportPopupValues: TPBooleanDynArray read FReportPopupValues;
|
|
/// pointer to the set of available popup menu parameters for this report
|
|
property ReportPopupParamsEnabled: pointer read FReportPopupParamsEnabled;
|
|
/// retrieve the current selected ID of the grid
|
|
// - returns 0 if no row is selected
|
|
property CurrentID: TID read GetCurrentID;
|
|
end;
|
|
|
|
/// Event used to customize screen text of property names
|
|
TOnCaptionName = function(const Action: RawUTF8; Obj: TObject=nil; Index: integer=-1): string of object;
|
|
|
|
/// store some variables common to all pages, i.e. for the whole ribbon
|
|
TSQLRibbon = class
|
|
public
|
|
/// the pages array
|
|
Page: array of TSQLRibbonTab;
|
|
/// store the keyboard shortcuts for the whole ribbon
|
|
ShortCuts: TFreeShortCut;
|
|
/// initialize the Pages properties for this ribbon
|
|
// - this constructor must be called in the Owner.OnCreate handler (not in
|
|
// OnShow)
|
|
// - most parameters are sent back to the SQLRibbonTab.Create constructor
|
|
// - if BackgroundPictureResourceNameCSV is set, the corresponding
|
|
// background pictures will be extracted from resources and displayed behind
|
|
// the ribbon toolbar, according to the group
|
|
constructor Create(Owner: TCustomForm; ToolBar: TSynPager; Body: TSynBodyPager;
|
|
aImageList32,aImageList16: TImageList;
|
|
Client: TSQLRestClientURI; aUserRights: TSQLFieldBits;
|
|
aOnValueText: TValueTextEvent; SetAction: TSQLRibbonSetActionEvent;
|
|
const ActionsTBCaptionCSV, ActionsHintCaption: string; ActionIsNotButton: pointer;
|
|
aOnActionClick: TSQLListerEvent; RefreshActionIndex, ViewToolbarIndex: integer;
|
|
aHideDisabledButtons: boolean;
|
|
PagesCount: integer; TabParameters: PSQLRibbonTabParameters; TabParametersSize: integer;
|
|
const GroupCSV: string; const BackgroundPictureResourceNameCSV: string='';
|
|
aHeaderCheckboxSelectsInsteadOfSort: boolean=false); reintroduce; virtual;
|
|
/// release associated memory
|
|
destructor Destroy; override;
|
|
/// retrieve the index of a given Pages[]
|
|
// - returns -1 if this page was not found
|
|
function GetPage(aRecordClass: TSQLRecordClass): integer;
|
|
/// retrieve the current TSQLRibbonTab instance on the screen
|
|
// - returns nil if no page is currently selected
|
|
function GetActivePage: TSQLRibbonTab;
|
|
/// retrieve the TSQLRibbonTabParameters associated to a Ribbon tab, from its index
|
|
// - returns nil if the specified page index is not valid
|
|
function GetParameter(aPageIndex: Integer): PSQLRibbonTabParameters; overload;
|
|
/// get the the TSQLRibbonTabParameters associated to a Ribbon tab, from its table
|
|
// - returns nil if the specified table is not valid
|
|
function GetParameter(aTable: TSQLRecordClass): PSQLRibbonTabParameters; overload;
|
|
/// retrieve the reference of a given button of the ribbon
|
|
// - useful to customize the Ribbon layout, if automatic generation from RTTI
|
|
// don't fit exactly your needs, or even worse marketing's know-how ;)
|
|
// - called by SetButtonHint method
|
|
function FindButton(aTable: TSQLRecordClass; aActionIndex: integer): TSynToolButton;
|
|
/// customize the Hint property of any button
|
|
// - will test the button is available (avoid any GPF error)
|
|
procedure SetButtonHint(aTable: TSQLRecordClass; aActionIndex: integer; const aHint: string);
|
|
|
|
/// trigger this event when a page changed on screen
|
|
// - will free GDI resources and unneeded memory
|
|
procedure ToolBarChange(Sender: TObject);
|
|
/// resize the lists according to the body size
|
|
procedure BodyResize(Sender: TObject);
|
|
/// handle a ribbon button press
|
|
// - returns TRUE if a Refresh command has been processed (caller should exit)
|
|
// and a refresh timer command has been set
|
|
// - returns FALSE if the caller must handle the action
|
|
function RefreshClickHandled(Sender: TObject; RecordClass: TSQLRecordClass;
|
|
ActionValue: integer; out Tab: TSQLRibbonTab): boolean;
|
|
/// must be called by the main form to handle any WM_TIMER message
|
|
// - will refresh the screen as necessary
|
|
procedure WMRefreshTimer(var Msg: TWMTimer);
|
|
{$ifdef USETMSPACK}
|
|
/// change the style of the ribbon and all associated stylers
|
|
// - TMS style is not coherent between stylers: this method will
|
|
// synchronize the color scheme accross all stylers, at once
|
|
procedure ChangeColorScheme(const ColorScheme: TToolBarStyle;
|
|
PanelStyler: TAdvPanelStyler=nil;
|
|
StatusBarStyler: TAdvOfficeStatusBarOfficeStyler=nil;
|
|
CustomStyle: TMemoryStream=nil);
|
|
{$endif USETMSPACK}
|
|
/// create a report for the specified page index
|
|
// - the report must be created from the Page[aPageIndex].CurrentRecord
|
|
// record content
|
|
// - call the CreateReport virtual method
|
|
procedure CreateReport(aPageIndex: Integer); overload;
|
|
/// create a report for the specified page index
|
|
// - this default method create a report with the content of all fields,
|
|
// except those listed in the corrresponding
|
|
// TSQLRibbonTabParameters.EditFieldNameToHideCSV value
|
|
procedure CreateReport(aTable: TSQLRecordClass; aID: TID;
|
|
aReport: TGDIPages; AlreadyBegan: boolean=false); overload; virtual;
|
|
/// add the specified fields content to the report
|
|
// - by default, all main fields are displayed, but caller can specify custom
|
|
// field names as Comma-Separated-Values
|
|
// - retrieve the main Caption of this record (e.g. the "Name" field value)
|
|
function AddToReport(aReport: TGDIPages; aRecord: TSQLRecord; WithTitle: Boolean;
|
|
CSVFieldNames: PUTF8Char=nil; CSVFieldNameToHide: PUTF8Char=nil;
|
|
OnCaptionName: TOnCaptionName=nil;
|
|
ColWidthName: Integer=40; ColWidthValue: integer=60): string; overload;
|
|
/// add the specified database Table Content to the report
|
|
// - if ColWidths are not specified (that is set to []),
|
|
// their values are caculated from the Table content columns
|
|
procedure AddToReport(aReport: TGDIPages; Table: TSQLTable;
|
|
const ColWidths: array of integer); overload;
|
|
/// generic method which print the all marked entries of the supplied table
|
|
function MarkedEntriesToReport(aTable: TSQLRecordClass;
|
|
const ColWidths: array of integer; aRep: TGDIPages=nil): TGDIPages;
|
|
/// make a specified record available to the UI
|
|
// - select tab and record index
|
|
// - if ActionToPerform is set, the corresponding action is launched
|
|
procedure GotoRecord(aTable: TSQLRecordClass; aID: TID;
|
|
ActionToPerform: integer=0); overload;
|
|
/// make a specified record available to the UI
|
|
// - select tab and record index
|
|
// - if ActionToPerform is set, the corresponding action is launched
|
|
procedure GotoRecord(aRecord: TSQLRecord; ActionToPerform: integer=0); overload;
|
|
/// refresh the specified page content
|
|
// - by default, refresh the current page content
|
|
// - calls internaly RefreshClickHandled method
|
|
procedure Refresh(aTable: TSQLRecordClass=nil);
|
|
/// generic method which delete either the current selected entry,
|
|
// either all marked entries
|
|
// - returns TRUE if deletion was successful, or FALSE if any error occured
|
|
function DeleteMarkedEntries(aTable: TSQLRecordClass; const ActionHint: string): Boolean;
|
|
/// generic method which export the supplied record
|
|
// - display the save dialog before
|
|
// - only two formats are available here: Acrobat (.pdf) and plain text (.txt)
|
|
// - returns the exported file name if export was successful, or '' if any error occured
|
|
// - by default, the report is created by using the CreateReport method
|
|
function ExportRecord(aTable: TSQLRecordClass; aID: TID;
|
|
const ActionHint: string; OpenAfterCreation: boolean=true): TFileName;
|
|
protected { private properties set by Init method }
|
|
fTabParameters: PSQLRibbonTabParameters;
|
|
fTabParametersSize: integer;
|
|
fForm: TCustomForm;
|
|
fToolBar: TSynPager;
|
|
{$ifdef USETMSPACK}
|
|
fPreviewMenuButton: TAdvShapeButton;
|
|
fPreviewMenu: TAdvPreviewMenu;
|
|
{$endif USETMSPACK}
|
|
fBody: TSynBodyPager;
|
|
fOnActionClick: TSQLListerEvent;
|
|
fRefreshActionIndex: integer;
|
|
fLastActiveTab: integer;
|
|
fClient: TSQLRestClientURI;
|
|
fActionType: PTypeInfo;
|
|
fEventType: PTypeInfo;
|
|
fActionsHintCaption: string;
|
|
fReportAutoFocus: boolean;
|
|
procedure RefreshPage(Page: TSQLRibbonTab);
|
|
public
|
|
/// the associated Client connection
|
|
property Client: TSQLRestClientURI read fClient write fClient;
|
|
/// the associated Form on scren
|
|
property Form: TCustomForm read fForm;
|
|
/// the Toolbar component used to display the Ribbon on the Form
|
|
property ToolBar: TSynPager read fToolBar;
|
|
{$ifdef USETMSPACK}
|
|
/// the Preview Menu button displayed on the Ribbon
|
|
property PreviewMenuButton: TAdvShapeButton read fPreviewMenuButton;
|
|
/// the Preview Menu to be displayed by pressing the Ribbon Preview Menu button
|
|
property PreviewMenu: TAdvPreviewMenu read fPreviewMenu write fPreviewMenu;
|
|
{$endif USETMSPACK}
|
|
/// the main Pager component used to display the main data (i.e. records list
|
|
// and report) on the Form
|
|
property Body: TSynBodyPager read fBody;
|
|
/// if set to TRUE, the right-sided report is focused instead of
|
|
// the left-sided records list
|
|
property ReportAutoFocus: boolean read fReportAutoFocus write fReportAutoFocus;
|
|
end;
|
|
|
|
|
|
/// retrieve the ready to be displayed text of the given property
|
|
function CaptionName(OnCaptionName: TOnCaptionName;
|
|
const Action: RawUTF8; Obj: TObject=nil; Index: integer=-1): string;
|
|
|
|
/// draw the cell of a TDrawGrid according to the current Theming of TabAppearance
|
|
procedure NewDrawCellBackground(Sender: TObject; ACol, ARow: Integer;
|
|
Rect: TRect; State: TGridDrawState;
|
|
{$ifdef USETMSPACK} TabAppearance: TTabAppearance;{$endif} Marked: boolean);
|
|
|
|
/// create a report containing all icons for a given action enumeration
|
|
// - useful e.g. for marketing or User Interface review purposes
|
|
procedure CreateReportWithIcons(ParamsEnum: PTypeInfo; ImgList: TImageList;
|
|
const Title, Hints: string; StartIndexAt: integer);
|
|
|
|
/// load a bitmap from a .png/.jpg file embedded as a resource to the executable
|
|
// - you can specify a library (dll) resource instance handle, if needed
|
|
function LoadBitmapFromResource(const ResName: string; Instance: THandle=0): TBitmap;
|
|
|
|
/// fill a TImageList from the content of another TImageList
|
|
// - stretching use GDI+ so is smooth enough for popup menu display
|
|
procedure ImageListStretch(ImgListSource, ImgListDest: TImageList;
|
|
BkColor: TColor=clSilver);
|
|
|
|
/// load TImageList bitmaps from an .zip archive embedded as a ZIP resource
|
|
procedure LoadImageListFromEmbeddedZip(ImgList: TCustomImageList; const ZipName: TFileName);
|
|
|
|
/// load TImageList bitmaps from a TBitmap
|
|
// - warning Bmp content can be modified: it could be converted from multi-line
|
|
// (e.g. IDE export format) into one-line (as expected by TImageList.AddMasked)
|
|
procedure LoadImageListFromBitmap(ImgList: TCustomImageList; Bmp: TBitmap);
|
|
|
|
/// add an Icon to the supplied TImageList
|
|
// - return the newly created index in the image list
|
|
// - the HIcon handle is destroyed before returning
|
|
function AddIconToImageList(ImgList: TCustomImageList; Icon: HIcon): integer;
|
|
|
|
resourcestring
|
|
{$ifdef USETMSPACK}
|
|
sPerformToSelected = 'Apply to the selected entry:<br><br><font color="clnavy">%s</font> ?'#13;
|
|
sPerformToMarkedOrSelected =
|
|
'Apply to the <b>Selected entry</b>:<br> <font color="clnavy">%s</font><br><br>'+
|
|
'Or apply to all <b>Marked entries</b>:<font color="clnavy">';
|
|
{$else}
|
|
sPerformToSelected = 'Apply to the selected entry:\n\n%s ?\n';
|
|
sPerformToMarkedOrSelected =
|
|
'Apply to the Selected entry:\n %s\n\nOr apply to all Marked entries:';
|
|
{$endif}
|
|
sApplyToSelected = 'Selected entry';
|
|
sApplyToMarked = 'Marked entries';
|
|
sDeleteN = 'About to Delete %d record(s)';
|
|
sTextFile = 'Text File';
|
|
|
|
implementation
|
|
|
|
procedure CreateReportWithIcons(ParamsEnum: PTypeInfo; ImgList: TImageList;
|
|
const Title, Hints: string; StartIndexAt: integer);
|
|
var Dest: TGDIPages;
|
|
A: integer;
|
|
P: PEnumType;
|
|
PS: PShortString;
|
|
Bmp: TBitmap;
|
|
R: TRect;
|
|
PC: PChar;
|
|
begin
|
|
Bmp := TBitmap.Create;
|
|
Dest := TGDIPages.Create(nil);
|
|
try
|
|
Dest.BeginDoc;
|
|
Dest.Caption := Title;
|
|
Dest.DrawTitle(Title+' - Icons list',true);
|
|
Bmp.Width := ImgList.Width;
|
|
Bmp.Height := ImgList.Height;
|
|
P := ParamsEnum^.EnumBaseType;
|
|
PS := @P^.NameList;
|
|
PC := pointer(Hints);
|
|
R.Left := Dest.LeftMargin;
|
|
R.Right := R.Left+12;
|
|
Dest.LeftMargin := R.Right+10;
|
|
for A := StartIndexAt to P^.MaxValue do begin // start at 1 (0=noAction)
|
|
Bmp.Canvas.FillRect(Rect(0,0,Bmp.Width,Bmp.Height));
|
|
if A-StartIndexAt<ImgList.Count then
|
|
ImgList.Draw(Bmp.Canvas,0,0,A-StartIndexAt);
|
|
if not Dest.HasSpaceFor(20) then
|
|
Dest.NewPage;
|
|
R.Top := Dest.CurrentYPos;
|
|
R.Bottom := R.Top+12;
|
|
Dest.DrawBMP(R,Bmp);
|
|
Dest.Font.Style := [fsBold];
|
|
Dest.DrawText(IntToStr(A)+' - '+P^.GetCaption(A));
|
|
Dest.Font.Style := [];
|
|
Dest.DrawText(GetNextItemString(PC,#13));
|
|
while Dest.CurrentYPos<R.Bottom+5 do
|
|
Dest.NewHalfLine;
|
|
inc(PByte(PS),ord(PS^[0])+1);
|
|
end;
|
|
Dest.EndDoc;
|
|
Dest.ShowPreviewForm;
|
|
finally
|
|
Bmp.Free;
|
|
Dest.Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TSQLLister }
|
|
|
|
class function TSQLLister.AddPage(aOwner: TSynPager;
|
|
aClass: TSQLRecordClass; const CustomCaption: string;
|
|
CustomCaptionTranslate: boolean): TSynPage;
|
|
var i: integer;
|
|
Cap: string;
|
|
begin
|
|
i := FindPage(aOwner,aClass);
|
|
if i<0 then begin
|
|
if CustomCaption='' then
|
|
// get expanded caption
|
|
if aClass=nil then
|
|
Cap := '' else
|
|
Cap := aClass.CaptionName else begin
|
|
// translate specified caption if necessary
|
|
Cap := CustomCaption;
|
|
if CustomCaptionTranslate and Assigned(LoadResStringTranslate) then
|
|
LoadResStringTranslate(Cap);
|
|
end;
|
|
result := TSynPage.Create(aOwner);
|
|
result.Caption := Cap;
|
|
aOwner.AddPage(result);
|
|
end else
|
|
result := aOwner.Pages[i];
|
|
result.Tag := integer(aClass);
|
|
end;
|
|
|
|
class function TSQLLister.FindPage(aOwner: TSynPager;
|
|
aClass: TSQLRecordClass): integer;
|
|
begin
|
|
if aClass<>nil then
|
|
for result := 0 to aOwner.PageCount-1 do
|
|
if aOwner.Pages[result].Tag=integer(aClass) then
|
|
exit;
|
|
result := -1;
|
|
end;
|
|
|
|
procedure TSQLLister.ActionButtonClick(Sender: TObject);
|
|
var aAction: integer;
|
|
A: TSQLAction absolute aAction;
|
|
submenuact: TSQLAction;
|
|
Btn: TSynToolButton absolute Sender;
|
|
iTB,iGB: integer;
|
|
TB: TSynToolBar;
|
|
GB: TSynToolButton;
|
|
begin
|
|
if fReportDetailedIndex<0 then
|
|
exit; // avoid recursive call after GB.Down := false below
|
|
aAction := isActionButton(Sender);
|
|
case A of
|
|
actNoAction: exit;
|
|
actUnMarkAll: begin
|
|
TableToGrid.SetMark(A); // unmarking as standard action
|
|
if Assigned(fOnMarkAction) then
|
|
fOnMarkAction(Sender,fClass,A);
|
|
end;
|
|
actMark:
|
|
if Sender.InheritsFrom(TSynToolButton) then
|
|
Btn.DoDropDown else
|
|
if Sender.InheritsFrom(TMenuItem) then begin
|
|
// actMarkAllEntries..actMarkBeforeOneYear are stored in the Menu.Tag,
|
|
// and gathered under the aAction=actMark button
|
|
submenuact := TSQLAction(TMenuItem(Sender).Tag);
|
|
TableToGrid.SetMark(submenuact);
|
|
if Assigned(fOnMarkAction) then
|
|
fOnMarkAction(Sender,fClass,submenuact);
|
|
end;
|
|
else begin // custom (not actMark*) buttons
|
|
if Sender.InheritsFrom(TSynToolButton) and
|
|
(Btn.Style=bsCheck) then begin
|
|
if Btn.Down then begin
|
|
fReportDetailedIndex := -1; // avoid recursive call
|
|
for iTB := 0 to fPage.ToolBarCount-1 do begin
|
|
TB := fPage.ToolBars[iTB];
|
|
for iGB := 0 to TB.ComponentCount-1 do begin
|
|
GB := TSynToolButton(TB.Components[iGB]);
|
|
if (GB<>Sender) and
|
|
GB.InheritsFrom(TSynToolButton) and
|
|
(GB.Style=bsCheck) then
|
|
GB.Down := false;
|
|
end;
|
|
end;
|
|
fReportDetailedIndex := aAction;
|
|
end else
|
|
fReportDetailedIndex := 0;
|
|
end;
|
|
if Assigned(fOnButtonClick) then
|
|
fOnButtonClick(Sender,fClass,aAction);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TSQLLister.OnSelectCell(Sender: TObject; ACol, ARow: Integer;
|
|
var CanSelect: Boolean);
|
|
begin
|
|
if Assigned(fOnButtonClick) {and (ARow<>fCurrentSelectedRow)} then begin
|
|
fCurrentSelectedRow := ARow;
|
|
fOnButtonClick(nil,fClass,ARow); // Sender=nil for Cell select
|
|
end;
|
|
end;
|
|
|
|
constructor TSQLLister.Create(aOwner: TComponent; aClient: TSQLRestClientURI;
|
|
aClass: TSQLRecordClass; aGrid: TDrawGrid; aIDColumnHide: boolean;
|
|
aPager: TSynPager; aImageList32,aImageList16: TImageList;
|
|
aOnButtonClick: TSQLListerEvent; aOnValueText: TValueTextEvent;
|
|
const aGridSelect: RawUTF8; aHideDisabledButtons, aHeaderCheckboxSelectsInsteadOfSort: boolean);
|
|
var T: TSQLTable;
|
|
begin
|
|
if (aClient=nil) or (aGridSelect='') then
|
|
T := nil else
|
|
T := aClient.List([aClass],aGridSelect);
|
|
Create(aOwner,aClient,aClass,aGrid,aIDColumnHide,aPager,
|
|
aImageList32,aImageList16,aOnButtonClick,aOnValueText,T,aHideDisabledButtons,
|
|
aHeaderCheckboxSelectsInsteadOfSort);
|
|
end;
|
|
|
|
constructor TSQLLister.Create(aOwner: TComponent; aClient: TSQLRestClientURI;
|
|
aClass: TSQLRecordClass; aGrid: TDrawGrid; aIDColumnHide: boolean;
|
|
aPager: TSynPager; aImageList32, aImageList16: TImageList;
|
|
aOnButtonClick: TSQLListerEvent; aOnValueText: TValueTextEvent;
|
|
aTable: TSQLTable; aHideDisabledButtons, aHeaderCheckboxSelectsInsteadOfSort: boolean);
|
|
var i: integer;
|
|
C: TSQLRestClientURI;
|
|
begin
|
|
{$ifdef USETMSPACK}
|
|
if aPager.Parent.InheritsFrom(TSynForm) then
|
|
aPager.MinimizeApp := false; // so WMSyscommand method will be called below
|
|
{$endif}
|
|
inherited Create(aOwner);
|
|
if (aClient=nil) or (aPager=nil) or (aClass=nil) then
|
|
raise EComponentError.Create(ClassName);
|
|
fClient := aClient;
|
|
fPager := aPager;
|
|
fClass := aClass;
|
|
fGrid := aGrid;
|
|
if aTable<>nil then begin
|
|
fTableToGrid := TSQLTableToGrid.From(fGrid);
|
|
if fTableToGrid=nil then begin
|
|
// this Grid has no associated TSQLTableToGrid -> create default one
|
|
if fClient.InheritsFrom(TSQLRestClientURI) then
|
|
C := TSQLRestClientURI(fClient) else
|
|
C := nil;
|
|
fTableToGrid := TSQLTableToGrid.Create(fGrid,aTable,C);
|
|
fTableToGrid.HeaderCheckboxSelectsInsteadOfSort := aHeaderCheckboxSelectsInsteadOfSort;
|
|
if aIDColumnHide then
|
|
fTableToGrid.IDColumnHide;
|
|
end;
|
|
fTableToGrid.OnRightClickCell := OnRightClickCell;
|
|
TableToGrid.OnValueText := aOnValueText;
|
|
fGrid.DefaultDrawing := false; // we force full redraw
|
|
TableToGrid.OnDrawCellBackground := OnDrawCellBackground;
|
|
TableToGrid.OnSelectCell := OnSelectCell;
|
|
end;
|
|
i := FindPage(fPager,fClass);
|
|
if i>=0 then
|
|
fPage := fPager.Pages[i];
|
|
fImageList32 := aImageList32;
|
|
fImageList16 := aImageList16;
|
|
fOnButtonClick := aOnButtonClick;
|
|
if fClient.Model.Actions<>nil then
|
|
fActionMax := fClient.Model.Actions^.MaxValue;
|
|
end;
|
|
|
|
function TSQLLister.SetToolBar(const aToolBarName: string; const aActions;
|
|
ActionIsNotButton: pointer): TSynToolBar;
|
|
var TypeName: PShortString;
|
|
A,iTB,iGB,iM,img: integer;
|
|
GB: TSynToolButton;
|
|
iAction: cardinal;
|
|
M: TMenuItem;
|
|
EN: boolean;
|
|
A2: TSQLAction;
|
|
ActionNames: TStringDynArray;
|
|
|
|
procedure InsertSubMenu(A2: TSQLAction);
|
|
begin
|
|
CreateSubMenuItem(fClass.CaptionNameFromRTTI(
|
|
PTypeInfo(TypeInfo(TSQLAction))^.EnumBaseType^.GetEnumName(A2)),
|
|
iAction,nil,iAction-1,integer(A2));
|
|
end;
|
|
|
|
begin
|
|
result := nil;
|
|
if fPage=nil then
|
|
exit;
|
|
// on existing Toolbar: update its buttons from aActions, and exit
|
|
for iTB := 0 to fPage.ToolBarCount-1 do
|
|
// test exact match, not with SameText(), since Caption can be translated
|
|
if fPage.ToolBars[iTB].Caption=aToolBarName then begin
|
|
result := fPage.ToolBars[iTB];
|
|
for iGB := 0 to result.ComponentCount-1 do begin
|
|
GB := TSynToolButton(result.Components[iGB]);
|
|
if isActionButton(GB)<>0 then begin
|
|
img := GB.ImageIndex;
|
|
EN := GetBitPtr(@aActions,img+1);
|
|
GB.Enabled := EN; // enable or disable buttons
|
|
for iM := 0 to fMenu.Items.Count-1 do
|
|
with fMenu.Items[iM] do
|
|
if ImageIndex=img then
|
|
Enabled := EN; // enable or disable popup menu item
|
|
end;
|
|
end;
|
|
break;
|
|
end;
|
|
if result<>nil then
|
|
exit; // we have found the toolbar
|
|
// no Toolbar: create one with its buttons; also create associated popup menu
|
|
EN := false;
|
|
for A := 0 to fActionMax do
|
|
if GetBitPtr(@aActions,A) then begin
|
|
EN := true;
|
|
break;
|
|
end;
|
|
if not EN then
|
|
exit; // aActions=[] -> no toolbar to add
|
|
if fMenu=nil then begin
|
|
fMenu := TSynPopupMenu.Create(fGrid);
|
|
fMenu.Images := ImageList16;
|
|
end;
|
|
result := fPage.CreateToolBar;
|
|
try
|
|
{$ifdef USETMSPACK}
|
|
result.BeginUpdate;
|
|
result.AutoPositionControls := true;
|
|
result.ShowOptionIndicator := false;
|
|
result.AutoSize := true;
|
|
{$else}
|
|
result.Images := ImageList32;
|
|
{$endif}
|
|
result.Caption := aToolBarName;
|
|
SetLength(ActionNames,fActionMax+1);
|
|
TypeName := @fClient.Model.Actions^.NameList;
|
|
for iAction := 0 to fActionMax do begin
|
|
ActionNames[iAction] := fClass.CaptionNameFromRTTI(TypeName); // expanded caption
|
|
inc(PByte(TypeName),ord(TypeName^[0])+1); // next enumerate value name
|
|
{$ifndef USETMSPACK}
|
|
end;
|
|
for iAction := fActionMax downto 0 do begin // TToolBar adds at 1st position
|
|
{$endif}
|
|
if GetBitPtr(@aActions,iAction) then // is this enumerate value inside aActions?
|
|
with result.CreateToolButton(ActionButtonClick,iAction,1,ActionNames[iAction],
|
|
ActionHints,fShortCutUsed,60,ImageList32) do begin
|
|
if GetBitPtr(@ActionIsNotButton,iAction) then
|
|
Style := bsCheck;
|
|
// create associated sub menu entry
|
|
if Style<>bsCheck then begin
|
|
NewMenuItem(fMenu,Caption,iAction-1);
|
|
if TSQLAction(iAction)=actMark then begin // Mark sub-menu
|
|
InsertSubMenu(actmarkAllEntries);
|
|
InsertSubMenu(actmarkInverse);
|
|
if TableToGrid.FieldIndexTimeLogForMark>=0 then
|
|
for A2 := actmarkToday to actmarkOlderThanOneYear do begin
|
|
if A2 in [actmarkToday,actmarkOlderThanOneDay] then
|
|
CreateSubMenuItem('-',iAction,nil);
|
|
InsertSubMenu(A2);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
M := TMenuItem.Create(fMenu);
|
|
M.Caption := '-';
|
|
fMenu.Items.Add(M);
|
|
finally
|
|
{$ifdef USETMSPACK}
|
|
result.EndUpdate;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
|
|
function TSQLLister.isActionButton(One: TObject): integer;
|
|
var GB: TSynToolButton absolute One;
|
|
M: TMenuItem absolute One;
|
|
begin
|
|
result := -1; // not an action buton or menu
|
|
if One.InheritsFrom(TSynToolButton) then
|
|
if ((GB.Images=ImageList32) or (GB.Images=ImageList16)) and
|
|
Assigned(GB.OnClick) and (TMethod(GB.OnClick).Data=Self) then
|
|
result := GB.ImageIndex;
|
|
if One.InheritsFrom(TMenuItem) then
|
|
if Assigned(M.OnClick) and (TMethod(M.OnClick).Data=Self) then
|
|
result := M.ImageIndex;
|
|
if cardinal(result)>=fActionMax then
|
|
result := 0 else
|
|
inc(result);
|
|
end;
|
|
|
|
procedure TSQLLister.OnRightClickCell(Sender: TSQLTable;
|
|
ACol, ARow, MouseX, MouseY: Integer);
|
|
var P: TPoint;
|
|
begin
|
|
if (self=nil) or (fMenu=nil) then
|
|
exit;
|
|
P.X := MouseX;
|
|
P.Y := MouseY;
|
|
P := fGrid.ClientToScreen(P);
|
|
fMenu.Popup(P.X,P.Y);
|
|
end;
|
|
|
|
|
|
{.$define MARKEDROWSCOLORED}
|
|
// if defined, all Marked[] rows are highligted with a different background color
|
|
|
|
procedure NewDrawCellBackground(Sender: TObject; ACol, ARow: Integer;
|
|
Rect: TRect; State: TGridDrawState;
|
|
{$ifdef USETMSPACK} TabAppearance: TTabAppearance;{$endif} Marked: boolean);
|
|
var Grid: TDrawGrid absolute Sender;
|
|
begin
|
|
if not Sender.InheritsFrom(TDrawGrid) then
|
|
exit;
|
|
{$ifdef USETMSPACK}
|
|
if TabAppearance<>nil then
|
|
with TabAppearance, Grid.Canvas do begin
|
|
Font := Grid.Font;
|
|
if (gdFixed in State) then begin
|
|
Brush.Color := BackGround.Color;
|
|
Font.Color := TextColor;
|
|
Pen.Color := ShadowColor;
|
|
inc(Rect.Bottom,1);
|
|
MoveTo(Rect.Right,Rect.Top);
|
|
LineTo(Rect.Right,Rect.Bottom);
|
|
end else
|
|
if Marked then
|
|
if (gdSelected in State) then begin
|
|
Brush.Color := HighLightColorSelected;
|
|
Font.Color := TextColorHot;
|
|
end else
|
|
Brush.Color := HighLightColor else
|
|
if (gdSelected in State) then begin
|
|
Brush.Color := ColorHot;
|
|
Font.Color := TextColorHot;
|
|
end else
|
|
Brush.Color := ColorTo;
|
|
{$else}
|
|
with Grid.Canvas do begin
|
|
Font := Grid.Font;
|
|
if gdFixed in State then begin
|
|
Font.Color := clCaptionText;
|
|
Brush.Color := clGradientInactiveCaption;
|
|
Pen.Color := clGrayText;
|
|
inc(Rect.Bottom,1);
|
|
MoveTo(Rect.Right,Rect.Top);
|
|
LineTo(Rect.Right,Rect.Bottom);
|
|
end else
|
|
if (gdSelected in State) then begin
|
|
Font.Color := clHighlightText;
|
|
Brush.Color := clHighlight;
|
|
end else begin
|
|
Font.Color := clWindowText;
|
|
Brush.Color := clWindow;
|
|
end;
|
|
{$endif}
|
|
FillRect(Rect);
|
|
end;
|
|
end;
|
|
|
|
procedure TSQLLister.OnDrawCellBackground(Sender: TObject; ACol,
|
|
ARow: Integer; Rect: TRect; State: TGridDrawState);
|
|
begin // draw the cell of a TDrawGrid according to the current Theming of Page
|
|
if (self=nil) or (Page=nil) then
|
|
exit;
|
|
NewDrawCellBackground(Sender,ACol,ARow,Rect,State,
|
|
{$ifdef USETMSPACK}TAdvToolBarOfficeStyler(Page.AdvToolBarPager.ToolBarStyler).TabAppearance,{$endif}
|
|
{$ifdef MARKEDROWSCOLORED}TableToGrid.Marked[ARow]{$else}false{$endif});
|
|
end;
|
|
|
|
function TSQLLister.NewMenuItem(Menu: TPopupMenu; const aCaption: string;
|
|
ImageIndex: integer=-1; SubMenu: TMenuItem=nil; OnClick: TNotifyEvent=nil;
|
|
itemEnabled: boolean=true): TMenuItem;
|
|
begin
|
|
result := TMenuItem.Create(Menu);
|
|
result.Caption := aCaption;
|
|
if not itemEnabled then
|
|
result.Enabled := false;
|
|
if Assigned(OnClick) then
|
|
result.OnClick := OnClick else
|
|
result.OnClick := ActionButtonClick;
|
|
if ImageIndex>=0 then
|
|
result.ImageIndex := ImageIndex;
|
|
if SubMenu=nil then
|
|
Menu.Items.Add(result) else
|
|
SubMenu.Add(result);
|
|
end;
|
|
|
|
function TSQLLister.FindButton(ActionIndex: integer): TSynToolButton;
|
|
var iTB, iGB: integer;
|
|
begin
|
|
dec(ActionIndex);
|
|
for iTB := 0 to fPage.ToolBarCount-1 do
|
|
with fPage.ToolBars[iTB] do
|
|
for iGB := 0 to ComponentCount-1 do begin
|
|
result := TSynToolButton(Components[iGB]);
|
|
if result.InheritsFrom(TSynToolButton) and (result.ImageIndex=ActionIndex) then
|
|
exit;
|
|
end;
|
|
result := nil;
|
|
end;
|
|
|
|
function TSQLLister.ActionHint(const Action): string;
|
|
var B: TSynToolButton;
|
|
begin
|
|
B := FindButton(Byte(Action));
|
|
if B=nil then
|
|
result := '' else
|
|
result := B.Hint;
|
|
end;
|
|
|
|
function TSQLLister.FindMenuItem(ActionIndex: integer): TMenuItem;
|
|
var i: integer;
|
|
begin
|
|
dec(ActionIndex);
|
|
for i := 0 to fMenu.Items.Count-1 do begin
|
|
result := fMenu.Items[i];
|
|
if result.ImageIndex=ActionIndex then
|
|
exit;
|
|
end;
|
|
result := nil;
|
|
end;
|
|
|
|
procedure TSQLLister.CreateSubMenuItem(const aCaption: string;
|
|
ActionIndex: integer; OnClick: TNotifyEvent; ImageIndex, Tag: integer;
|
|
itemEnabled: boolean);
|
|
begin
|
|
if (fCreateSubMenuLastMenu=nil) or (fCreateSubMenuLastAction<>ActionIndex) then begin
|
|
fCreateSubMenuLastMenu := nil;
|
|
fCreateSubMenuLastButton := FindButton(ActionIndex);
|
|
if fCreateSubMenuLastButton=nil then exit; // avoid GPF
|
|
if fCreateSubMenuLastButton.DropDownMenu=nil then begin
|
|
fCreateSubMenuLastButton.DropDownMenu := TSynPopupMenu.Create(fGrid);
|
|
fCreateSubMenuLastButton.DropDownMenu.Images := fMenu.Images;
|
|
end;
|
|
fCreateSubMenuLastMenu := FindMenuItem(ActionIndex);
|
|
fCreateSubMenuLastAction := ActionIndex;
|
|
end;
|
|
if (fCreateSubMenuLastMenu=nil) or (fCreateSubMenuLastButton=nil) then exit;
|
|
if aCaption='' then begin // erase any previous menu content
|
|
fCreateSubMenuLastButton.DropDownMenu.Items.Clear;
|
|
fCreateSubMenuLastMenu.Clear; // erase any previous menu content
|
|
end else begin
|
|
NewMenuItem(fMenu,aCaption,ImageIndex,fCreateSubMenuLastMenu,
|
|
OnClick,itemEnabled).Tag := Tag;
|
|
NewMenuItem(fCreateSubMenuLastButton.DropDownMenu,aCaption,ImageIndex,nil,
|
|
OnClick,itemEnabled).Tag := Tag;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TSQLRibbonTab }
|
|
|
|
function TSQLRibbonTab.AskForAction(const ActionCaption, aTitle: string;
|
|
Client: TSQLRest; DontAskIfOneRow, ReturnMarkedIfSomeMarked: boolean): integer;
|
|
var i: integer;
|
|
{$ifdef USETMSPACK}
|
|
Capt, Txt: string; // generic VCL string
|
|
{$else}
|
|
TaskDialog: TTaskDialog;
|
|
CommonButtons: TCommonButtons;
|
|
DefaultButton: integer;
|
|
{$endif}
|
|
begin
|
|
if TableToGrid.Table.RowCount<1 then
|
|
result := 0 else
|
|
if DontAskIfOneRow and
|
|
(TableToGrid.Table.RowCount=1) and (TDrawGrid(TableToGrid.Owner).Row=1) then
|
|
result := 100 else // one Row (only one workstation) -> "apply to selected"
|
|
if ReturnMarkedIfSomeMarked and TableToGrid.MarkAvailable then
|
|
result := 101 else // force "Apply to Marked"
|
|
{$ifdef USETMSPACK}
|
|
with CreateAdvTaskDialog do
|
|
try
|
|
if aTitle='' then
|
|
Title := SMsgDlgConfirm else
|
|
Title := aTitle;
|
|
Instruction := ActionCaption;
|
|
Icon := tiQuestion;
|
|
Capt := '';
|
|
with TableToGrid do
|
|
if MarkAvailable and not MarkedIsOnlyCurrrent then begin
|
|
for i := 1 to Table.RowCount do
|
|
if Marked[i] then
|
|
if length(Capt)>500 then begin
|
|
Capt := Capt+'<br> ...';
|
|
break;
|
|
end else
|
|
Capt := Capt+'<br> '+ExpandRowAsString(i,Client);
|
|
end;
|
|
if Capt<>'' then begin
|
|
// we have some marked entries -> ask if perform on them, or selected only
|
|
CommonButtons := [cbCancel];
|
|
Custombuttons.Add(sApplyToSelected);
|
|
Custombuttons.Add(sApplyToMarked);
|
|
Capt := sPerformToMarkedOrSelected+Capt;
|
|
DefaultButton := integer(mrCancel);
|
|
end else begin
|
|
// we have no marked entry -> confirm action on selected
|
|
CommonButtons := [cbYes,cbNo];
|
|
DefaultButton := integer(mrNo);
|
|
Capt := sPerformToSelected;
|
|
end;
|
|
Txt := TableToGrid.ExpandRowAsString(TDrawGrid(TableToGrid.Owner).Row,Client);
|
|
Content := format(Capt,[Txt]);
|
|
result := Execute;
|
|
if (DefaultButton=integer(mrNo)) and (result=IDYES) then
|
|
// "Apply to Selected" was choosen
|
|
result := 100;
|
|
finally
|
|
Free;
|
|
end;
|
|
{$else}
|
|
with TaskDialog do begin
|
|
if aTitle='' then
|
|
Title := SMsgDlgConfirm else
|
|
Title := aTitle;
|
|
Inst := ActionCaption;
|
|
with TableToGrid do
|
|
if MarkAvailable and not MarkedIsOnlyCurrrent then begin
|
|
for i := 1 to Table.RowCount do
|
|
if Marked[i] then
|
|
if length(Content)>500 then begin
|
|
Content := Content+'\n ...';
|
|
break;
|
|
end else
|
|
Content := Content+'\n '+ExpandRowAsString(i,Client);
|
|
end;
|
|
if Content<>'' then begin
|
|
// we have some marked entries -> ask if perform on them, or selected only
|
|
CommonButtons := [cbCancel];
|
|
Buttons := sApplyToSelected+#13#10+sApplyToMarked;
|
|
Content := sPerformToMarkedOrSelected+Content;
|
|
DefaultButton := integer(mrCancel);
|
|
end else begin
|
|
// we have no marked entry -> confirm action on selected
|
|
CommonButtons := [cbYes,cbNo];
|
|
DefaultButton := integer(mrNo);
|
|
Content := sPerformToSelected;
|
|
end;
|
|
Content := format(Content,
|
|
[TableToGrid.ExpandRowAsString(TDrawGrid(TableToGrid.Owner).Row,Client)]);
|
|
result := Execute(CommonButtons,DefaultButton,[],tiQuestion);
|
|
if (DefaultButton=integer(mrNo)) and (result=IDYES) then
|
|
// "Apply to Selected" was choosen
|
|
result := 100;
|
|
end;
|
|
{$endif USETMSPACK}
|
|
end;
|
|
|
|
destructor TSQLRibbonTab.Destroy;
|
|
begin
|
|
FreeAndNil(CurrentRecord);
|
|
inherited;
|
|
end;
|
|
|
|
{.$define CREATEICONSREPORT}
|
|
// if defined, a report is created containing all icons for this toolbar
|
|
// -> not working yet
|
|
|
|
constructor TSQLRibbonTab.Create(ToolBar: TSynPager; Body: TSynBodyPager;
|
|
aImageList32,aImageList16: TImageList; var aPagesShortCuts: TFreeShortCut;
|
|
const aTabParameters: TSQLRibbonTabParameters;
|
|
Client: TSQLRestClientURI; aUserRights: TSQLFieldBits;
|
|
aOnValueText: TValueTextEvent; SetAction: TSQLRibbonSetActionEvent;
|
|
const ActionsTBCaptionCSV, ActionsHintCaption: string; ActionIsNotButton: pointer;
|
|
aOnActionClick: TSQLListerEvent; ViewToolbarIndex: integer;
|
|
aHideDisabledButtons, aHeaderCheckboxSelectsInsteadOfSort: boolean);
|
|
var W: string;
|
|
U: RawUTF8;
|
|
i, LW: integer;
|
|
PC: PChar;
|
|
TestEnabled: boolean;
|
|
A: array[0..31] of byte; // enough space for a set of 256 elements
|
|
TB: TSynToolBar;
|
|
Act: TSQLActions absolute A;
|
|
OK: boolean;
|
|
{$ifdef CREATEICONSREPORT}
|
|
IcoRep: TGDIPages;
|
|
{$endif}
|
|
begin
|
|
Table := aTabParameters.Table;
|
|
TableIndex := Client.Model.GetTableIndex(Table);
|
|
Parameters := @aTabParameters;
|
|
assert(TableIndex>=0);
|
|
// create tab on ribbon
|
|
if aTabParameters.CustomCaption<>nil then
|
|
W := LoadResString(aTabParameters.CustomCaption) else // do the translation
|
|
W := '';
|
|
Tab := TSQLLister.AddPage(ToolBar,Table,W,false);
|
|
assert(TableIndex=Tab.PageIndex); // as expected in SetAction()
|
|
// create Body page
|
|
{$ifdef USETMSPACK}
|
|
Page := Body.AdvPages[Body.AddAdvPage(Table.ClassName)]; {$else}
|
|
Page := Body.Pages[Body.AddPage(Table.ClassName)];
|
|
{$endif}
|
|
Page.TabVisible := false;
|
|
if not (TableIndex in aUserRights) then begin
|
|
Tab.TabVisible := false;
|
|
exit; // this Table won't be visible in the client area
|
|
end;
|
|
{$ifdef USETMSPACK}
|
|
Tab.ShortCutHintPos := shpBottom;
|
|
Tab.ShortCutHint := aPagesShortCuts.FindFreeShortCut(Tab.Caption);
|
|
{$endif}
|
|
Tab.ShowHint := true;
|
|
FrameLeft := TFrame.Create(Body);
|
|
FrameLeft.Parent := Page;
|
|
List := TDrawGrid.Create(Body);
|
|
List.Parent := FrameLeft;
|
|
List.Align := alClient;
|
|
Lister := TSQLLister.Create(Page,Client,Table,List,not aTabParameters.ShowID,
|
|
Toolbar,aImageList32,aImageList16,aOnActionClick,aOnValueText,
|
|
'ID,'+aTabParameters.Select,aHideDisabledButtons,aHeaderCheckboxSelectsInsteadOfSort);
|
|
TableToGrid := Lister.TableToGrid;
|
|
U := aTabParameters.FieldWidth;
|
|
if aTabParameters.ShowID then
|
|
U := 'b'+U; // ID is shown centered in first column
|
|
if assigned(SetAction) then
|
|
SetAction(Tab.PageIndex,-1,false,A) else // -1 -> A := mark toolbar
|
|
fillchar(A,sizeof(A),0);
|
|
if TableToGrid<>nil then begin
|
|
TableToGrid.SetFieldLengthMean(U,actMark in Act); // actMark -> add checkboxes
|
|
if cardinal(aTabParameters.OrderFieldIndex)<cardinal(TableToGrid.Table.FieldCount) then begin
|
|
TableToGrid.SortForce(
|
|
aTabParameters.OrderFieldIndex,not aTabParameters.ReverseOrder);
|
|
List.Row := 1;
|
|
end;
|
|
end;
|
|
if aTabParameters.Layout=llClient then begin
|
|
FrameLeft.Align := alClient;
|
|
// no FrameSplit nor FrameRight necessary
|
|
end else begin // llLeft, llUp, llLeftUp:
|
|
FrameRight := TFrame.Create(Body);
|
|
FrameRight.Parent := Page;
|
|
FrameRight.Align := alClient;
|
|
FrameSplit := TSplitter.Create(Body);
|
|
FrameSplit.Parent := Page;
|
|
LW := aTabParameters.ListWidth;
|
|
if LW=0 then
|
|
LW := 30; // default list width is 30%
|
|
case aTabParameters.Layout of
|
|
llLeft, llLeftUp: begin
|
|
FrameLeft.Width := (Page.ClientWidth*LW)div 100;
|
|
FrameLeft.Align := Controls.alLeft;
|
|
FrameSplit.Left:= FrameLeft.Width;
|
|
end;
|
|
llUp: begin
|
|
FrameLeft.Height := (Page.ClientHeight*LW)div 100;
|
|
FrameLeft.Align := Controls.alTop;
|
|
FrameSplit.Top := FrameLeft.Height;
|
|
end;
|
|
end;
|
|
FrameSplit.Align := FrameLeft.Align;
|
|
if TableToGrid<>nil then
|
|
FrameRight.OnResize := TableToGrid.Resize;
|
|
if not aTabParameters.NoReport then begin
|
|
Report := TGDIPages.Create(Body);
|
|
Report.ForceScreenResolution := true;
|
|
Report.Parent := FrameRight;
|
|
Report.Align := alClient;
|
|
Report.Zoom := PAGE_WIDTH;
|
|
{$ifdef USETMSPACK}
|
|
Report.Color := (Toolbar.ToolBarStyler as TAdvToolBarOfficeStyler).
|
|
DockColor.Color;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
// create toolbars on ribbon for this tab
|
|
// TestEnabled := false -> first create all buttons
|
|
// TestEnabled := true -> then enabled or disable the buttons,
|
|
// according to user rights
|
|
if assigned(SetAction) then begin
|
|
{$ifdef CREATEICONSREPORT}
|
|
IcoRep := TGDIPages.Create(nil);
|
|
IcoRep.BeginDoc;
|
|
IcoRep.DrawTitle(Page.Caption,true);
|
|
{$endif}
|
|
Lister.ActionHints := ActionsHintCaption;
|
|
for TestEnabled := false to true do begin
|
|
PC := pointer(ActionsTBCaptionCSV);
|
|
i := 0;
|
|
while PC<>nil do begin
|
|
if aHideDisabledButtons then
|
|
OK := true else
|
|
OK := TestEnabled;
|
|
W := SetAction(Tab.PageIndex,i,OK,A); // actions for this toolbar
|
|
if W='' then begin
|
|
W := GetNextItemString(PC);
|
|
if W='%' then // display the Tab name as Toolbar caption
|
|
W := Tab.Caption else
|
|
if W='%%' then // display the table name as Toolbar caption
|
|
W := Table.CaptionName;
|
|
end else
|
|
GetNextItemString(PC); // customized caption -> just ignore default
|
|
{$ifdef CREATEICONSREPORT}
|
|
if TestEnabled then begin
|
|
IcoRep.DrawTitle('"'+W+'" Toolbar');
|
|
end;
|
|
{$endif}TB := Lister.SetToolBar(W,A,ActionIsNotButton);
|
|
if i=ViewToolbarIndex then
|
|
ViewToolbar := TB;
|
|
inc(i);
|
|
end;
|
|
end;
|
|
{$ifdef CREATEICONSREPORT}
|
|
IcoRep.EndDoc;
|
|
IcoRep.ShowPreviewForm;
|
|
IcoRep.Free;
|
|
{$endif}
|
|
end;
|
|
// update Report popup menu
|
|
if (Report<>nil) and (ViewToolbar<>nil) then begin
|
|
Report.PopupMenu := TSynPopupMenu.Create(Report);
|
|
{$ifdef USETMSPACK}
|
|
ViewToolBar.ShowOptionIndicator := true;
|
|
ViewToolbar.OnOptionClick := ReportOptionEvent;
|
|
{$endif}
|
|
end;
|
|
{$ifndef USETMSPACK}
|
|
Lister.Page.ToolBarCreated;
|
|
{$endif}
|
|
end;
|
|
|
|
function TSQLRibbonTab.Retrieve(Client: TSQLRestClient; ARow: integer; ForUpdate: boolean=false): boolean;
|
|
var ID: integer;
|
|
begin
|
|
FreeAndNil(CurrentRecord); // force Destroy: private fields MUST be reset
|
|
if (Client=nil) or (ARow<=0) then
|
|
result := false else begin
|
|
CurrentRecord := Table.Create;
|
|
ID := TableToGrid.Table.IDColumnHiddenValue(ARow);
|
|
if ID<=0 then
|
|
result := false else
|
|
result := Client.Retrieve(ID,CurrentRecord,ForUpdate);
|
|
end;
|
|
end;
|
|
|
|
procedure TSQLRibbonTab.ReportOptionEvent(Sender: TObject; ClientPoint,
|
|
ScreenPoint: TPoint);
|
|
begin
|
|
Report.PopupMenu.Popup(ScreenPoint.X,ScreenPoint.Y);
|
|
end;
|
|
|
|
procedure TSQLRibbonTab.CustomReportPopupMenu(OnClick: TNotifyEvent;
|
|
ParamsEnum: PTypeInfo; ParamsEnabled: pointer; const Values: array of PBoolean);
|
|
begin
|
|
if (ParamsEnum=nil) or not (ParamsEnum^.Kind=tkEnumeration) then
|
|
exit;
|
|
Report.OnPopupMenuPopup := ReportPopup;
|
|
Report.OnPopupMenuClick := ReportClick;
|
|
FReportPopupClick := OnClick;
|
|
FReportPopupParams := ParamsEnum^.EnumBaseType;
|
|
FReportPopupParamsEnabled := ParamsEnabled;
|
|
SetLength(FReportPopupValues,FReportPopupParams.MaxValue+1);
|
|
move(Values[0],FReportPopupValues[0],length(Values)*sizeof(Values[0]));
|
|
end;
|
|
|
|
procedure TSQLRibbonTab.AddReportPopupMenuOptions(Menu: TPopupMenu; OnClick: TNotifyEvent);
|
|
var P: PShortString;
|
|
i: integer;
|
|
function AddReportMenu(const Caption: string): TMenuItem;
|
|
begin
|
|
result := Lister.NewMenuItem(Menu,Caption,-1,nil,OnClick);
|
|
result.Tag := 1000+i;
|
|
end;
|
|
begin
|
|
if (self=nil) or (FReportPopupParams=nil) or (FReportPopupParamsEnabled=nil) then
|
|
exit;
|
|
if not Assigned(OnClick) and (Report<>nil) then
|
|
OnClick := Report.PopupMenuItemClick;
|
|
AddReportMenu('-'); // separator
|
|
P := @FReportPopupParams^.NameList;
|
|
for i := 0 to FReportPopupParams^.MaxValue do begin
|
|
if GetBitPtr(FReportPopupParamsEnabled,i) then
|
|
with AddReportMenu(Table.CaptionNameFromRTTI(P)) do
|
|
Checked := (FReportPopupValues[i]<>nil) and FReportPopupValues[i]^;
|
|
inc(PByte(P),ord(P^[0])+1); // next enumeration item
|
|
end;
|
|
end;
|
|
|
|
procedure TSQLRibbonTab.ReportPopup(Sender: TObject);
|
|
begin
|
|
AddReportPopupMenuOptions(Report.PopupMenu,nil);
|
|
end;
|
|
|
|
procedure TSQLRibbonTab.ReportClick(Sender: TObject);
|
|
var M: TMenuItem absolute Sender;
|
|
i: integer;
|
|
begin
|
|
if (Sender<>nil) and not Sender.InheritsFrom(TMenuItem) then
|
|
exit;
|
|
if FReportPopupValues=nil then
|
|
exit; // avoid GPF
|
|
i := M.Tag-1000;
|
|
if (cardinal(i)<=cardinal(high(FReportPopupValues))) and
|
|
(FReportPopupValues[i]<>nil) then begin
|
|
FReportPopupValues[i]^ := not FReportPopupValues[i]^;
|
|
M.Checked := FReportPopupValues[i]^;
|
|
if Assigned(FReportPopupClick) then
|
|
FReportPopupClick(Sender);
|
|
end;
|
|
end;
|
|
|
|
function TSQLRibbonTab.GetCurrentID: TID;
|
|
begin
|
|
if (self=nil) or (TableToGrid=nil) or (List=nil) then
|
|
result := 0 else
|
|
result := TableToGrid.Table.IDColumnHiddenValue(List.Row);
|
|
end;
|
|
|
|
{ TFreeShortCut }
|
|
|
|
function TFreeShortCut.FindFreeShortCut(const aCaption: string): string;
|
|
var c: AnsiChar;
|
|
i: integer;
|
|
begin
|
|
for i := 1 to length(aCaption) do begin
|
|
{$ifdef UNICODE}
|
|
if word(aCaption[i])>255 then
|
|
continue;
|
|
{$endif}
|
|
c := NormToUpper[AnsiChar(aCaption[i])];
|
|
if (c in ['A'..'Z']) and not (ord(c) in Values) then begin
|
|
Include(Values,ord(c)); // one char shortcut
|
|
result := string(c);
|
|
exit;
|
|
end;
|
|
end;
|
|
result := '';
|
|
end;
|
|
|
|
|
|
{ TSQLCustomToolBar }
|
|
|
|
function TSQLCustomToolBar.AddToolBar(const ToolBarName: string;
|
|
ActionsBits: pointer=nil; ButtonWidth: integer=60): TSynToolBar;
|
|
var TypeName: PShortString;
|
|
iAction: integer;
|
|
ActionNames: TStringDynArray;
|
|
begin
|
|
if (ActionsEnum=nil) or (ActionsBits=nil) then
|
|
// no enum -> add a void toolbar
|
|
result := Page.CreateToolBar else begin
|
|
result := nil;
|
|
for iAction := 0 to ActionsEnum^.MaxValue do
|
|
if GetBitPtr(ActionsBits,iAction) then begin
|
|
result := Page.CreateToolBar;
|
|
break;
|
|
end;
|
|
end;
|
|
SetLength(ToolBars,length(ToolBars)+1); // ToolBars[] index is OK
|
|
if result=nil then
|
|
exit; // only create the toolbar if any button to put inside ;)
|
|
ToolBars[high(ToolBars)] := result;
|
|
try
|
|
{$ifdef USETMSPACK}
|
|
result.BeginUpdate;
|
|
result.AutoPositionControls := true;
|
|
result.ShowOptionIndicator := false;
|
|
result.AutoSize := true;
|
|
{$else}
|
|
result.Images := ImageList;
|
|
{$endif}
|
|
result.Caption := ToolBarName;
|
|
if ActionsEnum=nil then
|
|
exit;
|
|
SetLength(ActionNames,ActionsEnum^.MaxValue+1);
|
|
TypeName := @ActionsEnum^.NameList;
|
|
for iAction := 0 to ActionsEnum^.MaxValue do begin
|
|
ActionNames[iAction] := TSQLRecord.CaptionNameFromRTTI(TypeName); // expanded caption
|
|
inc(PByte(TypeName),ord(TypeName^[0])+1); // next enumerate value name
|
|
{$ifndef USETMSPACK}
|
|
end; // TToolBar adds at 1st position -> downto
|
|
for iAction := ActionsEnum^.MaxValue downto 0 do begin
|
|
{$endif}
|
|
if (ActionsBits=nil) or GetBitPtr(ActionsBits,iAction) then
|
|
Buttons[iAction] := result.CreateToolButton(ButtonClick,iAction,
|
|
ImageListFirstIndex,ActionNames[iAction],ActionHints,ShortCutUsed,
|
|
ButtonWidth,ImageList);
|
|
end;
|
|
finally
|
|
{$ifdef USETMSPACK}
|
|
result.EndUpdate;
|
|
{$else}
|
|
Page.ToolBarCreated; // create Caption label under toolbar
|
|
{$endif}
|
|
end;
|
|
end;
|
|
|
|
function TSQLCustomToolBar.CreateSubMenuItem(aButtonIndex: integer;
|
|
const aCaption: string; aOnClick: TNotifyEvent; aTag: integer): TMenuItem;
|
|
begin
|
|
result := nil;
|
|
if (@self<>nil) and (cardinal(aButtonIndex)<=cardinal(high(Buttons))) then
|
|
with Buttons[aButtonIndex] do begin
|
|
if DropDownMenu=nil then
|
|
DropDownMenu := TSynPopupMenu.Create(Page);
|
|
if aCaption='' then // erase any previous menu content
|
|
DropDownMenu.Items.Clear else begin // or add item
|
|
result := TMenuItem.Create(DropDownMenu);
|
|
result.Caption := aCaption;
|
|
result.OnClick := aOnClick;
|
|
result.Tag := aTag;
|
|
DropDownMenu.Items.Add(result);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TSQLCustomToolBar.Init(aToolbarOrPage: TControl; aEnum: PTypeInfo;
|
|
aButtonClick: TNotifyEvent; aImageList: TImageList; const aActionHints: string;
|
|
aImageListFirstIndex: integer);
|
|
var ToolBar: TSynPager absolute aToolbarOrPage;
|
|
begin
|
|
if aToolbarOrPage.InheritsFrom(TCustomForm) then begin
|
|
ToolBar := TSynPager.CreatePager(TCustomForm(aToolbarOrPage),true);
|
|
{$ifndef USETMSPACK}
|
|
ToolBar.FormNoCaption;
|
|
{$endif}
|
|
end;
|
|
if aToolbarOrPage.InheritsFrom(TSynPager) then begin
|
|
Page := TSQLLister.AddPage(ToolBar,nil,'',False);
|
|
{$ifdef USETMSPACK}
|
|
if ToolBar.Parent.InheritsFrom(TSynForm) then
|
|
ToolBar.MinimizeApp := false; // so WMSyscommand method will be called below
|
|
{$endif}
|
|
ToolBar.ActivePageIndex := 0;
|
|
end else
|
|
if aToolbarOrPage.InheritsFrom(TSynPage) then
|
|
Page := pointer(aToolbarOrPage) else
|
|
assert(false);
|
|
if aEnum^.Kind=tkEnumeration then begin
|
|
ActionsEnum := aEnum^.EnumBaseType;
|
|
SetLength(Buttons,ActionsEnum^.MaxValue+1);
|
|
end;
|
|
ButtonClick := aButtonClick;
|
|
ImageList := aImageList;
|
|
ActionHints := aActionHints;
|
|
ImageListFirstIndex := aImageListFirstIndex;
|
|
end;
|
|
|
|
|
|
{$ifdef USETMSPACK}
|
|
|
|
{ TSynForm }
|
|
|
|
procedure TSynForm.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
HideAppFormTaskBarButton; // check if not already hidden
|
|
inherited CreateParams(Params);
|
|
Params.ExStyle := Params.ExStyle and not WS_EX_TOOLWINDOW or
|
|
WS_EX_APPWINDOW; // this form will appear in the TaskBar
|
|
end;
|
|
|
|
procedure TSynForm.WMSyscommand(var M: TMessage);
|
|
begin
|
|
case (M.WParam and $FFF0) of
|
|
SC_MINIMIZE, SC_RESTORE, SC_MAXIMIZE: begin
|
|
M.Result := DefWindowProc(self.Handle, M.Msg, M.WParam, M.LParam);
|
|
ShowWindow(Application.Handle, SW_HIDE);
|
|
end;
|
|
else
|
|
inherited;
|
|
end;
|
|
end;
|
|
|
|
{$endif USETMSPACK}
|
|
|
|
function LoadBitmapFromResource(const ResName: string; Instance: THandle): TBitmap;
|
|
var Pic: TSynPicture;
|
|
begin
|
|
if Instance=0 then
|
|
Instance := HInstance;
|
|
result := TBitmap.Create;
|
|
try
|
|
Pic := TSynPicture.Create;
|
|
try
|
|
Pic.LoadFromResourceName(Instance,ResName); // *.png
|
|
result.Width := Pic.Width;
|
|
result.Height := Pic.Height;
|
|
result.Canvas.Draw(0,0,Pic);
|
|
finally
|
|
Pic.Free;
|
|
end;
|
|
except
|
|
on Exception do
|
|
FreeAndNil(result);
|
|
end;
|
|
end;
|
|
|
|
procedure ImageListStretch(ImgListSource, ImgListDest: TImageList;
|
|
BkColor: TColor=clSilver);
|
|
var BmpSource, BmpDest: TBitmap;
|
|
i: integer;
|
|
Pic: TSynPicture;
|
|
RS,RD: TRect;
|
|
begin
|
|
ImgListDest.Clear;
|
|
if Gdip=nil then
|
|
Gdip := TGDIPlusFull.Create;
|
|
Pic := TSynPicture.Create;
|
|
BmpSource := TBitmap.Create;
|
|
BmpDest := TBitmap.Create;
|
|
try
|
|
RS.Left := 0;
|
|
RS.Top := 0;
|
|
RS.Right := ImgListSource.Width;
|
|
RS.Bottom := ImgListSource.Height;
|
|
BmpSource.Width := RS.Right;
|
|
BmpSource.Height := RS.Bottom;
|
|
RD.Left := 0;
|
|
RD.Top := 0;
|
|
RD.Right := ImgListDest.Width;
|
|
RD.Bottom := ImgListDest.Height;
|
|
BmpDest.Width := RD.Right;
|
|
ImgListDest.Masked := false;
|
|
BmpDest.Height := RD.Bottom;
|
|
for i := 0 to ImgListSource.Count-1 do begin
|
|
BmpSource.Canvas.Brush.Color := BkColor;
|
|
BmpSource.Canvas.Brush.Style := bsSolid;
|
|
BmpSource.Canvas.FillRect(RS);
|
|
ImgListSource.Draw(BmpSource.Canvas,0,0,i);
|
|
Pic.Assign(BmpSource);
|
|
Pic.Draw(BmpDest.Canvas,RD); // GDI+ smooth draw
|
|
ImgListDest.Add(BmpDest,nil);
|
|
end;
|
|
finally
|
|
BmpDest.Free;
|
|
BmpSource.Free;
|
|
Pic.Free;
|
|
end;
|
|
end;
|
|
|
|
function AddIconToImageList(ImgList: TCustomImageList; Icon: HIcon): integer;
|
|
var Bmp: TBitmap;
|
|
begin
|
|
Bmp := TBitmap.Create;
|
|
try
|
|
Bmp.Transparent := true;
|
|
Bmp.Canvas.Brush.Color := clWhite;
|
|
Bmp.Width := ImgList.Width;
|
|
Bmp.Height := ImgList.Height;
|
|
DrawIconEx(Bmp.Canvas.Handle,0,0,Icon,ImgList.Width,ImgList.Height,0,
|
|
Bmp.Canvas.Brush.Handle,DI_NORMAL);
|
|
DestroyIcon(Icon);
|
|
result := ImgList.AddMasked(Bmp,clWhite);
|
|
finally
|
|
Bmp.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure LoadImageListFromBitmap(ImgList: TCustomImageList; Bmp: TBitmap);
|
|
var i: integer;
|
|
BW,BH,W,H: integer;
|
|
begin
|
|
// from multi-line (i.e. IDE export) into one-line (for AddMasked)
|
|
BW := Bmp.Width;
|
|
BH := Bmp.Height;
|
|
W := (BW div ImgList.Width);
|
|
H := (BH div ImgList.Height);
|
|
Bmp.Width := W*H*ImgList.Width;
|
|
BH := ImgList.Height;
|
|
for i := 2 to H do
|
|
Bmp.Canvas.CopyRect(Rect((i-1)*BW,0,i*BW,BH),
|
|
Bmp.Canvas,Rect(0,(i-1)*BH,BW,i*BH));
|
|
Bmp.Height := BH;
|
|
// add these images to the image list
|
|
ImgList.AddMasked(Bmp,Bmp.Canvas.Pixels[0,0]);
|
|
end;
|
|
|
|
procedure LoadImageListFromEmbeddedZip(ImgList: TCustomImageList; const ZipName: TFileName);
|
|
var i: integer;
|
|
Bmp: TBitmap;
|
|
Stream: TSynMemoryStream;
|
|
begin
|
|
with TZipRead.Create(HInstance,'Zip','ZIP') do
|
|
try
|
|
i := NameToIndex(ZipName);
|
|
if i<0 then exit;
|
|
Stream := TSynMemoryStream.Create(UnZip(i)); // uncompress
|
|
try
|
|
Bmp := TBitmap.Create;
|
|
try
|
|
Bmp.LoadFromStream(Stream);
|
|
LoadImageListFromBitmap(ImgList,Bmp);
|
|
finally
|
|
Bmp.Free;
|
|
end;
|
|
finally
|
|
Stream.Free;
|
|
end;
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
{$ifndef USETMSPACK}
|
|
|
|
{ TSynToolButton }
|
|
|
|
constructor TSynToolButton.Create(aOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
AutoSize := true;
|
|
end;
|
|
|
|
procedure TSynToolButton.DoDropDown;
|
|
begin
|
|
CheckMenuDropdown;
|
|
end;
|
|
|
|
function TSynToolButton.Images: TCustomImageList;
|
|
begin
|
|
if Owner.InheritsFrom(TToolBar) then
|
|
result := TToolBar(Owner).Images else
|
|
result := nil;
|
|
end;
|
|
|
|
|
|
{ TSynPage }
|
|
|
|
const
|
|
TOOLBAR_SPACE = 20;
|
|
|
|
function TSynPage.GetToolBarNextLeft(var Last: TSynToolBar): integer;
|
|
var n, W: integer;
|
|
begin
|
|
n := length(fToolBar);
|
|
if n>0 then begin
|
|
Last := fToolBar[n-1];
|
|
with Last.Buttons[Last.ButtonCount-1] do
|
|
W := Left+Width+2;
|
|
Last.Width := W;
|
|
result := Last.Left+W+TOOLBAR_SPACE;
|
|
end else begin
|
|
result := 4;
|
|
Last := nil;
|
|
end;
|
|
end;
|
|
|
|
function TSynPage.CreateToolBar(AddToList: boolean): TSynToolBar;
|
|
var n: integer;
|
|
Last: TSynToolBar;
|
|
begin
|
|
result := TSynToolBar.Create(self);
|
|
result.Parent := self;
|
|
result.Align := alNone;
|
|
result.AutoSize := false;
|
|
result.ShowCaptions := true;
|
|
result.ButtonHeight := 58;
|
|
result.ButtonWidth := 60;
|
|
result.Height := 57;
|
|
result.Top := 7;
|
|
result.Font := DefaultFont;
|
|
result.Font.Size := result.Font.Size-1;
|
|
result.Left := GetToolBarNextLeft(Last);
|
|
if (Last<>nil) and (Last.Images<>nil) then
|
|
result.Images := Last.Images;
|
|
if AddToList then begin
|
|
n := length(fToolBar);
|
|
SetLength(fToolBar,n+1);
|
|
fToolBar[n] := result;
|
|
end;
|
|
end;
|
|
|
|
function TSynPage.GetToolBar(aIndex: integer): TSynToolBar;
|
|
begin
|
|
if cardinal(aIndex)<cardinal(length(fToolBar)) then
|
|
result := fToolBar[aIndex] else
|
|
result := nil;
|
|
end;
|
|
|
|
function TSynPage.GetToolBarCount: integer;
|
|
begin
|
|
result := length(fToolBar);
|
|
end;
|
|
|
|
procedure TSynPage.ToolBarCreated;
|
|
var n, i: integer;
|
|
Lab: TLabel;
|
|
Bev: TBevel;
|
|
Last: TSynToolBar;
|
|
begin
|
|
n := length(fToolBar);
|
|
if fToolBarCaptionsCount=n then
|
|
exit;
|
|
GetToolBarNextLeft(Last);
|
|
for i := fToolBarCaptionsCount to n-1 do begin
|
|
Lab := TLabel.Create(Self);
|
|
Lab.Parent := Self;
|
|
Lab.AutoSize := false;
|
|
Lab.Alignment := Classes.taCenter;
|
|
Lab.Font.Color := clGrayText;
|
|
Lab.Transparent := true;
|
|
Bev := TBevel.Create(Self);
|
|
Bev.Parent := Self;
|
|
with fToolBar[i] do begin
|
|
Lab.Font.Size := Font.Size;
|
|
Lab.SetBounds(Left,Top+Height+3,Width,20);
|
|
Bev.SetBounds(Left,Top+Height+1,Width,2);
|
|
Lab.Caption := Caption;
|
|
end;
|
|
Bev.Shape := bsTopLine;
|
|
end;
|
|
fToolBarCaptionsCount := n;
|
|
end;
|
|
|
|
|
|
{ TSynPager }
|
|
|
|
function TSynPager.AddPage(aPage: TSynPage): integer;
|
|
begin
|
|
aPage.PageControl := self;
|
|
result := PageCount-1;
|
|
if TabHeight=0 then
|
|
aPage.TabVisible := false;
|
|
end;
|
|
|
|
function TSynPager.AddPage(const aCaption: string): integer;
|
|
var aPage: TSynPage;
|
|
begin
|
|
aPage := TSynPage.Create(self);
|
|
aPage.Parent := self;
|
|
result := AddPage(aPage);
|
|
end;
|
|
|
|
function TSynPager.GetSynPage(aIndex: integer): TSynPage;
|
|
begin
|
|
result := inherited Pages[aIndex] as TSynPage;
|
|
end;
|
|
|
|
function TSynPager.GetActivePageIndex: integer;
|
|
begin
|
|
result := inherited ActivePageIndex;
|
|
end;
|
|
|
|
procedure TSynPager.SetActivePageIndex(const Value: integer);
|
|
begin
|
|
inherited ActivePageIndex := Value;
|
|
Change;
|
|
if Assigned(OnChange) then
|
|
OnChange(self);
|
|
end;
|
|
|
|
procedure TSynPager.Change;
|
|
var Pag: TSynPage;
|
|
Last: TSynToolBar;
|
|
begin
|
|
inherited;
|
|
if fHelpToolBar<>nil then begin
|
|
Pag := ActivePage as TSynPage;
|
|
fHelpToolBar.Parent := Pag;
|
|
fHelpToolBar.Left := Pag.GetToolBarNextLeft(Last);
|
|
end;
|
|
end;
|
|
|
|
function TSynPager.TabGroupsAdd(TabIndexStart, TabIndexEnd: integer; const aCaption: string): TLabel;
|
|
begin
|
|
assert(TopMostPanel<>nil,'expect TSynPager.CreatePager');
|
|
result := TLabel.Create(TopMostPanel);
|
|
result.Font := DefaultFont;
|
|
result.Parent := TopMostPanel;
|
|
result.Font.Color := clGrayText;
|
|
result.Font.Size := Font.Size-1;
|
|
result.Alignment := Classes.taCenter;
|
|
result.Transparent := true;
|
|
result.Caption := aCaption;
|
|
result.Left := TabWidth*TabIndexStart+8;
|
|
result.Top := 2;
|
|
result.Tag := TabIndexStart; // for GroupLabelClick to select the page
|
|
result.OnClick := GroupLabelClick;
|
|
result.Width := TabWidth*TabIndexEnd-result.Left;
|
|
with TBevel.Create(TopMostPanel) do begin
|
|
Parent := TopMostPanel;
|
|
SetBounds(result.Left+result.Width+1,2,2,result.Height+2);
|
|
Shape := bsLeftLine;
|
|
end;
|
|
end;
|
|
|
|
procedure TSynPager.FormNoCaption;
|
|
begin
|
|
if Owner.InheritsFrom(TSynForm) and (TopMostPanel<>nil) then begin
|
|
TSynForm(Owner).SetNoCaption(TopMostPanel,TabWidth*PageCount);
|
|
TSynForm(Owner).NoCaptionLabel.Font := DefaultFont;
|
|
end;
|
|
end;
|
|
|
|
procedure TSynPager.GroupLabelClick(Sender: TObject);
|
|
begin
|
|
if Sender.InheritsFrom(TLabel) then
|
|
ActivePageIndex := TLabel(Sender).Tag;
|
|
end;
|
|
|
|
class function TSynPager.CreatePager(aOwner: TCustomForm; NoTabVisible: boolean=false): TSynPager;
|
|
var H: integer;
|
|
begin
|
|
if NoTabVisible then
|
|
H := TOOLBAR_HEIGHT-TOOLBAR_TAB_HEIGHT else
|
|
H := TOOLBAR_HEIGHT;
|
|
result := TSynPager.Create(aOwner);
|
|
result.fTopMostPanel := TPanel.Create(aOwner);
|
|
with result.fTopMostPanel do begin
|
|
Parent := aOwner;
|
|
Height := H+TOOLBAR_GROUPS_HEIGHT;
|
|
Align := alTop;
|
|
end;
|
|
result.fTopPanel := TPanel.Create(aOwner);
|
|
with result.fTopPanel do begin
|
|
Parent := result.fTopMostPanel;
|
|
Height := result.fTopMostPanel.ClientHeight-TOOLBAR_GROUPS_HEIGHT;
|
|
Align := alBottom;
|
|
end;
|
|
result.Parent := result.fTopPanel;
|
|
result.Height := H;
|
|
result.HotTrack := true;
|
|
if not NoTabVisible then begin
|
|
result.TabHeight := TOOLBAR_TAB_HEIGHT;
|
|
result.TabWidth := 85;
|
|
end;
|
|
result.Font := DefaultFont;
|
|
result.Align := alTop;
|
|
end;
|
|
|
|
function TSynPager.GetHelpButton: TSynToolButton;
|
|
var Pag: TSynPage;
|
|
begin
|
|
if fHelpButton=nil then begin
|
|
fHelpButton := TSynToolButton.Create(self);
|
|
Pag := ActivePage as TSynPage;
|
|
fHelpToolBar := Pag.CreateToolBar(false);
|
|
fHelpButton.Parent := fHelpToolBar;
|
|
fHelpButton.Caption := SMsgDlgHelpHelp;
|
|
fHelpButton.ImageIndex :=
|
|
AddIconToImageList(fHelpToolBar.Images,LoadIcon(0,IDI_QUESTION));
|
|
fHelpToolBar.Width := fHelpButton.Width+3;
|
|
Pag.ToolBarCreated;
|
|
end;
|
|
result := fHelpButton;
|
|
end;
|
|
|
|
function TSynPager.GetCaption: TLabel;
|
|
begin
|
|
if Owner.InheritsFrom(TSynForm) then
|
|
result := TSynForm(Owner).NoCaptionLabel else
|
|
result := nil;
|
|
end;
|
|
|
|
{$else USETMSPACK}
|
|
|
|
{ TSynPage }
|
|
|
|
function TSynPage.CreateToolBar: TSynToolBar;
|
|
begin
|
|
result := TSynToolBar(CreateAdvToolBar);
|
|
end;
|
|
|
|
destructor TSynPage.Destroy;
|
|
begin
|
|
if BackgroundPictureStored then
|
|
FreeAndNil(fBackgroundPicture);
|
|
inherited;
|
|
end;
|
|
|
|
function TSynPage.GetToolBar(aIndex: integer): TSynToolBar;
|
|
begin
|
|
result := TSynToolBar(AdvToolBars[aIndex]);
|
|
end;
|
|
|
|
procedure TSynPage.Paint;
|
|
var Bmp: TBitmap;
|
|
W,BW: integer;
|
|
begin
|
|
inherited Paint;
|
|
if BackgroundPicture=nil then
|
|
Exit;
|
|
W := Width-BackgroundPicture.Width-4;
|
|
Canvas.Draw(W, 4, BackgroundPicture);
|
|
if W<=4 then
|
|
exit; // no tiling necessary
|
|
Bmp := TBitmap.Create;
|
|
try // need to tile for filling the left side of the page
|
|
if BackgroundPictureTiledWidth<10 then
|
|
BW := 200 else
|
|
BW := BackgroundPictureTiledWidth;
|
|
if BW>BackgroundPicture.Width then
|
|
BW := BackgroundPicture.Width;
|
|
Bmp.Width := BW;
|
|
Bmp.Height := BackgroundPicture.Height;
|
|
Bmp.Canvas.Draw(0,0,BackgroundPicture);
|
|
repeat
|
|
dec(W,Bmp.Width);
|
|
Canvas.Draw(W,4,Bmp); // replicate leftmost of the bitmap
|
|
until W<=4;
|
|
finally
|
|
Bmp.Free;
|
|
end;
|
|
end;
|
|
|
|
function TSynPage.ToolBarCount: integer;
|
|
begin
|
|
result := AdvToolBarCount;
|
|
end;
|
|
|
|
|
|
{ TSynPager }
|
|
|
|
class function TSynPager.CreatePager(aOwner: TCustomForm; NoTabVisible: boolean=false): TSynPager;
|
|
begin
|
|
result := TSynPager.Create(aOwner);
|
|
result.Parent := aOwner;
|
|
if NoTabVisible then begin
|
|
result.TabSettings.Height := 0;
|
|
result.Height := 119;
|
|
result.HelpButton.Hide;
|
|
end else
|
|
result.Height := 145;
|
|
result.ToolBarStyler := TAdvToolBarOfficeStyler.Create(aOwner);
|
|
TAdvToolBarOfficeStyler(result.ToolBarStyler).Style := bsOffice2007Luna;
|
|
end;
|
|
|
|
function TSynPager.AddPage(aPage: TSynPage): integer;
|
|
begin
|
|
result := AddAdvPage(aPage);
|
|
end;
|
|
|
|
function TSynPager.AddPage(const aCaption: string): integer;
|
|
begin
|
|
result := AddAdvPage(aCaption);
|
|
end;
|
|
|
|
function TSynPager.GetSynPage(aIndex: integer): TSynPage;
|
|
begin
|
|
result := TSynPage(AdvPages[aIndex]);
|
|
end;
|
|
|
|
function TSynPager.GetSynPageCount: integer;
|
|
begin
|
|
result := AdvPageCount;
|
|
end;
|
|
|
|
{$endif USETMSPACK}
|
|
|
|
|
|
{ TSynToolBar }
|
|
|
|
function TSynToolBar.CreateToolButton(ButtonClick: TNotifyEvent;
|
|
iAction, ImageListFirstIndex: integer; const ActionName, ActionHints: string;
|
|
var ShortCutUsed: TFreeShortCut; ButtonWidth: integer; Images: TCustomImageList): TSynToolButton;
|
|
begin
|
|
result := TSynToolButton.Create(self);
|
|
result.Caption := ActionName;
|
|
{$ifdef USETMSPACK}
|
|
result.Height := (ClientHeight-CaptionHeight)-4;
|
|
result.Width := ButtonWidth;
|
|
result.Layout := blGlyphTop;
|
|
result.ShortCutHint := ShortCutUsed.FindFreeShortCut(result.Caption);
|
|
result.ShortCutHintPos := shpBottom;
|
|
result.Images := Images;
|
|
{$endif}
|
|
result.Parent := self;
|
|
result.OnClick := ButtonClick;
|
|
result.ImageIndex := iAction-ImageListFirstIndex; // store the button enumerate value in ImageIndex
|
|
result.Tag := iAction;
|
|
result.Hint := GetCSVItemString(pointer(ActionHints),result.ImageIndex,#13);
|
|
if result.Hint<>'' then
|
|
result.ShowHint := true;
|
|
end;
|
|
|
|
|
|
{ TSQLRibbon }
|
|
|
|
function CaptionName(OnCaptionName: TOnCaptionName;
|
|
const Action: RawUTF8; Obj: TObject=nil; Index: integer=-1): string;
|
|
begin
|
|
if Assigned(OnCaptionName) then begin
|
|
result := OnCaptionName(Action,Obj,Index);
|
|
if result<>'' then
|
|
exit;
|
|
end;
|
|
// default implementation uses RTTI
|
|
if Obj=nil then
|
|
result := TSQLRecord.CaptionName(@Action) else
|
|
if Obj.InheritsFrom(TSQLRecord) then
|
|
result := TSQLRecord(Obj).CaptionName else
|
|
result := TSQLRecord.CaptionNameFromRTTI(ClassNameShort(Obj));
|
|
if Index>=0 then
|
|
result := result+' '+IntToStr(Index);
|
|
end;
|
|
|
|
procedure TSQLRibbon.BodyResize(Sender: TObject);
|
|
var P: integer;
|
|
begin
|
|
for P := 0 to high(Page) do
|
|
if Page[P]<>nil then
|
|
Page[P].TableToGrid.Resize(Sender);
|
|
end;
|
|
|
|
|
|
{$ifdef USETMSPACK}
|
|
|
|
const // bulky TMS styles don't match :(
|
|
TToolBarStyleToPanel: array[TToolBarStyle] of TAdvPanelStyle =
|
|
(psOffice2003Blue, psOffice2003Silver, psOffice2003Olive, psOffice2003Classic,
|
|
psOffice2007Luna, psOffice2007Obsidian, psWindowsXP, psWhidbey,
|
|
psOffice2003Olive {=bsCustom}, psOffice2007Silver, psXP, psWindowsVista,
|
|
psWindows7, psTerminal, psOffice2010Blue, psOffice2010Silver, psOffice2010Black);
|
|
|
|
procedure TSQLRibbon.ChangeColorScheme(
|
|
const ColorScheme: TToolBarStyle;
|
|
PanelStyler: TAdvPanelStyler;
|
|
StatusBarStyler: TAdvOfficeStatusBarOfficeStyler;
|
|
CustomStyle: TMemoryStream);
|
|
var PreviewStyle: TPreviewMenuStyle;
|
|
StatusStyle: TOfficeStatusBarStyle;
|
|
TBStyler: TAdvToolBarOfficeStyler;
|
|
i, curr: Integer;
|
|
C: TComponent;
|
|
begin
|
|
if not fToolBar.ToolBarStyler.InheritsFrom(TAdvToolBarOfficeStyler) then
|
|
exit;
|
|
TBStyler := TAdvToolBarOfficeStyler(ToolBar.ToolBarStyler);
|
|
if TBStyler=nil then
|
|
exit;
|
|
TBStyler.Style := ColorScheme;
|
|
case ColorScheme of // bulky TMS styles don't match :(
|
|
bsCustom: begin
|
|
if CustomStyle<>nil then begin
|
|
CustomStyle.Seek(0,soFromBeginning);
|
|
CustomStyle.ReadComponent(TBStyler);
|
|
end;
|
|
PreviewStyle := AdvPreviewMenuStylers.psOffice2003Olive;
|
|
StatusStyle := AdvOfficeStatusBarStylers.psOffice2003Olive;
|
|
end;
|
|
bsOffice2007Silver: begin
|
|
PreviewStyle := AdvPreviewMenuStylers.psOffice2007Silver;
|
|
StatusStyle := AdvOfficeStatusBarStylers.psOffice2007Silver;
|
|
end;
|
|
bsOfficeXP: begin
|
|
PreviewStyle := AdvPreviewMenuStylers.psOfficeXP;
|
|
StatusStyle := AdvOfficeStatusBarStylers.psWindowsXP;
|
|
end;
|
|
bsWindowsVista..high(TToolBarStyle): begin
|
|
PreviewStyle := TPreviewMenuStyle(ColorScheme);
|
|
StatusStyle := TOfficeStatusBarStyle(pred(ColorScheme));
|
|
end;
|
|
else begin
|
|
PreviewStyle := TPreviewMenuStyle(ColorScheme);
|
|
StatusStyle := TOfficeStatusBarStyle(ColorScheme);
|
|
end;
|
|
end;
|
|
if (PreviewMenu<>nil) and
|
|
PreviewMenu.Styler.InheritsFrom(TAdvPreviewMenuOfficeStyler) then
|
|
TAdvPreviewMenuOfficeStyler(PreviewMenu.Styler).Style := PreviewStyle;
|
|
if StatusBarStyler<>nil then
|
|
StatusBarStyler.Style := StatusStyle;
|
|
if PanelStyler<>nil then
|
|
PanelStyler.Style := TToolBarStyleToPanel[ColorScheme];
|
|
TBStyler.CaptionAppearance.Assign(TBStyler.GroupAppearance.CaptionAppearance);
|
|
with TBStyler.GroupAppearance.TabAppearance do begin
|
|
TBStyler.PagerCaption.TextColor := TextColor;
|
|
TBStyler.PagerCaption.TextColorExtended := TextColorSelected;
|
|
end;
|
|
if (Body<>nil) and Body.AdvOfficePagerStyler.InheritsFrom(TAdvOfficePagerOfficeStyler) then
|
|
TAdvOfficePagerOfficeStyler(Body.AdvOfficePagerStyler).Style :=
|
|
TOfficePagerStyle(StatusStyle);
|
|
// update colors for windows
|
|
for i := 0 to Application.ComponentCount-1 do begin
|
|
C := Application.Components[i];
|
|
if C.InheritsFrom(TCustomForm) then
|
|
SetStyle(C,TBStyler); // will set style for all embedded components
|
|
end;
|
|
// update report colors on every ribbon page
|
|
curr := fToolBar.ActivePageIndex;
|
|
for i := 0 to high(Page) do
|
|
with Page[i] do begin
|
|
if Report<>nil then
|
|
Report.Color := TBStyler.QATAppearance.ColorTo;
|
|
if i=curr then
|
|
List.Invalidate; // repaint list first row with new colors
|
|
end;
|
|
if Form<>nil then
|
|
Form.Invalidate; // whole form redraw
|
|
end;
|
|
{$endif USETMSPACK}
|
|
|
|
constructor TSQLRibbon.Create(Owner: TCustomForm; ToolBar: TSynPager; Body: TSynBodyPager;
|
|
aImageList32,aImageList16: TImageList;
|
|
Client: TSQLRestClientURI; aUserRights: TSQLFieldBits;
|
|
aOnValueText: TValueTextEvent; SetAction: TSQLRibbonSetActionEvent;
|
|
const ActionsTBCaptionCSV, ActionsHintCaption: string; ActionIsNotButton: pointer;
|
|
aOnActionClick: TSQLListerEvent; RefreshActionIndex, ViewToolbarIndex: integer;
|
|
aHideDisabledButtons: boolean;
|
|
PagesCount: integer; TabParameters: PSQLRibbonTabParameters; TabParametersSize: integer;
|
|
const GroupCSV: string; const BackgroundPictureResourceNameCSV: string='';
|
|
aHeaderCheckboxSelectsInsteadOfSort: boolean=false);
|
|
{$ifdef USETMSPACK}
|
|
var Pic: TGDIPPicture;
|
|
PicUsed: boolean;
|
|
ResName: string;
|
|
PS: TSynPage;
|
|
PB: PChar;
|
|
{$else}
|
|
var aPageFirst: integer;
|
|
{$endif}
|
|
aGroup: integer;
|
|
PC: PChar;
|
|
aPage: integer;
|
|
ActionsHints: string;
|
|
TP: PSQLRibbonTabParameters;
|
|
begin
|
|
if (Owner=nil) or (TabParameters=nil) or (Client=nil) then
|
|
exit;
|
|
fActionsHintCaption := ActionsHintCaption;
|
|
fTabParameters := TabParameters;
|
|
fTabParametersSize := TabParametersSize;
|
|
fClient := Client;
|
|
fForm := Owner;
|
|
if ToolBar=nil then begin
|
|
ToolBar := TSynPager.CreatePager(Owner);
|
|
{$ifdef USETMSPACK}
|
|
fPreviewMenu := TAdvPreviewMenu.Create(Owner);
|
|
fPreviewMenu.Styler := TAdvPreviewMenuOfficeStyler.Create(Owner);
|
|
TAdvPreviewMenuOfficeStyler(fPreviewMenu.Styler).Style :=
|
|
AdvPreviewMenuStylers.psOffice2007Luna;
|
|
fPreviewMenuButton := TAdvShapeButton.Create(Owner);
|
|
fPreviewMenuButton.Appearance.Shape := bsOrb;
|
|
fPreviewMenuButton.Parent := ToolBar;
|
|
fPreviewMenuButton.SetBounds(6,6,45,45);
|
|
fPreviewMenuButton.AdvPreviewMenu := fPreviewMenu;
|
|
{$endif}
|
|
end;
|
|
fToolBar := ToolBar;
|
|
if Body=nil then begin
|
|
Body := TSynBodyPager.Create(Owner);
|
|
Body.Parent := Owner;
|
|
{$ifdef USETMSPACK}
|
|
Body.AdvOfficePagerStyler := TAdvOfficePagerOfficeStyler.Create(Owner);
|
|
TAdvOfficePagerOfficeStyler(Body.AdvOfficePagerStyler).Style :=
|
|
AdvOfficePagerStylers.psOffice2007Luna;
|
|
Body.TabSettings.Height := 0;
|
|
{$endif}
|
|
end;
|
|
fBody := Body;
|
|
fOnActionClick := aOnActionClick;
|
|
fRefreshActionIndex:= RefreshActionIndex;
|
|
Body.Align := alClient;
|
|
SetLength(Page,PagesCount);
|
|
TP := TabParameters;
|
|
for aPage := 0 to PagesCount-1 do begin
|
|
if TP^.CustomHint<>nil then
|
|
ActionsHints := LoadResString(TP^.CustomHint) else
|
|
ActionsHints := TP^.Table.CaptionName(nil,true); // ForHint=true
|
|
ActionsHints := StringReplace(ActionsHintCaption,'%s',ActionsHints,[rfReplaceAll]);
|
|
Page[aPage] := TSQLRibbonTab.Create(ToolBar, Body, aImageList32, aImageList16,
|
|
ShortCuts, TP^, Client, aUserRights, aOnValueText,
|
|
SetAction, ActionsTBCaptionCSV, ActionsHints, ActionIsNotButton,
|
|
aOnActionClick, ViewToolbarIndex, aHideDisabledButtons, aHeaderCheckboxSelectsInsteadOfSort);
|
|
Inc(PtrInt(TP),TabParametersSize);
|
|
end;
|
|
aPage := 0;
|
|
aGroup := 0;
|
|
PC := pointer(GroupCSV); // 'Tab 1,Tab 2,Tab 3'
|
|
{$ifdef USETMSPACK}
|
|
PB := pointer(BackgroundPictureResourceNameCSV);
|
|
while PC<>nil do
|
|
with ToolBar.TabGroups.Add do begin
|
|
Caption := GetNextItemString(PC);
|
|
CaptionAlignment := Classes.taCenter;
|
|
TabIndexStart := aPage;
|
|
PicUsed := false;
|
|
ResName := GetNextItemString(PB);
|
|
if (ResName='') or
|
|
(FindResource(HInstance,pointer(ResName),RT_RCDATA)=0) then
|
|
Pic := nil else
|
|
Pic := TGDIPPicture.Create;
|
|
if Pic<>nil then
|
|
Pic.LoadFromResourceName(HInstance,ResName);
|
|
try
|
|
while (aPage<PagesCount) and (TabParameters^.Group=aGroup) do begin
|
|
if Pic<>nil then begin
|
|
PS := TSynPage(ToolBar.AdvPages[aPage]);
|
|
if PS.InheritsFrom(TSynPage) then begin
|
|
PS.BackgroundPicture := Pic;
|
|
if not PicUsed then begin
|
|
PS.BackgroundPictureStored := True;
|
|
PicUsed := true;
|
|
end;
|
|
end;
|
|
end;
|
|
inc(PtrInt(TabParameters),TabParametersSize);
|
|
inc(aPage);
|
|
end;
|
|
finally
|
|
if (Pic<>nil) and not PicUsed then
|
|
Pic.Free;
|
|
end;
|
|
TabIndexEnd := aPage-1;
|
|
inc(aGroup);
|
|
end;
|
|
{$else}
|
|
while PC<>nil do begin
|
|
aPageFirst := aPage;
|
|
while (aPage<PagesCount) and (TabParameters^.Group=aGroup) do begin
|
|
inc(PtrInt(TabParameters),TabParametersSize);
|
|
inc(aPage);
|
|
end;
|
|
ToolBar.TabGroupsAdd(aPageFirst,aPage,GetNextItemString(PC));
|
|
inc(aGroup);
|
|
end;
|
|
ToolBar.FormNoCaption;
|
|
{$endif}
|
|
ToolBar.OnChange := ToolBarChange;
|
|
Body.OnResize := BodyResize;
|
|
BodyResize(nil);
|
|
end;
|
|
|
|
|
|
destructor TSQLRibbon.Destroy;
|
|
var P: integer;
|
|
begin
|
|
if Form<>nil then begin
|
|
KillTimer(Form.Handle,WM_TIMER_REFRESH_SCREEN); // avoid GPF
|
|
KillTimer(Form.Handle,WM_TIMER_REFRESH_REPORT);
|
|
end;
|
|
for P := 0 to high(Page) do
|
|
FreeAndNil(Page[P]);
|
|
inherited;
|
|
end;
|
|
|
|
function TSQLRibbon.GetActivePage: TSQLRibbonTab;
|
|
var P: Integer;
|
|
begin
|
|
result := nil;
|
|
if (Self=nil) or (ToolBar=nil) then
|
|
exit;
|
|
P := Toolbar.ActivePageIndex;
|
|
if cardinal(P)<=cardinal(high(Page)) then
|
|
result := Page[P];
|
|
end;
|
|
|
|
function TSQLRibbon.GetPage(aRecordClass: TSQLRecordClass): integer;
|
|
begin
|
|
if self<>nil then
|
|
for result := 0 to high(Page) do
|
|
if (Page[result]<>nil) and (Page[result].Table=aRecordClass) then
|
|
exit;
|
|
result := -1;
|
|
end;
|
|
|
|
function TSQLRibbon.GetParameter(aPageIndex: Integer): PSQLRibbonTabParameters;
|
|
begin
|
|
if (Self=nil) or (fTabParameters=nil) or (fTabParametersSize=0) or
|
|
(cardinal(aPageIndex)>cardinal(high(Page)) )then
|
|
result := nil else
|
|
result := Pointer(PtrInt(fTabParameters)+fTabParametersSize*aPageIndex);
|
|
end;
|
|
|
|
procedure TSQLRibbon.GotoRecord(aTable: TSQLRecordClass; aID: TID;
|
|
ActionToPerform: integer);
|
|
var P,R: integer;
|
|
begin
|
|
if (self=nil) or (aTable=nil) or (aID<=0) then
|
|
exit; // no record to jump in
|
|
P := GetPage(aTable);
|
|
if P>=0 then
|
|
with Page[P] do
|
|
if TableToGrid<>nil then begin
|
|
R := TableToGrid.Table.RowFromID(aID);
|
|
if R<0 then exit;
|
|
if ToolBar.ActivePageIndex<>P then begin
|
|
ToolBar.ActivePageIndex := P;
|
|
Application.ProcessMessages;
|
|
end;
|
|
TableToGrid.Refresh;
|
|
R := TableToGrid.Table.RowFromID(aID); // do it now after Grid refresh
|
|
if R<0 then exit;
|
|
List.Row := R;
|
|
Application.ProcessMessages;
|
|
Form.BringToFront;
|
|
Application.ProcessMessages;
|
|
if (ActionToPerform<>0) and Assigned(fOnActionClick) then
|
|
// Sender needs to be <> nil
|
|
fOnActionClick(self,Table,ActionToPerform);
|
|
end;
|
|
end;
|
|
|
|
procedure TSQLRibbon.GotoRecord(aRecord: TSQLRecord; ActionToPerform: integer);
|
|
begin
|
|
if (self<>nil) and (aRecord<>nil) then
|
|
GotoRecord(aRecord.RecordClass,aRecord.ID);
|
|
end;
|
|
|
|
function TSQLRibbon.RefreshClickHandled(Sender: TObject;
|
|
RecordClass: TSQLRecordClass; ActionValue: integer;
|
|
out Tab: TSQLRibbonTab): boolean;
|
|
var aP: integer;
|
|
begin
|
|
result := true; // caller must exit now
|
|
aP := GetPage(RecordClass);
|
|
if aP<0 then
|
|
exit;
|
|
Tab := Page[aP];
|
|
if (Sender<>nil) and (fRefreshActionIndex<>0) and
|
|
(ActionValue=fRefreshActionIndex) and not Tab.TableToGrid.Refresh then begin
|
|
Sender := nil;
|
|
ActionValue := Tab.List.Row;
|
|
end;
|
|
if Sender=nil then begin
|
|
if Tab.FrameRight<>nil then begin
|
|
if Tab.Retrieve(Client,ActionValue) then begin
|
|
Tab.FrameRight.Show;
|
|
if Tab.Report<>nil then begin
|
|
if ReportAutoFocus and
|
|
(Form.Focused or Tab.List.Focused) and Tab.Report.CanFocus then
|
|
Tab.Report.SetFocus;
|
|
SetTimer(Form.Handle,WM_TIMER_REFRESH_REPORT,200,nil);
|
|
end;
|
|
end else
|
|
Tab.FrameRight.Hide;
|
|
end;
|
|
exit;
|
|
end;
|
|
result := false; // caller must handle the action
|
|
end;
|
|
|
|
procedure TSQLRibbon.RefreshPage(Page: TSQLRibbonTab);
|
|
var P: TSQLRibbonTab;
|
|
begin
|
|
if (self=nil) or (Page=nil) or (fRefreshActionIndex=0) then
|
|
exit;
|
|
if Assigned(fOnActionClick) then
|
|
fOnActionClick(Page.Lister,Page.Table,fRefreshActionIndex) else
|
|
RefreshClickHandled(Page.Lister,Page.Table,fRefreshActionIndex,P);
|
|
end;
|
|
|
|
procedure TSQLRibbon.ToolBarChange(Sender: TObject);
|
|
var aPage: integer;
|
|
begin
|
|
KillTimer(Form.Handle,WM_TIMER_REFRESH_SCREEN);
|
|
KillTimer(Form.Handle,WM_TIMER_REFRESH_REPORT);
|
|
aPage := fToolBar.ActivePageIndex;
|
|
if cardinal(aPage)>cardinal(high(Page)) then
|
|
exit;
|
|
with Page[fLastActiveTab] do begin
|
|
TableToGrid.PageChanged;
|
|
if Report<>nil then // release some unused GDI resources
|
|
FreeAndNil(Report.PreviewSurfaceBitmap);
|
|
end;
|
|
fLastActiveTab := aPage;
|
|
fBody.ActivePageIndex := aPage;
|
|
if fBody.Visible and (fRefreshActionIndex<>0) then begin
|
|
RefreshPage(Page[aPage]);
|
|
if (Form<>nil) and GetParameter(aPage)^.AutoRefresh then
|
|
// set Timer to refresh the screen every second
|
|
SetTimer(Form.Handle,WM_TIMER_REFRESH_SCREEN,1000,nil);
|
|
end;
|
|
end;
|
|
|
|
procedure TSQLRibbon.WMRefreshTimer(var Msg: TWMTimer);
|
|
var i: integer;
|
|
begin
|
|
if (self=nil) or (Form=nil) or (csDestroying in Form.ComponentState) then
|
|
exit; // avoid GPF
|
|
i := ToolBar.ActivePageIndex;
|
|
if cardinal(i)>cardinal(high(Page)) then
|
|
exit;
|
|
if fClient.OnIdleBackgroundThreadActive then
|
|
exit; // avoid endless loop
|
|
case Msg.TimerID of // action from Timer ID
|
|
WM_TIMER_REFRESH_SCREEN: // used to send a Refresh command (default every second)
|
|
if (fRefreshActionIndex<>0) and
|
|
GetParameter(i)^.AutoRefresh then // refresh Workstation content
|
|
RefreshPage(Page[i]);
|
|
WM_TIMER_REFRESH_REPORT: with Page[i] do
|
|
if (FrameRight<>nil) and (Report<>nil) and
|
|
Retrieve(Client,List.Row) then begin
|
|
// used to recreate the current selected report
|
|
// use a timer, otherwise marking is buggy and UI experience is poor
|
|
KillTimer(Form.Handle,WM_TIMER_REFRESH_REPORT); // only refresh once
|
|
try
|
|
Report.BeginDoc;
|
|
CreateReport(i);
|
|
finally
|
|
Report.EndDoc; // so we ignore any reporting errors
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TSQLRibbon.AddToReport(aReport: TGDIPages; aRecord: TSQLRecord;
|
|
WithTitle: Boolean; CSVFieldNames, CSVFieldNameToHide: PUTF8Char;
|
|
OnCaptionName: TOnCaptionName;
|
|
ColWidthName, ColWidthValue: integer): string;
|
|
var OldWordWrapLeftCols: boolean;
|
|
i: integer;
|
|
aName: RawUTF8;
|
|
RibbonParams: PSQLRibbonTabParameters;
|
|
PHint: PChar; // map FieldHints
|
|
aHint, aCaption: string;
|
|
begin
|
|
result := '';
|
|
if (Self=nil) or (aReport=nil) or (aRecord=nil) or (Client=nil) then
|
|
exit;
|
|
PHint := nil;
|
|
RibbonParams := GetParameter(aRecord.RecordClass);
|
|
if RibbonParams<>nil then
|
|
with RibbonParams^ do
|
|
if EditFieldHintsToReport and (EditFieldHints<>nil) then
|
|
PHint := pointer(LoadResString(EditFieldHints));
|
|
result := U2S(Client.MainFieldValue(aRecord.RecordClass,aRecord.ID,true));
|
|
if WithTitle then begin
|
|
aReport.DrawTitle(aRecord.CaptionName+' : '+result,true);
|
|
aReport.NewHalfLine;
|
|
end;
|
|
OldWordWrapLeftCols := aReport.WordWrapLeftCols;
|
|
aReport.WordWrapLeftCols := true; // automatic word wrap and #13 for next line
|
|
aReport.AddColumns([ColWidthName,ColWidthValue]);
|
|
aReport.SetColumnBold(0);
|
|
aReport.AddColumnHeaders([],true);
|
|
with aRecord.RecordProps.Fields do begin
|
|
for i := 0 to Count-1 do begin
|
|
aHint := GetNextItemString(PHint,'|'); // ALL fields are listed: do it now
|
|
aName := List[i].Name;
|
|
if ((CSVFieldNameToHide<>nil) and
|
|
(FindCSVIndex(CSVFieldNameToHide,aName,',',false)>=0)) or
|
|
((CSVFieldNames<>nil) and
|
|
(FindCSVIndex(CSVFieldNames,aName,',',false)<0)) then
|
|
continue; // display properties listed in optional CSVFieldNames parameter
|
|
if aHint<>'' then begin
|
|
aReport.Font.Color := clNavy;
|
|
aReport.DrawText(aHint);
|
|
aReport.Font.Color := clBlack;
|
|
end;
|
|
if assigned(OnCaptionName) then
|
|
aCaption := OnCaptionName(aName) else
|
|
aCaption := '';
|
|
if aCaption='' then
|
|
GetCaptionFromPCharLen(TrimLeftLowerCase(aName),aCaption);
|
|
aReport.DrawTextAcrossCols([aCaption,
|
|
Language.PropToString(List[i],aRecord,Client)]); // PropToString do all the magic
|
|
if aHint<>'' then
|
|
aReport.NewLine else
|
|
aReport.NewHalfLine;
|
|
end;
|
|
end;
|
|
aReport.WordWrapLeftCols := oldWordWrapLeftCols;
|
|
end;
|
|
|
|
function TSQLRibbon.DeleteMarkedEntries(aTable: TSQLRecordClass; const ActionHint: string): boolean;
|
|
var Tab: TSQLRibbonTab;
|
|
aP, n, i: integer;
|
|
begin
|
|
result := True; // success by default
|
|
if (self=nil) or (aTable=nil) or (Client=nil) then
|
|
exit;
|
|
aP := GetPage(aTable);
|
|
if aP<0 then
|
|
exit;
|
|
Tab := Page[aP];
|
|
with Tab.TableToGrid do begin
|
|
n := MarkedTotalCount;
|
|
if n=0 then
|
|
if (Tab.List.Row<1) or (YesNo(ActionHint,
|
|
U2S(Client.MainFieldValue(aTable,Tab.CurrentID,true)),false)=ID_NO) or
|
|
not Client.Delete(aTable,Tab.CurrentID) then begin
|
|
result := false;
|
|
exit;
|
|
end else
|
|
GotoRecord(aTable,Table.IDColumnHiddenValue(Tab.List.Row+1)) else
|
|
if YesNo(ActionHint,Format(sDeleteN,[n]),false)=ID_NO then
|
|
exit else
|
|
if Client.TransactionBegin(aTable) then
|
|
try
|
|
for i := Table.RowCount downto 1 do
|
|
if Marked[i] then
|
|
if not Client.Delete(aTable,Table.IDColumnHiddenValue(i)) then begin
|
|
Client.RollBack;
|
|
result := false;
|
|
break;
|
|
end;
|
|
SetMark(actUnmarkAll);
|
|
Tab.List.Row := 0;
|
|
Refresh;
|
|
finally
|
|
Client.Commit; // will do nothing if Client.RollBack has been called
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TSQLRibbon.ExportRecord(aTable: TSQLRecordClass; aID: TID;
|
|
const ActionHint: string; OpenAfterCreation: boolean): TFileName;
|
|
var i: integer;
|
|
aName, ext: TFileName;
|
|
Rep: TGDIPages;
|
|
Content: string;
|
|
begin
|
|
result := '';
|
|
if (self=nil) or (aTable=nil) or (Client=nil) then
|
|
exit;
|
|
if GetPage(aTable)<0 then
|
|
exit; // CreateReport need a known record type
|
|
if aID>0 then
|
|
aName := U2S(Client.MainFieldValue(aTable,aID,true)) else
|
|
aName := aTable.CaptionName;
|
|
with TSaveDialog.Create(Application.MainForm) do
|
|
try
|
|
Title := ActionHint;
|
|
Options := [ofOverwritePrompt,ofHideReadOnly,ofEnableSizing];
|
|
Filter := sPDFFile+' (*.pdf)|*.pdf|'+sTextFile+' (*.txt)|*.txt';
|
|
DefaultExt := '.pdf';
|
|
FileName := aName;
|
|
if not Execute then
|
|
exit;
|
|
aName := FileName;
|
|
finally
|
|
Free;
|
|
end;
|
|
ext := ExtractFileExt(aName);
|
|
Rep := TGDIPages.Create(nil); // use a temp report to create text
|
|
try
|
|
Screen.Cursor := crHourGlass;
|
|
Rep.ForceCopyTextAsWholeContent := true; // headers copied once
|
|
CreateReport(aTable,aID,Rep);
|
|
Rep.EndDoc;
|
|
if SameText(ext,'.PDF') then begin
|
|
Rep.Caption := aName;
|
|
if not Rep.ExportPDF(aName,false) then
|
|
exit;
|
|
end else
|
|
if SameText(ext,'.TXT') then begin
|
|
for i := 0 to high(Rep.Pages) do
|
|
Content := Content+Rep.Pages[i].Text; // append content of every page
|
|
// export as ANSI text file, in the current code page
|
|
if not FileFromString(
|
|
{$ifdef UNICODE}
|
|
CurrentAnsiConvert.UnicodeBufferToAnsi(pointer(Content),length(Content))
|
|
{$else}
|
|
Content
|
|
{$endif} ,aName) then
|
|
exit;
|
|
end else
|
|
exit; // invalid extension
|
|
if OpenAfterCreation then
|
|
ShellExecute(Application.DialogHandle,nil,pointer(aName),nil,nil,SW_SHOWNORMAL);
|
|
result := aName; // mark success
|
|
finally
|
|
Screen.Cursor := crDefault;
|
|
Rep.Free;
|
|
end;
|
|
end;
|
|
|
|
function TSQLRibbon.GetParameter(aTable: TSQLRecordClass): PSQLRibbonTabParameters;
|
|
begin
|
|
result := GetParameter(GetPage(aTable));
|
|
end;
|
|
|
|
function TSQLRibbon.MarkedEntriesToReport(aTable: TSQLRecordClass;
|
|
const ColWidths: array of integer; aRep: TGDIPages): TGDIPages;
|
|
var P, R, F: integer;
|
|
ColText: TSynUnicodeDynArray;
|
|
ColWidth: TIntegerDynArray;
|
|
begin
|
|
P := GetPage(aTable);
|
|
if (P<0) or (Page[P].TableToGrid.MarkedTotalCount=0) then begin
|
|
result := nil;
|
|
exit;
|
|
end;
|
|
if aRep<>nil then
|
|
result := aRep else
|
|
result := TGDIPages.Create(nil);
|
|
result.WordWrapLeftCols := true; // word wrap so that we won't loose any data
|
|
CreateReport(aTable,-1,result); // create footer
|
|
result.DrawTitle(aTable.CaptionName,true);
|
|
with Page[P].TableToGrid do begin
|
|
if length(ColWidths)=Table.FieldCount then begin
|
|
SetLength(ColWidth,Table.FieldCount);
|
|
move(ColWidths[0],ColWidth[0],Table.FieldCount*sizeof(integer));
|
|
end else
|
|
Table.CalculateFieldLengthMean(ColWidth,true); // FromDisplay=true
|
|
result.AddColumns(ColWidth);
|
|
SetLength(ColText,Table.FieldCount);
|
|
for F := 0 to Table.FieldCount-1 do
|
|
Table.ExpandAsSynUnicode(0,F,Client,ColText[F]);
|
|
result.AddColumnHeaders(ColText,true,true); // true = with gray bottom line
|
|
for R := 1 to Table.RowCount do
|
|
if Marked[R] then begin
|
|
for F := 0 to Table.FieldCount-1 do
|
|
Table.ExpandAsSynUnicode(R,F,Client,ColText[F]);
|
|
result.DrawTextAcrossCols(ColText);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TSQLRibbon.CreateReport(aPageIndex: Integer);
|
|
var P: TSQLRibbonTab;
|
|
begin
|
|
if cardinal(aPageIndex)>cardinal(high(Page)) then
|
|
exit;
|
|
P := Page[aPageIndex];
|
|
if P<>nil then
|
|
CreateReport(P.Table,P.CurrentRecord.ID,P.Report,false);
|
|
end;
|
|
|
|
procedure TSQLRibbon.CreateReport(aTable: TSQLRecordClass; aID: TID;
|
|
aReport: TGDIPages; AlreadyBegan: boolean=false);
|
|
var P: integer;
|
|
begin
|
|
if (aReport<>nil) and (aTable<>nil) and (self<>nil) then
|
|
if aID=0 then
|
|
MarkedEntriesToReport(aTable,[],aReport) else
|
|
with aReport do begin
|
|
if not AlreadyBegan then begin
|
|
Clear;
|
|
BeginDoc;
|
|
end;
|
|
if (aID>0) and (Caption='') then
|
|
Caption := U2S(Client.MainFieldValue(aTable,aID,true));
|
|
Font.Size := 9;
|
|
AddPagesToFooterAt(FormatString('% - % %',[sPageN,aTable.CaptionName,Caption]),LeftMargin);
|
|
Font.Size := 10;
|
|
P := GetPage(aTable);
|
|
if (P<0) or (aID<=0) then
|
|
exit;
|
|
with self.Page[P] do
|
|
if CurrentRecord.ID=aID then
|
|
AddToReport(aReport,CurrentRecord,True,nil,
|
|
pointer(GetParameter(P)^.EditFieldNameToHideCSV));
|
|
end;
|
|
end;
|
|
|
|
function TSQLRibbon.FindButton(aTable: TSQLRecordClass; aActionIndex: integer): TSynToolButton;
|
|
var P: integer;
|
|
begin
|
|
P := GetPage(aTable);
|
|
if P<0 then
|
|
result := nil else
|
|
result := Page[P].Lister.FindButton(aActionIndex);
|
|
end;
|
|
|
|
procedure TSQLRibbon.SetButtonHint(aTable: TSQLRecordClass;
|
|
aActionIndex: integer; const aHint: string);
|
|
var Btn: TSynToolButton;
|
|
begin
|
|
Btn := FindButton(aTable,aActionIndex);
|
|
if Btn<>nil then
|
|
Btn.Hint := aHint;
|
|
end;
|
|
|
|
procedure TSQLRibbon.Refresh(aTable: TSQLRecordClass);
|
|
var Tab: TSQLRibbonTab;
|
|
begin
|
|
if aTable=nil then begin
|
|
Tab := GetActivePage;
|
|
if Tab=nil then
|
|
exit;
|
|
aTable := Tab.Table;
|
|
end;
|
|
RefreshClickHandled(self,aTable,fRefreshActionIndex,Tab);
|
|
end;
|
|
|
|
procedure TSQLRibbon.AddToReport(aReport: TGDIPages; Table: TSQLTable;
|
|
const ColWidths: array of integer);
|
|
var R,F: integer;
|
|
ColText: TSynUnicodeDynArray;
|
|
ColWidth: TIntegerDynArray;
|
|
aClient: TSQLRest;
|
|
begin
|
|
if (aReport=nil) or (Table=nil) or (Table.FieldCount=0) then
|
|
exit;
|
|
if self=nil then
|
|
aClient := nil else
|
|
aClient := Client;
|
|
if length(ColWidths)=Table.FieldCount then begin
|
|
SetLength(ColWidth,Table.FieldCount);
|
|
move(ColWidths[0],ColWidth[0],Table.FieldCount*sizeof(integer));
|
|
end else
|
|
Table.CalculateFieldLengthMean(ColWidth,true); // FromDisplay=true
|
|
aReport.AddColumns(ColWidth);
|
|
SetLength(ColText,Table.FieldCount);
|
|
for F := 0 to Table.FieldCount-1 do
|
|
Table.ExpandAsSynUnicode(0,F,aClient,ColText[F]);
|
|
aReport.AddColumnHeaders(ColText,true,true); // true = with gray bottom line
|
|
for R := 1 to Table.RowCount do begin
|
|
for F := 0 to Table.FieldCount-1 do
|
|
Table.ExpandAsSynUnicode(R,F,aClient,ColText[F]);
|
|
aReport.DrawTextAcrossCols(ColText);
|
|
end;
|
|
end;
|
|
|
|
|
|
end.
|
|
|