View Issue Details
ID | Project | Category | View Status | Date Submitted | Last Update |
---|---|---|---|---|---|
0038336 | Lazarus | Database Components | public | 2021-01-09 16:34 | 2021-01-14 16:13 |
Reporter | Zdravko Gabrovski | Assigned To | wp | ||
Priority | normal | Severity | minor | Reproducibility | N/A |
Status | resolved | Resolution | no change required | ||
Platform | All | OS | All | ||
Summary | 0038336: Two new database components - TDBTreeView and TDBCntrlGrid | ||||
Description | Based on the original IBXDBTreeView and DBControlGrid, I developed a two new components - DBTreeVoew and DBCntrlGrid. I removed the dependencies form IBX and now components works with standard TSQLQuery components. The only requirement for DBTreeView TSQLQuery object is to save a line with "Where"clause in the SQL Query. Later on I will port the orinal examples from IBX components. I already use both components in my project they work awesome. Thanks for the great job for initial development to Mr. Tony Whyman from MWA Software. | ||||
Steps To Reproduce | - | ||||
Additional Information | My proposal is to add a components as a part of standard distribution. | ||||
Tags | No tags attached. | ||||
Fixed in Revision | |||||
LazTarget | - | ||||
Widgetset | |||||
Attached Files |
|
|
|
|
> now components works with standard TSQLQuery components. I think these components should require only TDataset, just like TDBGrid and the other standard data-aware components do. |
|
Unfortunately DBTreeView not. It loads data dynamically, based on the SQL modification runtime. In the original version even it is bound with IBX SQL Query, an the moment it is with TSQLQuery, which give an option to use with other databases, not only with firebird. For dbCntrlGrid - It should work with any TDataSet. |
|
Please, find attached simple example, based on the original example from Tony Whyman. It requires local firebird and employee database. |
|
> I think these components should require only TDataset, just like TDBGrid and the other standard data-aware components do. wp, actually they require a TDataSource. It is a nice abstraction and consistent for all data-aware comps. These new components sound good. I am not sure if they should be in LCL though. They could have their own package maintained somewhere and delivered through OPM. Maybe the new package gets other similar specialized DB-components in future. |
|
> actually they require a TDataSource. It is a nice abstraction and consistent for all data-aware comps. Only on the surface. When you look deeper you see that DBTreeView raises an exception in DBControlLinkChanged when the DataSet hooked to the TDataSource is not a TSQLQuery. This is a big advantage. It excludes for example the popular Zeos components. And I do not see why it should not be possible to display a DBase table in such a treeview. For example, the DBTreeView could switch to the (slower) Filter mechanism when SQL is not available. Therefore I'd vote against adding this DBTreeView to the LCL. No problem with the DBCtrlGrid which is missing for Delphi compatibility. |
|
I will try to modify little bit to remove TSQLQuery dependancy. I am open for any ideas how to do this. For the moment there are two methods: UpdateSQL and UpdateParams, which modified SQL and updated parameters in the query. May be I can add a two events and the modification and parameters update should be done outside of the component? I still think that the best way is to put the components into LCL. We are missing from a years good and easy-to use DBTreeView. I even think that will be also better to put in LCL IBX components, developed from Tony Whyman. There is a lot of Delphi-7 applications used IBX than can be easy ported to fpc/lazarus if their developers knows about IBX. |
|
Already when opening your demo I have this problem: I do not have IBConnection installed, and my TSQLQuery is that of FPC 3.2 which does not have a Macros property - it is not acceptable that Lazarus requires FPC-trunk... To generalize applicability of the DBTreeView, you could introduce a Mode property: TDBTreeViewMode = (tvmSimple, tvmFilter, tvmSQL). tvmSimple should work for all datasets: when the tree seeks the child nodes of a given node the dataset iterates through all records and picks those which have a matching ParentID. tvmFilter works for all datasets supporting the Filter/OnFilter mechanism to select the records having the requested ParentID. And tvmSQL, finally, does this by sending SQL queries; but in order to be indpendent of the dataset type there should be an event in which the user can cast to the TDataset descendant required in order be able to apply the correct SQL syntax. I could also imagine that there is an "adapter" component for each SQLQuery type (TSQLQueryTreeViewAdapter, TIBQueryTreeViewAdapter, TZeosTreeViewAdapter) which executes the query and returns the found records; this would have the advantage that the treeview could show data already at designtime, but the disadvantage that the component authors must provide this adapter class and that the component palette would be filled even more. Can you prepare a demo so that I can see operation and usage of the DBCtrlGrid? But no fancy database please, TDbf or TBufDataset would be perfect. I am not a lawyer and not a license specialist. Is the license equivalent with the license of the LCL (LGPL2 with linking exception)? |
|
I am also not a lawyer, I can put here peace of e-mail from Mr. Whyman: "As long as you have respected the IPL licence conditions then you are fully entitled to publish your updates in your own name. I would prefer you to do this as (a) I have no experience with TSQLQuery and hence could not support such a component, and (b) IBX is already big enough. Testing each upgrade is now a serious burden and I don't really want to add to it." So, I think this cover your question for the licence. For the demo: Macros property is no required, just the demo I created is in the trunk. I am using trunk. Your ideas for DBTreeView are very good, for the moment I have no time to develop the adapters, but the approach with TDBTreeViewMode will be fair enough. Just remove from the .lfm file Macro property and you will compile in stable release. I developed Macros in TSQLQuery an year and more ago, I don't know why it is not in the stable release. The are from the trunk since september 2019. |
|
> I am not a lawyer and not a license specialist. Is the license equivalent with the license of the LCL (LGPL2 with linking exception)? The DBControlGrid originally is based on Lazarus' DBGrid component and as such its also subject to the LGPL2 with linking exception as the source states: https://svn.mwasoftware.co.uk/viewvc/public/ibx/trunk/ibcontrols/DBControlGrid.pas?revision=263&view=markup IBTreeView however uses a custom license: https://svn.mwasoftware.co.uk/viewvc/public/ibx/trunk/ibcontrols/IBTreeView.pas?revision=272&view=markup Thus the DBControlGrid could be integrated into the LCL (after all it's indeed required for Delphi compatibility), while IBTreeView should be placed in a separate package. Cause even if we can in general distribute the source, the question is in how far the IPL is compatible with something distributed as LGPL2-with-exception. |
|
> after all it's indeed required for Delphi compatibility Well, hmmm. It is "50%-compatible": it has a different name (TDBCtrlGrid (Delphi) vs. TDBCntrlGrid (Laz)) and it has different properties(D: AllowDelete, AllowInsert, ColCount, ShowFocus, Orientations, PanelHeight, PanelWidth; L: AltColorStartNormal, DrawPanel, new Options) The different name is maybe not so bad in this situation because it signals the user: this is similar, but different in detail (but then I'd prefer TDBControlGrid over TDBCntrlGrid), like TeeChart vs TAChart. Regarding the license: I'd replace the current license text of the DBCntrlGrid by the text used by the LCL components. Zdravko, would that be ok? |
|
Yeas, it is. But, please, use the new files attached, today I fix a lot of bugs in TDBCntrlGrid, i upload a new source. The bugs was critical - DBCntrlGrid does not unregister global OnKeyDownBeforeHandler and does not check if it form is current active form. I am attaching new sources with a last fixes. And very nice screen shot of usage a new component in my application. |
|
> I am not a lawyer and not a license specialist. Is the license equivalent with the license of the LCL (LGPL2 with linking exception)? > > IBTreeView however uses a custom license: https://svn.mwasoftware.co.uk/viewvc/public/ibx/trunk/ibcontrols/IBTreeView.pas?revision=272&view=markup > > Thus the DBControlGrid could be integrated into the LCL (after all it's indeed required for Delphi compatibility), while IBTreeView should be placed in a separate package. Cause even if we can in general distribute the source, the question is in how far the IPL is compatible with something distributed as LGPL2-with-exception. The Initial Developer's Public License and the InterBase Public License are both based on the Mozilla Public License V 1.1 with some changes: https://www.firebirdsql.org/en/interbase-public-license/ https://www.firebirdsql.org/en/initial-developer-s-public-license-version-1-0 The MPL versions up to 1.1 are not compatible with GPL version 2: https://en.wikipedia.org/wiki/Mozilla_Public_License So, IDPL and IPL should also not be compatible with GPL version 2. Then, rest three ways: Tony Whyman could double license his work, or IBTreeView should be placed in a separate package, or a new "DBTreeView" component should be build from scratch to be inserted in the LCL. |
|
There are serious problems with both controls: Running your demo I noticed that I see only a single record in the DbCntrlGrid. So, I increased its height. But now when I run the modified demo the newly visible records in the grid have a black background color, and when I expand the root node of the tree view suddenly its children are gone. When this is fixed (and no other problems show up) I plan to put the components on Lazarus-CCR. These are the reasons why they should not be added to the main distribution - The grid basically would be needed for Delphi compatibility, but the problem is that it is NOT 100% compatible. It is not possible to load a Delphi form with the TDBCtrlGrid into Lazarus without manual adjustments (different name, different properties), additional work would be required to extend the Delphi import tool for it. It is true that we do have other components requiring adjustments, too, but we should aim at improving compatibility instead of adding more incompatible components. - The main problem of the treeview is its license which is incompatible with the LCL policy. Moreover, it is not contained in the Delphi standard installations, so there is no immediate need to add it to LCL (although I share your opinion that it is highly useful). Adding them to CCR, on the other hand, solves these issues. Being not so much in the focus of the Lazarus distribution it is no longer required to strive for Delphi compatibility, and mixing license types is no problem either. After some testing period we can create a zipped package for the Online-Package-Manager and the package will be very visible to Lazarus users. I see that you are a relatively new user. When I get the impression that you do not disappear soon like some others did and that you are willing to maintain the package I could arrange to get commit rights on CCR for you. |
|
I will not disappear:) Don't worry! My first development here is improvement of TDBGrid fields editor in 2014. After that i was (positively) surprised to see my name in Lazarus contributors list. I will add a new demo later on to eliminate the problems you discoverd. I am using both the controls in my application, I am fixing the bugs (as critical keyboard handler from yesterday), I will upload new version soon. Regards, Zdravko |
|
Sorry, I concluded this from your recent forum post which is counted to be number 20. |
|
:) Don't worry, I recently post in bug tracker, have no time for the forums:) Minutes ago I fixed a new bug inside DBTreeView, it was firing "OnSelectionchange" event in internal ExpandAll method, for each of the node it iterates. Now it fire only for the last node. The component archive I will upload end of the day, probably there will be news bugs. |
|
So, please find attached today's changes with a modified sample and bugfix for black background color. Also bugfix in OnSelectionChange event in DBTreeView. |
|
And sample screen shot |
|
Thanks. Looks good. One thing maybe: Is there a way to paint the edit control in a themed way? Right now, the edits in the non-selected panels are 3D-like in Win95-style, those in the selected panel are flat (themed). This results in a distracting up/down movement of the edit boxes when the selected row changes. |
|
> I am not a lawyer and not a license specialist. Is the license equivalent with the license of the LCL (LGPL2 with linking exception)? I wouldn't worry too much about the licence conditions. As the original author I can easily re-issue IBTreeView under the LCL and will do so on request. The only reason for the IPL is that that is how Borland originally released IBX and it's easier to keep everything under the same licence. TDBControlGrid never had any dependencies on IBX and the only difference I can see (using diff) with the original is a change of name for the class and the incorporation of the register procedure. Otherwise it is the same as my original. I always hoped that it would have a life beyond IBX one day as it is generally applicable. It was hacked from TDBGrid (as said in the comments) and is hence already under the LCL. TIBTreeView is dependent on IBX in that it uses IBX's SQL rewriting capability in order to "walk the tree". If you are going to generalise it then perhaps it might be better to create an abstract class and make the TSQLQuery version an implementation of the abstract class. |
|
>One thing maybe: Is there a way to paint the edit control in a themed way? Right now, the edits in the non-selected panels are 3D-like in Win95-style, those in the selected panel are flat (themed). This results in a distracting up/down movement of the edit boxes when the selected row changes. The panel is any TWInControl descendent and the TDBControlGrid works by drawing each row to a bitmap canvas and then caching the result. Only currently focused row is a "real" control. The other rows are just images copied from the cache. The "jumpiness" can be an artefact of the control being moved to a different location and being replaced by an image and it depends on which GUI you are using (GTK, Windows, etc.) as to how you perceive the jumpiness. There is an example that is part of IBX. The example uses IBX, Firebird and the employee database. |
|
>TDBControlGrid never had any dependencies on IBX and the only difference I can see (using diff) with the original is a change of name for the class and the incorporation of the register procedure. Otherwise it is the same as my original. I always hoped that it would have a life beyond IBX one day as it is generally applicable. It was hacked from TDBGrid (as said in the comments) and is hence already under the LCL. Mr. Whyman, thanks for the participation here:) There is bugfixes in DNCntrlGrid the last version from yesterday - in TRowCache.Render I add Container.Canvas.Brush.Color := control.Color; Container.Canvas.FillRect(0,0,Control.Width,Control.Height); to avoid draw of the panel in a black background for a first time; I add a one more check inside KeyDownHandler if Visible and assigned(FDrawPanel) and FDrawPanel.Visible and FWeHaveFocus and ->>>> this (Self.Owner=Screen.ActiveForm) then.... and finally - I add if not (csDesigning in ComponentState) then Application.RemoveOnKeyDownBeforeHandler( @KeyDownHandler ); in the destructor. The last one prevents from AV when destroying the form. For the TreeView - I Hope I will find some easy way to avoid even TSQLQuery Dependency |
|
>There is bugfixes in DNCntrlGrid the last version from yesterday I am always willing to receive bug reports. The ones you listed are not in the file you uploaded? |
|
in the last file, I will attach again here. P.S. The reason to rename DBControlGrid to DBCntrlGrid is only to have an option to install both of the components together during the development process (to debug simultaneity:) dbcntrlgrid.pas (49,018 bytes)
{ /*************************************************************************** DBControlGrid.pas ----------- An interface to DB aware Controls Initial Revision : Sun Mar 8 2015 ***************************************************************************/ Unashameably hacked from DBGrid.Pas (Copyright (C) 2003 Jesus Reyes Aguilar.) by Tony Whyman (tony@mwasoftware.co.uk) .Additional source code is Copyright (c) McCallum Whyman Associates Ltd (trading as MWA Software) 2015. This unit defines TDBCntrlGrid: a lookalike rather than a clone for the Delphi TDBCrtlGrid. TDBCntrlGrid is a single column grid that replicates a TWinControl - typically a TPanel or a TFrame in each row. Each row corresponding to the rows of the linked DataSource. Any data aware control on the replicated (e.g.) TPanel will then appear to have the appropriate value for the row. The replicated control is not part of this control but must be added by the programmer at design time, and linked to the "DrawPanel" property. Rows can be edited, inserted (append only) or deleted. Distributed and licensed under the Library GNU General Public License see https://www.gnu.org/licenses/lgpl.html with the following modification: As a special exception, the copyright holders of this library give you permission to link this library with independent modules to produce an executable, regardless of the license terms of these independent modules, and to copy and distribute the resulting executable under terms of your choice, provided that you also meet, for each linked independent module, the terms and conditions of the license of that module. An independent module is a module which is not derived from or based on this library. If you modify this library, you may extend this exception to your version of the library, but you are not obligated to do so. If you do not wish to do so, delete this exception statement from your version. With a small bugfixes and change the component name to TBCntrlGrid from Zdravko Gabrovski To allow both installation of IBX DB Control Grid and and this port } unit dbcntrlgrid; {$mode objfpc}{$H+} interface uses Classes, Controls, SysUtils, DB, Grids, DBGrids, Graphics, StdCtrls, LMessages, LResources, Clipbrd; { The TRowCache is where we keep track of the DataSet and cache images of each row. TDBCntrlGrid is really a slight of hand. Only the active record is shown in the panel and the others are cached and displayed as images. The image cache is indexed by TDataSet.RecNo and accessed by current active record number (the data being displayed on the panel) and row offset from this record number. This is efficient but gives us a problem as the TDataSet model does not remove deleted records. Instead it simply marks them as deleted. Likewise, we need to keep track of deleted rows and skip over them when accessing the cache. When alternate row colours are in use, the cache is also used to keep track of the correct row colour as we must similarly ignore delete rows when calculating the correct colour. Odd and Even row numbers is not good enough here. } type { TRowCache } TRowCache = class private type TRowCacheState = (rcEmpty,rcPresent,rcDeleted); TRowDetails = record FState: TRowCacheState; FAlternateColor: boolean; FBitmap: TBitmap; end; private FAltColorStartNormal: boolean; FHeight: integer; FList: array of TRowDetails; FUseAlternateColors: boolean; FWidth: integer; procedure FreeImages(Reset: boolean); function GetAlternateColor(RecNo: integer): boolean; function Render(Control: TWinControl): TBitmap; procedure ExtendCache(aMaxIndex: integer); procedure OnWidthChange(Sender: TObject); procedure SetHeight(AValue: integer); procedure SetUseAlternateColors(AValue: boolean); procedure SetWidth(AValue: integer); public constructor Create; destructor Destroy; override; procedure ClearCache; function Add2Cache(RecNo: Longint; Control: TWinControl): TBitmap; function GetRowImage(RecNo, Offset: integer): TBitmap; procedure InvalidateRowImage(RecNo: integer); function IsEmpty(RecNo: integer): boolean; procedure MarkAsDeleted(RecNo: integer); property AlternateColor[RecNo: integer]: boolean read GetAlternateColor; property Width: integer read FWidth write SetWidth; property Height: integer read FHeight write SetHeight; property AltColorStartNormal: boolean read FAltColorStartNormal write FAltColorStartNormal; property UseAlternateColors: boolean read FUseAlternateColors write SetUseAlternateColors; end; { TDBCntrlGridDataLink } TDBCntrlGridDataLink = class(TComponentDataLink) private FOnCheckBrowseMode: TDataSetNotifyEvent; protected procedure CheckBrowseMode; override; public property OnCheckBrowseMode: TDataSetNotifyEvent read FOnCheckBrowseMode write FOnCheckBrowseMode; end; TKeyDownHandler = procedure (Sender: TObject; var Key: Word; Shift: TShiftState; var Done: boolean) of object; TPanelGridOption = (dgpIndicator,dgpDisableInsert,dgpCancelOnExit); TPanelGridOptions = set of TPanelGridOption; { TDBCntrlGrid } TDBCntrlGrid = class(TCustomGrid) private { Private declarations } FDataLink: TDBCntrlGridDataLink; FDefaultPositionAtEnd: boolean; FDrawPanel: TWinControl; FDrawingActiveRecord: boolean; FOldPosition: Integer; FOnKeyDownHander: TKeyDownHandler; fOnUpdateActive: TNotifyEvent; FOptions: TPanelGridOptions; FWeHaveFocus: boolean; FRowCache: TRowCache; FDrawRow: integer; {The current row in the draw panel} FSelectedRow: integer; {The row containing the current selection} FSelectedRecNo: integer; {The DataSet RecNo for the current row} FRequiredRecNo: integer; {Used after a big jump and is the dataset recno that we want to end up with} FInCacheRefresh: boolean; {Cache refresh in progress during paint} FCacheRefreshQueued: boolean; {cache refresh requested during wmpaint} FModified: boolean; FLastRecordCount: integer; {Used to pass mouse clicks to panel when focused row changes} FLastMouse: TPoint; FLastMouseButton: TMouseButton; FLastMouseShiftState: TShiftState; function ActiveControl: TControl; procedure EmptyGrid; function GetDataSource: TDataSource; function GetRecordCount: Integer; procedure GetScrollbarParams(out aRange, aPage, aPos: Integer); function GridCanModify: boolean; procedure DoDrawRow(aRow: integer; aRect: TRect; aState: TGridDrawState); procedure DoMoveRecord(Data: PtrInt); procedure DoSelectNext(Data: PtrInt); procedure DoScrollDataSet(Data: PtrInt); procedure DoSetupDrawPanel(Data: PtrInt); procedure DoSendMouseClicks(Data: PtrInt); procedure KeyDownHandler(Sender: TObject; var Key: Word; Shift: TShiftState); procedure OnRecordChanged(Field:TField); procedure OnCheckBrowseMode(aDataSet: TDataSet); procedure OnDataSetChanged(aDataSet: TDataSet); procedure OnDataSetOpen(aDataSet: TDataSet); procedure OnDataSetClose(aDataSet: TDataSet); procedure OnDrawPanelResize(Sender: TObject); procedure OnEditingChanged(aDataSet: TDataSet); procedure OnInvalidDataSet(aDataSet: TDataSet); procedure OnInvalidDataSource(aDataSet: TDataset); procedure OnLayoutChanged(aDataSet: TDataSet); procedure OnNewDataSet(aDataSet: TDataset); procedure OnDataSetScrolled(aDataSet:TDataSet; Distance: Integer); procedure OnUpdateData(aDataSet: TDataSet); procedure SetDataSource(AValue: TDataSource); procedure SetDrawPanel(AValue: TWinControl); procedure SetOptions(AValue: TPanelGridOptions); procedure SetupDrawPanel(aRow: integer); function UpdateGridCounts: Integer; procedure UpdateBufferCount; procedure UpdateDrawPanelBounds(aRow: integer); procedure UpdateScrollbarRange; procedure WMVScroll(var Message : TLMVScroll); message LM_VScroll; function ISEOF: boolean; function ValidDataSet: boolean; function InsertCancelable: boolean; protected { Protected declarations } function GetBufferCount: integer; virtual; procedure DoEnter; override; procedure DoExit; override; procedure DoGridResize; procedure DoOnResize; override; procedure DrawAllRows; override; procedure DrawRow(ARow: Integer); override; procedure DrawCell(aCol,aRow: Integer; aRect: TRect; aState:TGridDrawState); override; procedure DrawIndicator(ACanvas: TCanvas; aRow: integer; R: TRect; Opt: TDataSetState; MultiSel: boolean); virtual; procedure GridMouseWheel(shift: TShiftState; Delta: Integer); override; procedure KeyDown(var Key : Word; Shift : TShiftState); override; procedure LinkActive(Value: Boolean); virtual; procedure LayoutChanged; virtual; procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override; procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override; procedure MoveSelection; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure PrepareCanvas(aCol,aRow: Integer; aState:TGridDrawState); override; procedure ResetSizes; override; procedure SetColor(Value: TColor); override; procedure UpdateActive; virtual; procedure UpdateData; virtual; procedure UpdateShowing; override; procedure UpdateVertScrollbar(const aVisible: boolean; const aRange,aPage,aPos: Integer); override; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; function MouseToRecordOffset(const x, y: Integer; out RecordOffset: Integer ): TGridZone; function ExecuteAction(AAction: TBasicAction): Boolean; override; function UpdateAction(AAction: TBasicAction): Boolean; override; property Datalink: TDBCntrlGridDataLink read FDatalink; published { Published declarations } property Align; property AlternateColor; property AltColorStartNormal; property Anchors; property BiDiMode; property BorderSpacing; property BorderStyle; property CellHintPriority; property Color; property Constraints; property DataSource: TDataSource read GetDataSource write SetDataSource; property DefaultPositionAtEnd: boolean read FDefaultPositionAtEnd write FDefaultPositionAtEnd; property DragCursor; property DragMode; property DrawPanel: TWinControl read FDrawPanel write SetDrawPanel; property Enabled; property FixedColor; property FixedCols; property Flat; property Font; property Options: TPanelGridOptions read FOptions write SetOptions; property ParentBiDiMode; property ParentColor default false; property ParentFont; property PopupMenu; property Scrollbars default ssAutoVertical; property ShowHint; property TabOrder; property TabStop; property UseXORFeatures; property Visible; property OnContextPopup; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnEnter; property OnExit; property OnGetCellHint; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnKeyDownHander: TKeyDownHandler read FOnKeyDownHander write FOnKeyDownHander; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnPrepareCanvas; property OnStartDrag; property OnUTF8KeyPress; property OnUpdateActive : TNotifyEvent read fOnUpdateActive Write FOnUpdateActive; end; procedure Register; implementation uses LCLType, Math, LCLIntf, Forms, LCLMessageGlue, EditBtn, MaskEdit; { TDBCntrlGridDataLink } procedure TDBCntrlGridDataLink.CheckBrowseMode; begin inherited CheckBrowseMode; if assigned(FOnCheckBrowseMode) then OnCheckBrowseMode(DataSet); end; { TRowCache } function TRowCache.Render(Control: TWinControl): TBitmap; var Container: TBitmap; begin Container := TBitmap.Create; // Container.Transparent := False; try Container.SetSize(Control.Width,Control.Height); Container.Canvas.Brush.Color := control.Color; Container.Canvas.FillRect(0,0,Control.Width,Control.Height); Control.PaintTo(Container.Canvas,0,0); //Container.SaveToClipboardFormat( PredefinedClipboardFormat(pcfBitmap) ); except Container.Free; raise end; Result := Container; end; procedure TRowCache.FreeImages(Reset: boolean); var i: integer; altColor: boolean; begin altColor := not AltColorStartNormal; for i := 0 to Length(FList) - 1 do begin if (FList[i].FState <> rcEmpty) and (FList[i].FBitmap <> nil) then begin FList[i].FBitmap.Free; FList[i].FBitmap := nil; end; if Reset or (FList[i].FState = rcPresent) then FList[i].FState := rcEmpty; if FList[i].FState <> rcDeleted then begin FList[i].FAlternateColor := altColor; altColor := not altColor; end; end; end; function TRowCache.GetAlternateColor(RecNo: integer): boolean; begin ExtendCache(RecNo); Dec(RecNo); if (RecNo >= 0) and (RecNo < Length(FList)) then Result := FList[RecNo].FAlternateColor else Result := false; end; procedure TRowCache.ExtendCache(aMaxIndex: integer); var i: integer; StartIndex: integer; altColor: boolean; begin if aMaxIndex > Length(FList) then begin aMaxIndex := aMaxIndex + 10; StartIndex := Length(FList); SetLength(FList,aMaxIndex); if not UseAlternateColors then altColor := false else if StartIndex = 0 then altColor := not AltColorStartNormal else altColor := not FList[StartIndex-1].FAlternateColor; for i := StartIndex to Length(FList) - 1 do begin FList[i].FState := rcEmpty; FList[i].FBitmap := nil; FList[i].FAlternateColor := altColor; if UseAlternateColors then altColor := not altColor; end; end; end; procedure TRowCache.OnWidthChange(Sender: TObject); begin FreeImages(false); end; procedure TRowCache.SetHeight(AValue: integer); begin if FHeight = AValue then Exit; FHeight := AValue; FreeImages(false); end; procedure TRowCache.SetUseAlternateColors(AValue: boolean); begin if FUseAlternateColors = AValue then Exit; FUseAlternateColors := AValue; FreeImages(false); end; procedure TRowCache.SetWidth(AValue: integer); begin if FWidth = AValue then Exit; FWidth := AValue; FreeImages(false); end; constructor TRowCache.Create; begin SetLength(FList,0); end; destructor TRowCache.Destroy; begin ClearCache; inherited Destroy; end; procedure TRowCache.ClearCache; begin FreeImages(true); SetLength(FList,0); end; function TRowCache.Add2Cache(RecNo: Longint; Control: TWinControl): TBitmap; begin Dec(RecNo); {Adust to zero base} ExtendCache(RecNo + 1); FList[RecNo].FState := rcPresent; if FList[RecNo].FBitmap <> nil then FList[RecNo].FBitmap.Free; FList[RecNo].FBitmap := Render(Control); Result := FList[RecNo].FBitmap; end; function TRowCache.GetRowImage(RecNo, Offset: integer): TBitmap; begin Result := nil; Dec(RecNo); {adjust to zero base} if (RecNo < 0) or (RecNo >= Length(FList)) then Exit; if Offset >= 0 then repeat while (RecNo < Length(FList)) and (FList[RecNo].FState = rcDeleted) do Inc(RecNo); if RecNo >= Length(FList) then Exit; if Offset = 0 then begin if FList[RecNo].FState = rcPresent then Result := FList[RecNo].FBitmap; Exit; end; Inc(RecNo); Dec(Offset); until false else repeat Inc(Offset); Dec(RecNo); while (RecNo > 0) and (FList[RecNo].FState = rcDeleted) do Dec(RecNo); if RecNo < 0 then Exit; if Offset = 0 then begin if FList[RecNo].FState = rcPresent then Result := FList[RecNo].FBitmap; Exit; end; until false; end; procedure TRowCache.InvalidateRowImage(RecNo: integer); begin Dec(RecNo); {adjust to zero base} if (RecNo < 0) or (RecNo >= Length(FList)) then Exit; if FList[RecNo].FState = rcPresent then begin FList[RecNo].FBitmap.Free; FList[RecNo].FBitmap := nil; FList[RecNo].FState := rcEmpty; end; end; function TRowCache.IsEmpty(RecNo: integer): boolean; begin Dec(RecNo); Result := (RecNo < 0) or (RecNo >= Length(FList)) or (FList[RecNo].FState = rcEmpty); end; procedure TRowCache.MarkAsDeleted(RecNo: integer); var altColor: boolean; i: integer; begin Dec(RecNo); {adjust to zero base} if (RecNo < 0) or (RecNo >= Length(FList)) then Exit; FList[RecNo].FState := rcDeleted; if not UseAlternateColors then Exit; {Reset Alternate Colours} if RecNo = 0 then altColor := not AltColorStartNormal else altColor := not FList[RecNo-1].FAlternateColor; for i := RecNo + 1 to Length(FList) - 1 do begin if FList[i].FState <> rcDeleted then begin FList[i].FAlternateColor := altColor; altColor := not altColor; if FList[i].FState = rcPresent then begin FList[i].FBitmap.Free; FList[i].FState := rcEmpty; end; end; end; end; { TDBCntrlGrid } function TDBCntrlGrid.ActiveControl: TControl; var AParent: TWinControl; begin Result := nil; AParent := Parent; while (AParent <> nil) and not (AParent is TCustomForm) do AParent := AParent.Parent; if (AParent <> nil) and (AParent is TCustomForm)then Result := TCustomForm(AParent).ActiveControl; end; procedure TDBCntrlGrid.EmptyGrid; var OldFixedRows: Integer; begin OldFixedRows := FixedRows; Clear; FRowCache.ClearCache; RowCount := OldFixedRows + 1; if dgpIndicator in FOptions then ColWidths[0]:=12; if assigned(FDrawPanel) then FDrawPanel.Visible := false; end; function TDBCntrlGrid.GetDataSource: TDataSource; begin Result:= FDataLink.DataSource; end; function TDBCntrlGrid.GetRecordCount: Integer; begin if assigned(FDataLink.DataSet) then result := FDataLink.DataSet.RecordCount else result := 0; end; procedure TDBCntrlGrid.GetScrollbarParams(out aRange, aPage, aPos: Integer); begin if (FDatalink<>nil) and (FDataLink.DataSet <> nil) and FDatalink.Active then begin if FDatalink.dataset.IsSequenced then begin aRange := GetRecordCount + VisibleRowCount - 1; aPage := VisibleRowCount; if aPage<1 then aPage := 1; if FDatalink.BOF then aPos := 0 else if FDatalink.EOF then aPos := aRange else aPos := FDataLink.DataSet.RecNo - 1; // RecNo is 1 based if aPos<0 then aPos:=0; end else begin aRange := 6; aPage := 2; if FDatalink.EOF then aPos := 4 else if FDatalink.BOF then aPos := 0 else aPos := 2; end; end else begin aRange := 0; aPage := 0; aPos := 0; end; end; function TDBCntrlGrid.GridCanModify: boolean; begin result := not FDataLink.ReadOnly and ValidDataSet and FDatalink.DataSet.CanModify; end; procedure TDBCntrlGrid.DoDrawRow(aRow: integer; aRect: TRect; aState: TGridDrawState); var CachedRow: TBitmap; begin CachedRow := FRowCache.GetRowImage(FSelectedRecNo,aRow-FDrawRow); {if the row is in the cache then draw it - otherwise schedule a cache refresh cycle} if CachedRow = nil then begin if not FCacheRefreshQueued then begin FCacheRefreshQueued := true; Application.QueueAsyncCall(@DoMoveRecord,PtrInt(aRow)); end; Canvas.FillRect(aRect); end else Canvas.Draw(aRect.Left,aRect.Top,CachedRow) end; procedure TDBCntrlGrid.DoMoveRecord(Data: PtrInt); var aRow: integer; begin if AppDestroying in Application.Flags then Exit; FCacheRefreshQueued := false; aRow := integer(Data); FInCacheRefresh := true; if assigned(FDataLink.DataSet) then FDatalink.DataSet.MoveBy(aRow - FDrawRow); end; procedure TDBCntrlGrid.DoSetupDrawPanel(Data: PtrInt); begin if AppDestroying in Application.Flags then Exit; SetupDrawPanel(FDrawRow); end; procedure TDBCntrlGrid.DoSendMouseClicks(Data: PtrInt); var P: TPoint; Control: TControl; begin if AppDestroying in Application.Flags then Exit; if assigned(FDrawPanel) and (FLastMouse.X <> 0) then begin P := ClientToScreen(FLastMouse); Control := FindControlAtPosition(P,false); if (Control <> nil) and (Control is TWinControl) then TWinControl(Control).SetFocus else Control := FDrawPanel; P := Control.ScreenToClient(P); LCLSendMouseDownMsg(Control,P.X,P.Y,FLastMouseButton,FLastMouseShiftState); LCLSendMouseUpMsg(Control,P.X,P.Y, FLastMouseButton,FLastMouseShiftState); end; FLastMouse.X := 0; end; procedure TDBCntrlGrid.KeyDownHandler(Sender: TObject; var Key: Word; Shift: TShiftState); var Done: boolean; AControl: TControl; begin if Visible and assigned(FDrawPanel) and FDrawPanel.Visible and FWeHaveFocus and (Self.Owner=Screen.ActiveForm) then begin AControl := ActiveControl; if (AControl <> nil) and (AControl is TCustomComboBox) and ((Key in [VK_UP,VK_DOWN]) or (TCustomComboBox(AControl).DroppedDown and (Key = VK_RETURN)) or ((TCustomComboBox(AControl).Text <> '') and (Key = VK_ESCAPE))) then Exit; {ignore these keys if we are in a combobox} if (AControl <> nil) and (AControl is TCustomMemo) and (Key in [VK_RETURN,VK_UP,VK_DOWN]) then Exit; {Ignore Return in a CustomMemo} if (AControl <> nil) and (AControl is TCustomGrid) and (Key in [VK_RETURN,VK_UP,VK_DOWN,VK_TAB]) then Exit; {Ignore Return in a CustomMemo} if (AControl <> nil) and ((AControl is TDateEdit) or (AControl is TCustomMaskedit)) and (Key in [VK_RETURN,VK_UP,VK_DOWN, VK_ESCAPE,VK_LEFT,VK_RIGHT]) then Exit; {Ignore Return in a CustomMemo} Done := false; if assigned(FOnKeyDownHander) then OnKeyDownHander(Sender,Key,Shift,Done); if Done then Exit; KeyDown(Key,Shift) end; end; procedure TDBCntrlGrid.OnRecordChanged(Field: TField); begin UpdateActive end; procedure TDBCntrlGrid.OnCheckBrowseMode(aDataSet: TDataSet); var RecNo: integer; begin if assigned(FDrawPanel) and (aDataSet.RecNo > 0) and (FModified or (FRowCache.IsEmpty(aDataSet.RecNo))) then begin RecNo := aDataSet.RecNo; Application.ProcessMessages; if RecNo = aDataSet.RecNo then {Guard against sudden changes} FRowCache.Add2Cache(RecNo,FDrawPanel); end; end; procedure TDBCntrlGrid.OnDataSetChanged(aDataSet: TDataSet); begin if aDataSet.State = dsBrowse then begin if GetRecordCount = 0 then begin {Must be closed/reopened} FRowCache.ClearCache; FSelectedRow := 0; end else if FLastRecordCount > GetRecordCount then begin {must be delete} FRowCache.MarkAsDeleted(FSelectedRecNo); Dec(FSelectedRow); end; LayoutChanged; end; FLastRecordCount := GetRecordCount; if aDataSet.State = dsInsert then begin FRequiredRecNo := aDataSet.RecNo + 1; Application.QueueAsyncCall(@DoSelectNext,0); end; UpdateActive end; procedure TDBCntrlGrid.OnDataSetOpen(aDataSet: TDataSet); begin LinkActive(true); UpdateActive; end; procedure TDBCntrlGrid.OnDataSetClose(aDataSet: TDataSet); begin LinkActive(false); end; procedure TDBCntrlGrid.OnDrawPanelResize(Sender: TObject); begin FRowCache.Height := FDrawPanel.Height; DefaultRowHeight := FDrawPanel.Height; end; procedure TDBCntrlGrid.OnEditingChanged(aDataSet: TDataSet); begin FModified := true; end; procedure TDBCntrlGrid.OnInvalidDataSet(aDataSet: TDataSet); begin LinkActive(False); end; procedure TDBCntrlGrid.OnInvalidDataSource(aDataSet: TDataset); begin LinkActive(False); end; procedure TDBCntrlGrid.OnLayoutChanged(aDataSet: TDataSet); begin LayoutChanged; end; procedure TDBCntrlGrid.OnNewDataSet(aDataSet: TDataset); begin LinkActive(True); UpdateActive; end; procedure TDBCntrlGrid.OnDataSetScrolled(aDataSet: TDataSet; Distance: Integer); begin UpdateScrollBarRange; if Distance <> 0 then begin FDrawRow := FixedRows + FDataLink.ActiveRecord; if not FInCacheRefresh then begin Row := FDrawRow; FSelectedRow := FDrawRow; FSelectedRecNo := aDataSet.RecNo; SetupDrawPanel(FDrawRow); end else Application.QueueAsyncCall(@DoSetupDrawPanel,0); end else UpdateActive; end; procedure TDBCntrlGrid.OnUpdateData(aDataSet: TDataSet); begin UpdateData; end; procedure TDBCntrlGrid.SetDataSource(AValue: TDataSource); begin if AValue = FDatalink.Datasource then Exit; FDataLink.DataSource := AValue; UpdateActive; end; procedure TDBCntrlGrid.SetDrawPanel(AValue: TWinControl); var theForm: TWinControl; begin if FDrawPanel = AValue then Exit; if FDrawPanel <> nil then begin RemoveFreeNotification(FDrawPanel); FDrawPanel.RemoveAllHandlersOfObject(self); theForm := Parent; while not ((theForm is TCustomForm) or (theForm is TCustomFrame)) and (theForm.Parent <> nil) do theForm := theForm.Parent; FDrawPanel.Parent := theForm; end; FRowCache.ClearCache; try FDrawPanel := AValue; if assigned(FDrawPanel) then begin FDrawPanel.Parent := self; DefaultRowHeight := FDrawPanel.Height; if csDesigning in ComponentState then UpdateDrawPanelBounds(0) else FDrawPanel.Visible := false; FRowCache.Height := FDrawPanel.Height; FRowCache.Width := FDrawPanel.Width; FDrawPanel.AddHandlerOnResize(@OnDrawPanelResize); FreeNotification(FDrawPanel); end; except FDrawPanel := nil; raise; end; end; procedure TDBCntrlGrid.SetOptions(AValue: TPanelGridOptions); begin if FOptions = AValue then Exit; FOptions := AValue; if dgpIndicator in FOptions then begin FixedCols := 1; ColWidths[0] := 12 end else FixedCols := 0; end; procedure TDBCntrlGrid.SetupDrawPanel(aRow: integer); begin if FDrawPanel = nil then Exit; if ValidDataSet and FRowCache.AlternateColor[FDataLink.DataSet.RecNo] then FDrawPanel.Color := AlternateColor else FDrawPanel.Color := self.Color; FDrawPanel.Visible := true; UpdateDrawPanelBounds(aRow); {Position Draw Panel over expanded Row} Invalidate; end; function TDBCntrlGrid.UpdateGridCounts: Integer; var RecCount: Integer; FRCount, FCCount: Integer; begin BeginUpdate; try FRCount := 0; if dgpIndicator in FOptions then FCCount := 1 else FCCount := 0; if FDataLink.Active then begin UpdateBufferCount; RecCount := FDataLink.RecordCount; if RecCount<1 then RecCount := 1; end else begin RecCount := 0; if FRCount=0 then // need to be large enough to hold indicator // if there is one, and if there are no titles RecCount := FCCount; end; Inc(RecCount, FRCount); RowCount := RecCount; FixedRows := FRCount; Result := RowCount ; finally EndUpdate; end; end; procedure TDBCntrlGrid.UpdateBufferCount; var BCount: Integer; begin if FDataLink.Active then begin BCount := GetBufferCount; if BCount<1 then BCount := 1; FDataLink.BufferCount:= BCount; end; end; procedure TDBCntrlGrid.UpdateDrawPanelBounds(aRow: integer); var R: TRect; begin R := Rect(0,0,0,0); if assigned(FDrawPanel) and (aRow >= 0) and (aRow < RowCount) then begin // Upper and Lower bounds for this row ColRowToOffSet(False, True, aRow, R.Top, R.Bottom); //Bounds for visible Column ColRowToOffSet(True,True,ColCount-1,R.Left,R.RIght); FDrawPanel.BoundsRect := R; end; end; procedure TDBCntrlGrid.UpdateScrollbarRange; var aRange, aPage, aPos: Integer; ScrollInfo: TScrollInfo; begin if not HandleAllocated then exit; GetScrollBarParams(aRange, aPage, aPos); FillChar(ScrollInfo, SizeOf(ScrollInfo), 0); ScrollInfo.cbSize := SizeOf(ScrollInfo); {TODO: try to move this out} {$ifdef WINDOWS} ScrollInfo.fMask := SIF_ALL or SIF_DISABLENOSCROLL; ScrollInfo.ntrackPos := 0; {$else} ScrollInfo.fMask := SIF_ALL or SIF_UPDATEPOLICY; //ScrollInfo.ntrackPos := SB_POLICY_CONTINUOUS; ScrollInfo.ntrackPos := SB_POLICY_DISCONTINUOUS; {$endif} ScrollInfo.nMin := 0; ScrollInfo.nMax := aRange; ScrollInfo.nPos := Min(aPos,aRange-aPage); ScrollInfo.nPage := aPage; // the redraw argument of SetScrollInfo means under gtk // if the scrollbar is visible or not, in windows it // seems to mean if the scrollbar is redrawn or not // to reflect the scrollbar changes made SetScrollInfo(Handle, SB_VERT, ScrollInfo, (ScrollBars in [ssBoth, ssVertical]) or ((Scrollbars in [ssAutoVertical, ssAutoBoth]) and (aRange>aPAge)) ); FOldPosition := aPos; end; procedure TDBCntrlGrid.WMVScroll(var Message: TLMVScroll); var IsSeq: boolean; aPos, aRange, aPage: Integer; DeltaRec: integer; function MaxPos: Integer; begin if IsSeq then result := GetRecordCount - 1 else result := 4; end; procedure DsMoveBy(Delta: Integer); begin FDataLink.DataSet.MoveBy(Delta); GetScrollbarParams(aRange, aPage, aPos); end; procedure DsGoto(BOF: boolean); begin if BOF then FDatalink.DataSet.First else FDataLink.DataSet.Last; GetScrollbarParams(aRange, aPage, aPos); end; function DsPos: boolean; begin result := false; aPos := Message.Pos; if aPos=FOldPosition then begin result := true; exit; end; if aPos>=MaxPos then dsGoto(False) else if aPos<=0 then dsGoto(True) else if IsSeq then FDatalink.DataSet.RecNo := aPos + 1 else begin DeltaRec := Message.Pos - FOldPosition; if DeltaRec=0 then begin result := true; exit end else if DeltaRec<-1 then DsMoveBy(-VisibleRowCount) else if DeltaRec>1 then DsMoveBy(VisibleRowCount) else DsMoveBy(DeltaRec); end; end; begin if not FDatalink.Active or not assigned(FDataLink.DataSet) then exit; IsSeq := FDatalink.DataSet.IsSequenced and not FDataLink.DataSet.Filtered; case Message.ScrollCode of SB_TOP: DsGoto(True); SB_BOTTOM: DsGoto(False); SB_PAGEUP: DsMoveBy(-VisibleRowCount); SB_LINEUP: DsMoveBy(-1); SB_LINEDOWN: DsMoveBy(1); SB_PAGEDOWN: DsMoveBy(VisibleRowCount); SB_THUMBPOSITION: if DsPos then exit; SB_THUMBTRACK: if not (FDatalink.DataSet.IsSequenced) or DsPos then begin exit; end; else begin Exit; end; end; ScrollBarPosition(SB_VERT, aPos); FOldPosition:=aPos; end; function TDBCntrlGrid.ISEOF: boolean; begin with FDatalink do result := ValidDataSet and DataSet.EOF; end; function TDBCntrlGrid.ValidDataSet: boolean; begin result := FDatalink.Active And (FDatalink.DataSet<>nil) end; function TDBCntrlGrid.InsertCancelable: boolean; begin Result := ValidDataSet; if Result then with FDatalink.DataSet do Result := (State=dsInsert) and not Modified ; end; function TDBCntrlGrid.GetBufferCount: integer; begin Result := ClientHeight div DefaultRowHeight; end; procedure TDBCntrlGrid.DoEnter; begin inherited DoEnter; FWeHaveFocus := true; end; procedure TDBCntrlGrid.DoExit; begin FWeHaveFocus := false; if ValidDataSet and (dgpCancelOnExit in Options) and InsertCancelable then begin FDataLink.DataSet.Cancel; end; inherited DoExit; end; procedure TDBCntrlGrid.DoGridResize; begin if Columns.Count = 0 then Exit; if ColCount > 1 then Columns[0].Width := ClientWidth - ColWidths[0] else Columns[0].Width := ClientWidth; FRowCache.Width := Columns[0].Width; UpdateDrawPanelBounds(Row); end; procedure TDBCntrlGrid.DoOnResize; begin inherited DoOnResize; DoGridResize; end; procedure TDBCntrlGrid.DoScrollDataSet(Data: PtrInt); begin if AppDestroying in Application.Flags then Exit; FDataLink.DataSet.MoveBy(integer(Data) - FDataLink.DataSet.RecNo); end; procedure TDBCntrlGrid.DoSelectNext(Data: PtrInt); begin FDataLink.DataSet.MoveBy(1); end; procedure TDBCntrlGrid.DrawAllRows; begin inherited DrawAllRows; if ValidDataSet and FDatalink.DataSet.Active then begin if FInCacheRefresh and not FCacheRefreshQueued then {We are at the end of a cache refresh cycle} begin if FRequiredRecNo > 0 then begin if FRequiredRecNo <> FDataLink.DataSet.RecNo then Application.QueueAsyncCall(@DoScrollDataSet,FRequiredRecNo); FRequiredRecNo := 0; end else if FDrawRow <> FSelectedRow then Application.QueueAsyncCall(@DoMoveRecord,FSelectedRow); end; FInCacheRefresh := false; end; end; procedure TDBCntrlGrid.DrawRow(ARow: Integer); begin if (ARow>=FixedRows) and FDataLink.Active then FDrawingActiveRecord := (ARow = FDrawRow) else FDrawingActiveRecord := False; inherited DrawRow(ARow); end; procedure TDBCntrlGrid.DrawCell(aCol, aRow: Integer; aRect: TRect; aState: TGridDrawState); function GetDatasetState: TDataSetState; begin if ValidDataSet then result := FDataLink.DataSet.State else result := dsInactive; end; begin PrepareCanvas(aCol, aRow, aState); if aCol < FixedCols then DrawIndicator(Canvas,aRow, aRect,GetDataSetState,false) else if (FDrawPanel = nil) or not FDataLink.Active then DrawFillRect(Canvas,aRect) else if not FDrawingActiveRecord and FDataLink.Active then DoDrawRow(aRow,aRect,aState); {if we are drawing the active record then this is rendered by the Draw Panel i.e. a child control - so we need do nothing here} DrawCellGrid(aCol, aRow, aRect, aState); end; procedure TDBCntrlGrid.DrawIndicator(ACanvas: TCanvas; aRow: integer; R: TRect; Opt: TDataSetState; MultiSel: boolean); var dx,dy, x, y: Integer; procedure CenterY; begin y := R.Top + (R.Bottom-R.Top) div 2; end; procedure CenterX; begin X := R.Left + (R.Right-R.Left) div 2; end; procedure DrawEdit(clr: Tcolor); begin ACanvas.Pen.Color := clr; CenterY; CenterX; ACanvas.MoveTo(X-2, Y-Dy); ACanvas.LineTo(X+3, Y-Dy); ACanvas.MoveTo(X, Y-Dy); ACanvas.LineTo(X, Y+Dy); ACanvas.MoveTo(X-2, Y+Dy); ACanvas.LineTo(X+3, Y+Dy); end; procedure DrawBrowse; begin ACanvas.Brush.Color:=clBlack; ACanvas.Pen.Color:=clBlack; CenterY; x:= R.Left+3; if MultiSel then begin if BiDiMode = bdRightToLeft then begin ACanvas.Polyline([point(x+dx,y-dy), point(x,y),point(x+dx,y+dy), point(x+dx,y+dy-1)]); ACanvas.Polyline([point(x+dx,y-dy+1), point(x+1,y),point(x+dx,y+dy-1), point(x+dx,y+dy-2)]); CenterX; Dec(X,3); ACanvas.Ellipse(Rect(X+dx-2,Y-2,X+dx+2,Y+2)); end else begin ACanvas.Polyline([point(x,y-dy), point(x+dx,y),point(x,y+dy), point(x,y+dy-1)]); ACanvas.Polyline([point(x,y-dy+1),point(x+dx-1,y),point(x, y+dy-1), point(x,y+dy-2)]); CenterX; Dec(X,3); ACanvas.Ellipse(Rect(X-2,Y-2,X+2,Y+2)); end; end else begin if BiDiMode = bdRightToLeft then ACanvas.Polygon([point(x,y),point(x+dx,y-dy),point(x+dx, y+dy),point(x,y)]) else ACanvas.Polygon([point(x,y-dy),point(x+dx,y),point(x, y+dy),point(x,y-dy)]); end; end; begin ACanvas.Brush.Color := FixedColor; ACanvas.FillRect(R); if aRow <> Row then Exit; dx := 6; dy := 6; case Opt of dsBrowse: DrawBrowse; dsEdit: if FDrawingActiveRecord then DrawEdit(clBlack) else DrawBrowse; dsInsert: if FDrawingActiveRecord then DrawEdit(clGreen) else DrawBrowse; else if MultiSel then begin ACanvas.Brush.Color:=clBlack; ACanvas.Pen.Color:=clBlack; CenterX; CenterY; ACanvas.Ellipse(Rect(X-3,Y-3,X+3,Y+3)); end; end; end; procedure TDBCntrlGrid.GridMouseWheel(shift: TShiftState; Delta: Integer); begin inherited GridMouseWheel(shift, Delta); self.SetFocus; if ValidDataSet then FDataLink.DataSet.MoveBy(Delta); end; procedure TDBCntrlGrid.KeyDown(var Key: Word; Shift: TShiftState); type TOperation=(opMoveBy,opCancel,opAppend,opInsert,opDelete); procedure DoOnKeyDown; begin if Assigned(OnKeyDown) then OnKeyDown(Self, Key, Shift); end; procedure DoOperation(AOper: TOperation; Arg: Integer = 0); begin self.SetFocus; case AOper of opMoveBy: FDatalink.DataSet.MoveBy(Arg); opCancel: begin FDatalink.Dataset.Cancel; end; opAppend: FDatalink.Dataset.Append; opInsert: FDatalink.Dataset.Insert; opDelete: FDatalink.Dataset.Delete; end; end; function doVKDown: boolean; begin if InsertCancelable then begin if IsEOF then result:=true else begin doOperation(opCancel); result := false; end; end else begin result:=false; doOperation(opMoveBy, 1); if GridCanModify and FDataLink.EOF then begin if not (dgpDisableInsert in Options) then doOperation(opAppend); end end; end; function DoVKUP: boolean; begin if InsertCancelable then doOperation(opCancel) else begin doOperation(opMoveBy, -1); end; result := FDatalink.DataSet.BOF; end; begin case Key of VK_DOWN: begin DoOnKeyDown; if (Key<>0) and ValidDataset then begin doVKDown; Key := 0; end; end; VK_UP: begin doOnKeyDown; if (Key<>0) and ValidDataset then begin doVKUp; key := 0; end; end; VK_NEXT: begin doOnKeyDown; if (Key<>0) and ValidDataset then begin doOperation(opMoveBy, VisibleRowCount); Key := 0; end; end; VK_PRIOR: begin doOnKeyDown; if (Key<>0) and ValidDataset then begin doOperation(opMoveBy, -VisibleRowCount); key := 0; end; end; VK_ESCAPE: begin doOnKeyDown; if ValidDataSet then doOperation(opCancel); end; VK_HOME: begin doOnKeyDown; if (Key<>0) and ValidDataSet then begin if ssCTRL in Shift then begin FDataLink.DataSet.First; Key:=0; end; end; end; VK_END: begin doOnKeyDown; if Key<>0 then begin if ValidDataSet then begin if ssCTRL in shift then begin FDatalink.DataSet.Last; Key:=0; end; end; end; end; end; end; procedure TDBCntrlGrid.LinkActive(Value: Boolean); begin if not Value then begin FRowCache.ClearCache; FInCacheRefresh := false; FCacheRefreshQueued := false; Row := FixedRows; FDrawingActiveRecord := false; FSelectedRecNo := 0; FSelectedRow := 0; FRequiredRecNo := 0; end; FRowCache.UseAlternateColors := AlternateColor <> Color; FRowCache.AltColorStartNormal := AltColorStartNormal; FLastRecordCount := 0; LayoutChanged; if Value then begin { The problem being solved here is that TDataSet does not readily tell us when a record is deleted. We get a DataSetChanged event - but this can occur for many reasons. Only by monitoring the record count accurately can be determine when a record is deleted. To do this we need to scroll the whole dataset to the end when the dataset is activated. Not desirable with large datasets - but a fix to TDataSet is needed to avoid this. } FDataLink.DataSet.DisableControls; try FDataLink.DataSet.Last; FLastRecordCount := FDataLink.DataSet.RecordCount; if not FDefaultPositionAtEnd then FDataLink.DataSet.First; FRequiredRecNo := FDataLink.DataSet.RecNo; finally FDataLink.DataSet.EnableControls; end; end; end; procedure TDBCntrlGrid.LayoutChanged; begin if csDestroying in ComponentState then exit; BeginUpdate; try if UpdateGridCounts=0 then EmptyGrid; finally EndUpdate; end; UpdateScrollbarRange; end; procedure TDBCntrlGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Gz: TGridZone; P: TPoint; procedure doMouseDown; begin // if not Focused then // SetFocus; if assigned(OnMouseDown) then OnMouseDown(Self, Button, Shift, X, Y); end; procedure doInherited; begin inherited MouseDown(Button, Shift, X, Y); end; procedure doMoveBy; begin FDatalink.DataSet.MoveBy(P.Y - Row); end; procedure doMoveToColumn; begin Col := P.X; end; procedure DoCancel; begin FDatalink.Dataset.cancel; end; begin if (csDesigning in componentState) or not ValidDataSet then begin exit; end; self.SetFocus; { if not MouseButtonAllowed(Button) then begin doInherited; exit; end;} Gz:=MouseToGridZone(X,Y); CacheMouseDown(X,Y); case Gz of gzInvalid: doMouseDown; gzFixedCells, gzFixedCols: doInherited; else begin P:=MouseToCell(Point(X,Y)); if Gz=gzFixedRows then P.X := Col; if P.Y=Row then begin //doAcceptValue; if not (ssCtrl in Shift) then begin if gz=gzFixedRows then doMouseDown else doInherited; end; end else begin doMouseDown; if ValidDataSet then begin if InsertCancelable and IsEOF then doCancel; doMoveBy; end; end; end; end; end; procedure TDBCntrlGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseUp(Button, Shift, X, Y); FLastMouse.X := X; FLastMouse.Y := Y; FLastMouseButton := Button; FLastMouseShiftState := Shift; Application.QueueAsyncCall(@DoSendMouseClicks,0); end; procedure TDBCntrlGrid.MoveSelection; begin inherited MoveSelection; InvalidateRow(Row); end; procedure TDBCntrlGrid.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) and (AComponent = FDrawPanel) then FDrawPanel := nil; end; procedure TDBCntrlGrid.PrepareCanvas(aCol, aRow: Integer; aState: TGridDrawState ); begin inherited PrepareCanvas(aCol, aRow, aState); if gdFixed in aState then begin if gdHot in aState then Canvas.Brush.Color := FixedHotColor else Canvas.Brush.Color := GetColumnColor(aCol, gdFixed in AState); end; if (not FDatalink.Active) and ((gdSelected in aState) or (gdFocused in aState)) then Canvas.Brush.Color := Self.Color; end; procedure TDBCntrlGrid.ResetSizes; begin LayoutChanged; inherited ResetSizes; DoGridResize; end; procedure TDBCntrlGrid.SetColor(Value: TColor); begin inherited SetColor(Value); if (csDesigning in ComponentState) and assigned(FDrawPaneL) then FDrawPanel.Color := Value; end; procedure TDBCntrlGrid.UpdateActive; var PrevRow: Integer; begin if (csDestroying in ComponentState) or (FDatalink=nil) or (not FDatalink.Active) or (FDatalink.ActiveRecord<0) then exit; if Assigned( OnUpdateActive ) then OnUpdateActive( FDataLink ); FDrawRow := FixedRows + FDataLink.ActiveRecord; FSelectedRecNo := FDataLink.DataSet.RecNo; PrevRow := Row; Row := FDrawRow; if not FInCacheRefresh then begin FSelectedRow := FDrawRow; if FDatalink.DataSet.State <> dsInsert then FRowCache.InvalidateRowImage(FSelectedRecNo); end; InvalidateRow(PrevRow); SetupDrawPanel(FDrawRow); end; procedure TDBCntrlGrid.UpdateData; begin FModified := false; end; procedure TDBCntrlGrid.UpdateShowing; begin inherited UpdateShowing; DoGridResize end; procedure TDBCntrlGrid.UpdateVertScrollbar(const aVisible: boolean; const aRange, aPage, aPos: Integer); begin UpdateScrollbarRange; end; constructor TDBCntrlGrid.Create(AOwner: TComponent); begin inherited Create(AOwner); FDataLink := TDBCntrlGridDataLink.Create;//(Self); FRowCache := TRowCache.Create; FDataLink.OnRecordChanged:=@OnRecordChanged; FDataLink.OnDatasetChanged:=@OnDataSetChanged; FDataLink.OnDataSetOpen:=@OnDataSetOpen; FDataLink.OnDataSetClose:=@OnDataSetClose; FDataLink.OnNewDataSet:=@OnNewDataSet; FDataLink.OnInvalidDataSet:=@OnInvalidDataset; FDataLink.OnInvalidDataSource:=@OnInvalidDataSource; FDataLink.OnDataSetScrolled:=@OnDataSetScrolled; FDataLink.OnLayoutChanged:=@OnLayoutChanged; FDataLink.OnEditingChanged:=@OnEditingChanged; FDataLink.OnUpdateData:=@OnUpdateData; FDataLink.OnCheckBrowseMode := @OnCheckBrowseMode; FDataLink.VisualControl:= True; ScrollBars := ssAutoVertical; FOptions := [dgpIndicator]; FixedCols := 1; ColCount := 1; FixedRows := 0; RowCount := 1; ColWidths[0] := 12; Columns.Add.ReadOnly := true; {Add Dummy Column for Panel} DoGridResize; if not (csDesigning in ComponentState) then Application.AddOnKeyDownBeforeHandler(@KeyDownHandler,false); end; destructor TDBCntrlGrid.Destroy; begin if assigned(FDataLink) then begin FDataLink.OnDataSetChanged:=nil; FDataLink.OnRecordChanged:=nil; FDataLink.Free; end; if assigned(FRowCache) then FRowCache.Free; Application.RemoveAsyncCalls(self); if not (csDesigning in ComponentState) then Application.RemoveOnKeyDownBeforeHandler( @KeyDownHandler ); inherited Destroy; end; function TDBCntrlGrid.MouseToRecordOffset(const x, y: Integer; out RecordOffset: Integer): TGridZone; var aCol,aRow: Integer; begin Result := MouseToGridZone(x, y); RecordOffset := 0; if (Result=gzInvalid) or (Result=gzFixedCells) then exit; MouseToCell(x, y, aCol, aRow); if (Result=gzFixedRows) or (Result=gzNormal) then RecordOffset := aRow - Row; if (Result=gzFixedCols) or (Result=gzNormal) then begin aRow := ColumnIndexFromGridColumn(aCol); end; end; function TDBCntrlGrid.ExecuteAction(AAction: TBasicAction): Boolean; begin Result := (DataLink <> nil) and DataLink.ExecuteAction(AAction); end; function TDBCntrlGrid.UpdateAction(AAction: TBasicAction): Boolean; begin Result := (DataLink <> nil) and DataLink.UpdateAction(AAction); end; procedure Register; begin {$I dbcontrolgrid_icon.lrs} RegisterComponents('Data Controls',[TDBCntrlGrid]); end; end. |
|
I have had a go at creating an abstract TDBTreeView. The result is attached together with IBX and TSQLQuery implementations. I have done a quick compile and run test of the iBX version. But have not even compiled my TSQLQuery hack. Hopefully it will work when compiled. |
|
Just remembered that I had forgotten to deal with your extra parameter to ScrollToNode. Update attached |
|
I asked on the devs mailing list today whether the DBCntrlGrid and DBTreeView should be included in Lazarus, and the overwhelming answer was: no. The components should be hosted somewhere else and made available via OPM. OPM is included in Lazarus and installed by default, and it is a one-click action for a user to install a third-party component. Now we have three options: * The easiest solution which gives you most freedom: Zdravko, you could create an account on github, gitlab, sourceforge or whatever and host the components yourself. * I put the components, package and demo on a subfolder of CCR. I can arrange that you, Zdravko, get commit rights, and then you can maintain the further development. * Since I see in the discussion that Tony's original components are still under development it is probably a bad idea to create a fork now because sooner or later both branches will run out of sync. Therefore, why don't you, Tony, host the components on your site as a package in addition to the other IBX components? In any case, the Lazarus team will not maintain the components. In order to make the components available for OPM you must create a zip file with package, source and demo files and store it on some location accessible to the public; then send the link to forum user GetMem or write a message to the forum thread https://forum.lazarus.freepascal.org/index.php/topic,34297.0.html and GetMem, the maintainer of OPM, will add the new package to OPM. Whenever you want to release a new version you'll store a new zip and send the new link again. Easy. What's your choice? |
|
>Tony, host the components on your site as a package in addition to the other IBX components? The components are already part of IBX and in the package IBControls. However, i am not able to support a TSQLQuery version and it would not be appropriate for me to try and do so - which I suppose is why Zdravko proposed to add them to lazarus. In the next version of IBX, I will probably include the abstract class version of TIBTreeView separate from the IBX implementation to make it easier for someone to pick up and use the package for non-IBX use. |
|
>* The easiest solution which gives you most freedom: Zdravko, you could create an account on github, gitlab, sourceforge or whatever and host the components yourself. I allready have github account. Here is the repository: https://github.com/ZGabrovski/DBTreeViewAndDBCntrlGrid and the post in the forum: https://bugs.freepascal.org/view.php?id=38336 I also send a PM to GetMem. |
|
I saw that GetMem already has put it in OPM. Then I can mark this report as resolved. Please close it. |
|
Thanks a lot! Have a nice day! All the bugfixes I will update in the github repo. |
|
Yes, and when you think that it's time for a new release create a new zip and send its link to GetMem again (OPM does not link to the developer's repositories). Maybe one thing which is not menitoned usually: OPM relies on the package version number to identify packages as "new". Therefore, your relase packages should differ in version number. |
|
OK, thanks! |
Date Modified | Username | Field | Change |
---|---|---|---|
2021-01-09 16:34 | Zdravko Gabrovski | New Issue | |
2021-01-09 16:34 | Zdravko Gabrovski | File Added: DBTreeView.7z | |
2021-01-09 18:23 | wp | Note Added: 0128207 | |
2021-01-09 21:13 | Zdravko Gabrovski | Note Added: 0128217 | |
2021-01-09 21:37 | Zdravko Gabrovski | Note Added: 0128218 | |
2021-01-09 21:37 | Zdravko Gabrovski | File Added: Sample.7z | |
2021-01-09 22:18 | Juha Manninen | Note Added: 0128223 | |
2021-01-10 01:32 | wp | Note Added: 0128233 | |
2021-01-10 06:07 | Zdravko Gabrovski | Note Added: 0128234 | |
2021-01-10 11:26 | wp | Note Added: 0128237 | |
2021-01-10 11:29 | wp | Note Edited: 0128237 | View Revisions |
2021-01-10 15:08 | Zdravko Gabrovski | Note Added: 0128243 | |
2021-01-11 14:33 | Sven Barth | Note Added: 0128265 | |
2021-01-11 15:28 | wp | Note Added: 0128267 | |
2021-01-11 21:00 | Zdravko Gabrovski | Note Added: 0128273 | |
2021-01-11 21:00 | Zdravko Gabrovski | File Added: DBTreeView-2.7z | |
2021-01-11 21:00 | Zdravko Gabrovski | File Added: tripical_3hyyAJTr16.png | |
2021-01-12 05:51 | Valdir Marcos | Note Added: 0128278 | |
2021-01-12 09:51 | wp | Note Added: 0128279 | |
2021-01-12 09:51 | wp | Assigned To | => wp |
2021-01-12 09:51 | wp | Status | new => assigned |
2021-01-12 10:14 | wp | Note Edited: 0128279 | View Revisions |
2021-01-12 11:21 | Zdravko Gabrovski | Note Added: 0128280 | |
2021-01-12 11:33 | wp | Note Added: 0128281 | |
2021-01-12 12:39 | Zdravko Gabrovski | Note Added: 0128282 | |
2021-01-12 17:59 | Zdravko Gabrovski | Note Added: 0128285 | |
2021-01-12 17:59 | Zdravko Gabrovski | File Added: DBTreeView-3.7z | |
2021-01-12 18:01 | Zdravko Gabrovski | Note Added: 0128287 | |
2021-01-12 18:01 | Zdravko Gabrovski | File Added: SQLTreeVew_5qCsavkI54.png | |
2021-01-12 18:20 | wp | Note Added: 0128288 | |
2021-01-13 00:18 | Tony Whyman | Note Added: 0128293 | |
2021-01-13 00:33 | Tony Whyman | Note Added: 0128294 | |
2021-01-13 06:26 | Zdravko Gabrovski | Note Added: 0128295 | |
2021-01-13 12:20 | Tony Whyman | Note Added: 0128296 | |
2021-01-13 14:26 | Zdravko Gabrovski | Note Added: 0128297 | |
2021-01-13 14:26 | Zdravko Gabrovski | File Added: DBTreeView-4.7z | |
2021-01-13 14:26 | Zdravko Gabrovski | File Added: dbcntrlgrid.pas | |
2021-01-13 15:29 | Tony Whyman | Note Added: 0128298 | |
2021-01-13 15:29 | Tony Whyman | File Added: ibcontrols.zip | |
2021-01-13 15:29 | Tony Whyman | Note Edited: 0128298 | View Revisions |
2021-01-13 15:30 | Tony Whyman | Note Edited: 0128298 | View Revisions |
2021-01-13 15:58 | Tony Whyman | Note Added: 0128299 | |
2021-01-13 15:58 | Tony Whyman | File Added: ibcontrolsv2.zip | |
2021-01-13 16:39 | wp | Note Added: 0128300 | |
2021-01-13 16:39 | wp | Status | assigned => feedback |
2021-01-13 16:39 | wp | LazTarget | => - |
2021-01-13 23:29 | wp | Note Edited: 0128300 | View Revisions |
2021-01-14 00:16 | Tony Whyman | Note Added: 0128306 | |
2021-01-14 08:45 | Zdravko Gabrovski | Note Added: 0128309 | |
2021-01-14 08:45 | Zdravko Gabrovski | Status | feedback => assigned |
2021-01-14 09:42 | wp | Status | assigned => resolved |
2021-01-14 09:42 | wp | Resolution | open => no change required |
2021-01-14 09:42 | wp | Note Added: 0128310 | |
2021-01-14 11:08 | Zdravko Gabrovski | Note Added: 0128311 | |
2021-01-14 12:10 | wp | Note Added: 0128313 | |
2021-01-14 16:13 | Zdravko Gabrovski | Note Added: 0128318 |