/// 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:

%s ?'#13; sPerformToMarkedOrSelected = 'Apply to the Selected entry:
%s

'+ 'Or apply to all Marked entries:'; {$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-StartIndexAtnil 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+'
...'; break; end else Capt := Capt+'
'+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)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)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 (aPagenil 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 (aPagenil 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.