Affirming: The source code is not written, just paste others work, the purpose is to promote! {************************************************* *********************************************************** *} {File name .......: dbvgrids.zipfile description: Implementation of a vertical dbgrid based on vcl's dbgrids.pas.targets ............................................................................................................................................................................................................................................................................................................................................................................................................................................ .: George VavoyLogiannisemail ...........: Georgev@hol.grweb .................................................. ...: freewarecategory ........: Database Components.
For a long time till a few months, I Was Trying to Find A Solution for Vertical Grid. I Found A Few Grid Components That Claimed To Be Vertical, But this Was Far from Tue. So One Day I Decided to Have A Better Look At The dbgrids.pas in borland vcl source. "Bit by bit" AS We say in Gree I Started Changing The code and finally a true us we have here.
I Wonder Why Borland Did't Think About this. After All It Seems So Simple !!!
NEW PROPERTIES Vertical: Boolean, set to True and and the grid becomes VERTICAL OnlyOne: Boolean, set to true if you want the grid to display only one record at a time (the curent record) TitlesWidth:. Integer, set the vertical column title's Width.
NOTE: because all the code is duplicated from the VCL, all the classes are redefined (TColumn, TDBGridColumns, TGridDatalink etc) The columns editor works fine except that it does not bring the fields list This is something that i may do in future.. Versions But Id IT OR Even Has Property Editor for the Column Please Drop ME AN E-MAIL.
Free to use and redistribute, but my name mustappear somewhere in the source code, or in the software.no warranty is given by the author, express.
Warning! The code is supplied as is with no guarance!} {********** *********************************************************** ***********************}
Unit dbvgrids;
{$ R-}
Interface
Uses Windows, Sysutils, Messages, Classes, Controls, Forms, Stdctrls, Graphics, Grids, Dbctrls, DB, Menus, DBGRIDS, Variants;
type TColumnValue = (cvColor, cvWidth, cvFont, cvAlignment, cvReadOnly, cvTitleColor, cvTitleCaption, cvTitleAlignment, cvTitleFont, cvImeMode, cvImeName); TColumnValues = set of TColumnValue;
Const columnTitiValues = [cvtitlecolor..cvtitlefont]; cm_deferlayout = wm_user 100;
{TColumn defines internal storage for column attributes. Values assigned to properties are stored in this object, the grid- or field-based default sources are not modified. Values read from properties are the previously assigned value, if any, or the grid- or field-based default values if nothing has been assigned to that property This class also publishes the column attribute properties for persistent storage} type TColumn = class;.. TCustomVDBGrid = class;
TColumnTitle = class (TPersistent) private FColumn: TColumn; FCaption: string; FFont: TFont; FColor: TColor; FAlignment: TAlignment; procedure FontChanged (Sender: TObject); function GetAlignment: TAlignment; function GetColor: TColor; function GetCaption: string; function GetFont: TFont; function IsAlignmentStored: Boolean; function IsColorStored: Boolean; function IsFontStored: Boolean; function IsCaptionStored: Boolean; procedure setAlignment (Value: TAlignment); procedure SetColor (Value: TColor); procedure SetFont (Value: TFont); procedure setCaption (const Value: string); virtual; protected procedure RefreshDefaultFont; public constructor Create (Column: TColumn); destructor Destroy; override; procedure Assign (Source: TPersistent); override; function DefaultAlignment: TAlignment; function DefaultColor: TColor; function DefaultFont : Tfont; function defaultcaption: string; procedure restefaults; Virtua l; published property Alignment: TAlignment read GetAlignment write SetAlignment stored IsAlignmentStored; property Caption: string read GetCaption write SetCaption stored IsCaptionStored; property Color: TColor read GetColor write SetColor stored IsColorStored; property Font: TFont read GetFont write SetFont stored IsFontStored; end; TColumnButtonStyle = (Cbsauto, CBSELLIPSIS, CBSNON);
TColumn = class (TCollectionItem) private FField: TField; FFieldName: string; FColor: TColor; FWidth: Integer; FTitle: TColumnTitle; FFont: TFont; FImeMode: TImeMode; FImeName: TImeName; FPickList: TStrings; FPopupMenu: TPopupMenu; FDropDownRows: Cardinal ; FButtonStyle: TColumnButtonStyle; FAlignment: TAlignment; FReadonly: Boolean; FAssignedValues: TColumnValues; procedure FontChanged (Sender: TObject); function getAlignment: TAlignment; function GetColor: TColor; function GetField: TField; function GetFont: TFont; function GetImeMode: TImeMode; function GetImeName: TImeName; function GetPickList: TStrings; function getReadOnly: Boolean; function GetWidth: Integer; function IsAlignmentStored: Boolean; function IsColorStored: Boolean; function IsFontStored: Boolean; function IsImeModeStored: Boolean; function IsImeNameStored: Boolean; function IsReadOnlyStored: Boolean; Functio n IsWidthStored: Boolean; procedure SetAlignment (Value: TAlignment); virtual; procedure SetButtonStyle (Value: TColumnButtonStyle); procedure SetColor (Value: TColor); procedure SetField (Value: TField); virtual; procedure SetFieldName (const Value: String); procedure SetFont (Value: TFont); procedure SetImeMode (Value: TImeMode); virtual; procedure SetImeName (Value: TImeName); virtual; procedure SetPickList (Value: TStrings); procedure SetPopupMenu (Value: TPopupMenu); procedure SetReadOnly (Value: Boolean Virtual; value: tcolumntitle; procedure setwidth; Virtual; protected function createTitle: tcolumntitle; virtual; function getGRID;
function GetDisplayName: string; override; procedure RefreshDefaultFont; public constructor Create (Collection: TCollection); override; destructor Destroy; override; procedure Assign (Source: TPersistent); override; function DefaultAlignment: TAlignment; function DefaultColor: TColor; function DefaultFont: TFont ; function DefaultImeMode: TImeMode; function DefaultImeName: TImeName; function DefaultReadOnly: Boolean; function DefaultWidth: Integer; procedure RestoreDefaults; virtual; property Grid: TCustomVDBGrid read GetGrid; property AssignedValues: TColumnValues read FAssignedValues; property Field: TField read GetField write SetField; published property Alignment: TAlignment read getAlignment write setAlignment stored IsAlignmentStored; property ButtonStyle: TColumnButtonStyle read FButtonStyle write SetButtonStyle default cbsAuto; property Color: TColor read GetColor write SetColor stored IsColorStored; property DropDownRows: Cardinal read FDropDownRows write FDropDownRows default 7; property FieldName: String read FFieldName write SetFieldName; property Font: TFont read GetFont write SetFont stored IsFontStored; property ImeMode: TImeMode read GetImeMode write SetImeMode stored IsImeModeStored; property ImeName: TImeName read GetImeName write SetImeName stored IsImeNameStored; property PickList: TStrings read GetPickList write SetPickList; property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu; property ReadOnly: Boolean read getReadOnly write SetReadOnly stored IsReadOnlyStored; property Title: TColumnTitle read FTitle write SetTitle;
Property Width: Integer ReadWidth Write SetWidth Stored IsWidthStored; End; TcolumnClass = Class of Tcolumn;
TDBGRIDCOLUMNSSSTATE = (CSDefault, CSCustomized);
TDBGridColumns = class (TCollection) private FGrid: TCustomVDBGrid; function GetColumn (Index: Integer): TColumn; function GetState: TDBGridColumnsState; procedure SetColumn (Index: Integer; Value: TColumn); procedure SetState (NewState: TDBGridColumnsState); protected function GetOwner: TPersistent; override; procedure Update (Item: TCollectionItem); override; public constructor Create (Grid: TCustomVDBGrid; columnClass: TColumnClass); function Add: TColumn; procedure LoadFromFile (const Filename: string); procedure LoadFromStream (S: TStream); procedure RestoreDefaults; procedure RebuildColumns; procedure SaveToFile (const Filename: string); procedure SaveToStream (S: TStream); property State: TDBGridColumnsState read GetState write SetState; property Grid: TCustomVDBGrid read fGrid; property Items [Index: Integer]: TColumn read GetColumn write SETCOLUMN; DEFAULT;
TGridDataLink = class (TDataLink) private FGrid: TCustomVDBGrid; FFieldCount: Integer; FFieldMapSize: Integer; FFieldMap: Pointer; FModified: Boolean; FInUpdateData: Boolean; FSparseMap: Boolean; function GetDefaultFields: Boolean; function GetFields (I: Integer): TField; protected procedure ActiveChanged; override; procedure DataSetChanged; override; procedure DataSetScrolled (Distance: Integer); override; procedure FocusControl (Field: TFieldRef); override; procedure EditingChanged; override; procedure LayoutChanged; override; procedure RecordChanged (Field: TField); override ; procedure UpdateData; override; function GetMappedIndex (ColIndex: Integer): Integer; public constructor Create (AGrid: TCustomVDBGrid); destructor Destroy; override; function AddMapping (const FieldName: string): Boolean; procedure ClearMapping; procedure Modified; procedure Reset; Property Defaultfields: Boolean Read GetDefaultfields; P ROPERTY FIELDCOUNT; Property Fields [I: Integer]: Tfield ReadField; Property Sparsemap: Boolean Read Fsparsemap Write fsparsemap;
TBookmarkList = class private FList: TStringList; FGrid: TCustomVDBGrid; FCache: TBookmarkStr; FCacheIndex: Integer; FCacheFind: Boolean; FLinkActive: Boolean; function GetCount: Integer; function GetCurrentRowSelected: Boolean; function GetItem (Index: Integer): TBookmarkStr; procedure SetCurrentRowSelected (Value: Boolean); procedure StringsChanged (Sender: TObject); protected function CurrentRow: TBookmarkStr; function Compare (const Item1, Item2: TBookmarkStr): Integer; procedure linkActive (Value: Boolean); public constructor Create (AGrid: TCustomVDBGrid); destructor Destroy; override; procedure Clear; // free all bookmarks procedure Delete; // delete all selected rows from dataset function Find (const Item: TBookmarkStr; var Index: Integer): Boolean; function IndexOf (const Item: TBookmarkStr): Integer Function Refresh: Boolean; // Drop orphaned Bookmarks; True = Orphans Found Property Count: INTE ger read GetCount; property CurrentRowSelected: Boolean read GetCurrentRowSelected write SetCurrentRowSelected; property Items [Index: Integer]: TBookmarkStr read GetItem; default; end; TDBGridOption = (dgEditing, dgAlwaysShowEditor, dgTitles, dgIndicator, dgColumnResize, dgColLines, dgRowLines, dgTabs, dgRowSelect, DGALWAYSSHOWSELECTION, DGCONFIRMDELETE, DGCANCENCELONEXIT, DGMULTITISELECT); TDBGRIDOPTION = Set of TdbGridOption;
{The VDBGrid's DrawDataCell virtual method and OnDrawDataCell event are only called when the grid's Columns.State is csDefault. This is for compatibility with existing code. These routines do not provide sufficient information to determine which column is being drawn, so the column attributes aren 't easily accessible in these routines column attributes also introduce the possibility that a column's field may be nil, which would break existing DrawDataCell code DrawDataCell, OnDrawDataCell, and DefaultDrawDataCell are obsolete, retained for compatibility purposes} TDrawDataCellEvent = procedure (Sender...: TObject; const Rect: TRect; Field: TField; State: TGridDrawState) of object; {The VDBGrid's DrawColumnCell virtual method and OnDrawColumnCell event are always called, when the grid has defined column attributes as well as when it is in default mode These new. Routines Provide the Additional Information Needed to Access The Column Attributes for The Cell Being Drawn, And Must Support Nil Fields.
TDrawColumnCellEvent = procedure (Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState) of object; TDBGridClickEvent = procedure (Column: TColumn) of object;
TCustomVDBGrid = class (TCustomGrid) private FIndicators: TImageList; FTitleFont: TFont; FReadOnly: Boolean; FOriginalImeName: TImeName; FOriginalImeMode: TImeMode; FUserChange: Boolean; FLayoutFromDataset: Boolean; FOptions: TDBGridOptions; FTitleOffset, FIndicatorOffset: Byte; FUpdateLock: Byte; FLayoutLock : Byte; FInColExit: Boolean; FDefaultDrawing: Boolean; FSelfChangingTitleFont: Boolean; FSelecting: Boolean; FSelRow: Integer; FDataLink: TGridDataLink; FOnColEnter: TNotifyEvent; FOnColExit: TNotifyEvent; FOnDrawDataCell: TDrawDataCellEvent; FOnDrawColumnCell: TDrawColumnCellEvent; FEditText: string; FColumns: TDBGridColumns ; FOnEditButtonClick: TNotifyEvent; FOnColumnMoved: TMovedEvent; FBookmarks: TBookmarkList; FSelectionAnchor: TBookmarkStr; FVertical: Boolean; FOnlyOne: Boolean; FTitlesWidth: integer; FOnCellClick: TDBGridClickEvent; FOnTitleClick: TDBGridClickEvent; function Ac quireFocus: Boolean; procedure DataChanged; procedure EditingChanged; function GetDataSource: TDataSource; function GetFieldCount: Integer; function GetFields (FieldIndex: Integer): TField; function GetSelectedField: TField; function GetSelectedIndex: Integer; procedure InternalLayout; procedure MoveCol (RawCol: Integer) ; procedure ReadColumns (Reader: TReader); procedure RecordChanged (Field: TField); procedure SetIme; procedure SetColumns (Value: TDBGridColumns); procedure SetDataSource (Value: TDataSource); procedure SetOptions (Value: TDBGridOptions); procedure SetSelectedField (Value: TField ); Procedure setSelectedIndex (value: integer); Procedure SetTitleFont (Value: tfont);
procedure TitleFontChanged (Sender: TObject); procedure UpdateData; procedure UpdateActive; procedure UpdateIme; procedure UpdateScrollBar; procedure UpdateRowCount; procedure WriteColumns (Writer: TWriter); procedure SetVertical (Value: Boolean); procedure SetOnlyOne (Value: Boolean); procedure SetTitlesWidth ( Value: integer); function TabStopRow (Arow: integer): Boolean; procedure CMExit (var Message: TMessage); message CM_EXIT; procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED; procedure CMParentFontChanged (var Message: TMessage); message CM_PARENTFONTCHANGED ; procedure CMDeferLayout (var Message); message cm_DeferLayout; procedure CMDesignHitTest (var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST; procedure WMSetCursor (var Msg: TWMSetCursor); message WM_SETCURSOR; procedure WMSize (var Message: TWMSize); message WM_SIZE; procedure WMVScroll ( Var message: twmvscroll; message wm_vscroll; procedure wmhscroll (var Message: TWMHScroll); message WM_HSCROLL; procedure WMIMEStartComp (var Message: TMessage); message WM_IME_STARTCOMPOSITION; procedure WMSetFocus (var Message: TWMSetFocus); message WM_SetFOCUS; procedure WMKillFocus (var Message: TMessage); message WM_KillFocus; protected FUpdateFields: Boolean; FAcquireFocus : Boolean; FUpdatingEditor: Boolean; function RawToDataColumn (ACol: Integer): Integer; function DataToRawColumn (ACol: Integer): Integer; function AcquireLayoutLock: Boolean; procedure BeginLayout; procedure BeginUpdate; procedure CancelLayout; function CanEditAcceptKey (Key: Char): Boolean Override; Function Calyitmodify: Boolean; Override; Function Calyitshow: Boolean; Override;
procedure CellClick (Column: TColumn); dynamic; procedure ColumnMoved (FromIndex, ToIndex: Longint); override; procedure RowMoved (FromIndex, ToIndex: Longint); override; procedure ColEnter; dynamic; procedure ColExit; dynamic; procedure ColWidthsChanged; override; function CreateColumns: TDBGridColumns; dynamic; function createEditor: TInplaceEdit; override; procedure CreateWnd; override; procedure DeferLayout; procedure DefaultHandler (var Msg); override; procedure DefineFieldMap; virtual; procedure DefineProperties (Filer: TFiler); override; procedure DrawCell (ACol, aRow: Longint; aRect: TRect; aState: TGridDrawState); override; procedure DrawDataCell (const Rect: TRect; Field: TField; State: TGridDrawState); dynamic; {obsolete} procedure DrawColumnCell (const Rect: TRect; DataCol: Integer; Column : Tcolumn; state: tgriddrawstate; Dynamic; Procedure EditButtonClick; Dynamic; Procedure Endlayout; ction GetColField (DataCol: Integer): TField; function GetEditLimit: Integer; override; function GetEditMask (ACol, ARow: Longint): string; override; function GetEditText (ACol, ARow: Longint): string; override; function GetFieldValue (ACol: Integer): string; function HighlightCell (DataCol, DataRow: Integer; const Value: string; aState: TGridDrawState): Boolean; virtual; procedure KeyDown (var Key: Word; Shift: TShiftState); override; procedure KeyPress (var Key: Char ); override; procedure LayoutChanged; virtual; procedure linkActive (Value: Boolean); virtual; procedure Loaded; override; procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure Notification (AComponent: TComponent; Operation: TOperation); override; procedure Scroll (Distance: Integer); virtual; procedure SetColumnAttributes; virtual; procedure SetEditText (ACol, aRow: Longint; const Value: string); override; function StoreColumns: Boolean; procedure TimedScroll (Direction: TGridScrollDirection); override; procedure TitleClick (Column: TColumn); dynamic; property Columns: TDBGridColumns read FColumns write SetColumns; property DefaultDrawing: Boolean read FDefaultDrawing write FDefaultDrawing default True; property DataSource: TDataSource read GetDataSource write SetDataSource; property DataLink: TGridDataLink read FDataLink; property IndicatorOffset: Byte read FIndicatorOffset; property LayoutLock: Byte read FLayoutLock; property Options: TDBGridOptions read FOptions write SetOptions default DGEDITING, DGTIS, DGIN dicator, dgColumnResize, dgColLines, dgRowLines, dgTabs, dgConfirmDelete, dgCancelOnExit]; property ParentColor default False; property ReadOnly: Boolean read FReadOnly write FReadOnly default False; property SelectedRows: TBookmarkList read FBookmarks; property TitleFont: TFont read FTitleFont write SetTitleFont; property UpdateLock: byte read FUpdateLock; property OnColEnter: TNotifyEvent read FOnColEnter write FOnColEnter; property OnColExit: TNotifyEvent read FOnColExit write FOnColExit; property OnDrawDataCell: TDrawDataCellEvent read FOnDrawDataCell write FOnDrawDataCell; {obsolete} property OnDrawColumnCell: TDrawColumnCellEvent read FOnDrawColumnCell write FOnDrawColumnCell;
property OnEditButtonClick: TNotifyEvent read FOnEditButtonClick write FOnEditButtonClick; property OnColumnMoved: TMovedEvent read FOnColumnMoved write FOnColumnMoved; property OnCellClick: TDBGridClickEvent read FOnCellClick write FOnCellClick; property OnTitleClick: TDBGridClickEvent read FOnTitleClick write FOnTitleClick; public constructor Create (AOwner: TComponent); override; destructor Destroy; override; procedure DefaultDrawDataCell (const Rect: TRect; Field: TField; State: TGridDrawState); {obsolete} procedure DefaultDrawColumnCell (const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); function ValidFieldIndex (FieldIndex: Integer) : Boolean; property EditorMode; property FieldCount: Integer read GetFieldCount; property Fields [FieldIndex: Integer]: TField read GetFields; property selectedField: TField read GetSelectedField write SetSelectedField; property SelectedIndex: Integer read getSelectedIndex w rite SetSelectedIndex; property Vertical: Boolean read FVertical write SetVertical default False; property OnlyOne: Boolean read FOnlyOne write SetOnlyOne default False; property TitlesWidth: integer read FTitlesWidth write SetTitlesWidth; end;
TVDBGrid = class (TCustomVDBGrid) public property Canvas; property SelectedRows; published property Align; property BorderStyle; property Color; property Columns stored False; // StoreColumns; property Ctl3D; property DataSource; property DefaultDrawing; property DragCursor; property DragMode; property Enabled; property FixedColor; property Font; property ImeMode; property ImeName; property Options; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property ReadOnly; property ShowHint; property TabOrder; property TabStop; property TitleFont; property Visible; property Vertical ; property onlyOne; property DefaultColWidth; property TitlesWidth; property OnCellClick; property OnColEnter; property OnColExit; property OnColumnMoved; property OnDrawDataCell; {obsolete} property OnDrawColumnCell; property OnDblCl ick; property OnDragDrop; property OnDragOver; property OnEditButtonClick; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnStartDrag; property OnTitleClick; end; const IndicatorWidth = 11;
PROCEDURE register;
IMPLEMentation
Uses dbconsts, dialogs;
{$ R dbvgrids.res}
procedure Register; begin RegisterComponents ( 'Data Controls', [TVDBGrid]); // RegisterPropertyEditor (TypeInfo (TDBGridColumns), TCustomVDBGrid, // 'Columns', TDBGridColumnsEditor); end;
const bmArrow = 'DBVGARROW'; bmEdit = 'DBVEDIT'; bmInsert = 'DBVINSERT'; bmMultiDot = 'DBVMULTIDOT'; bmMultiArrow = 'DBVMULTIARROW'; MaxMapSize = (MaxInt div 2) div SizeOf (Integer); {250 million}
{Error Reporting}
Procedure RaiseGridError (const s: string); begin raise einvalidgridoperty.create (s); end;
procedure KillMessage (Wnd: HWnd; Msg: Integer); // Delete the requested message from the queue, but throw back // any WM_QUIT msgs that PeekMessage may also returnvar M: TMsg; begin M.Message: = 0; if PeekMessage ( M, Wnd, MSG, MSG, PM_Remove) and (m.Message = WM_QUIT) THEN PostquitMessage (M.WPARAM); END;
{TvdbgridinplaceEdit}
{TVDBGridInplaceEdit adds support for a button on the in-place editor, which can be used to drop down a table-based lookup list, a stringlist-based pick list, or (if button style is esEllipsis) fire the grid event OnEditButtonClick.}
TYPE TEDITSTYLE = (Essimple, ESELIPSIS, EspickList, ESDATALIST); TPOPListBox = Class;
TVDBGridInplaceEdit = class (TInplaceEdit) private FButtonWidth: Integer; FDataList: TDBLookupListBox; FPickList: TPopupListbox; FActiveList: TWinControl; FLookupSource: TDatasource; FEditStyle: TEditStyle; FListVisible: Boolean; FTracking: Boolean; FPressed: Boolean; procedure ListMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure SetEditStyle (Value: TEditStyle); procedure StopTracking; procedure TrackButton (X, Y: Integer); procedure CMCancelMode (var Message: TCMCancelMode); message CM_CancelMode; procedure WMCancelMode (var Message: TMessage); message WM_CancelMode; procedure WMKillFocus (var Message: TMessage); message WM_KillFocus; procedure WMLButtonDblClk (var Message: TWMLButtonDblClk); message wm_LButtonDblClk; procedure WMPaint (var Message: TWMPaint); message wm_Paint; procedure WMSetCursor (var Message: twmsetcursor; message wm_setcursor; protected procedure boundschanged; override; procedure CloseUp (Accept: Boolean); procedure DoDropDownKeys (var Key: Word; Shift: TShiftState); procedure DropDown; procedure KeyDown (var Key: Word; Shift: TShiftState); override; procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove (Shift: TShiftState; X, Y: Integer); override; procedure MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure PaintWindow ( DC: HDC); override; procedure UpdateContents; override; procedure WndProc (var Message: TMessage); override; property EditStyle: TEditStyle read FEditStyle write SetEditStyle; property ActiveList: TWinControl read FActiveList write FActiveList;
Property DataList: TdblookUplistBox Read FDataList; Property Picklist: TpopUplistbox read fpicklist; public constructor create (OVERRIDE; End; {TPopUplistbox}
TPopupListbox = class (TCustomListbox) private FSearchText: String; FSearchTickCount: Longint; protected procedure CreateParams (var Params: TCreateParams); override; procedure CreateWnd; override; procedure KeyPress (var Key: Char); override; procedure MouseUp (Button: TMouseButton; SHIFT: TshiftState; x, y: integer; override;
procedure TPopupListBox.CreateParams (var Params: TCreateParams); begin inherited CreateParams (Params); with Params do begin Style: = Style or WS_BORDER; ExStyle: = WS_EX_TOOLWINDOW or WS_EX_TOPMOST; WindowClass.Style: = CS_SAVEBITS; end; end;
Procedure tpuplistbox.createwnd; begin inherited createwnd; Windows.SetParent (Handle, 0); CallWindowProc (DefWndProc, Handle, WM_SETFOCUS, 0, 0); END;
procedure TPopupListbox.Keypress (var Key: Char); var TickCount: Integer; begin case Key of # 8, # 27: FSearchText: = ''; # 32 .. # 255: begin TickCount: = GetTickCount; if TickCount - FSearchTickCount> 2000 then FSearchText: = ''; FSearchTickCount: = TickCount; if Length (FSearchText) <32 then FSearchText: = FSearchText Key; SendMessage (Handle, LB_SelectString, WORD (-1), Longint (PChar (FSearchText))); Key : = # 0; end; end; inherited keypress (key);
procedure TPopupListbox.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseUp (Button, Shift, X, Y); TVDBGridInPlaceEdit (Owner) .CloseUp ((X> = 0) and (Y> = 0) and (X procedure TVDBGridInplaceEdit.BoundsChanged; var R: TRect; begin SetRect (R, 2, 2, Width - 2, Height); if FEditStyle <> esSimple then Dec (R.Right, FButtonWidth); SendMessage (Handle, EM_SETRECTNP, 0, LongInt (@R)); sendMessage (Handle, EM_Scrollcaret, 0, 0); if syslocale.fareast the setimeCompositionWindow (font, r.left, r.top); procedure TVDBGridInplaceEdit.CloseUp (Accept: Boolean); var MasterField: TField; ListValue: Variant; begin if FListVisible then begin if GetCapture <> 0 then SendMessage (GetCapture, WM_CANCELMODE, 0, 0); if FActiveList = FDataList then ListValue: = FDataList .KeyValue else if FPickList.ItemIndex <> -1 then listValue: = FPickList.Items [FPicklist.ItemIndex]; SetWindowPos (FActiveList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW) ; FListVisible: = False; if Assigned (FDataList) then FDataList.ListSource: = nil; FLookupSource.Dataset: = nil; Invalidate; if Accept then if FActiveList = FDataList then with TCustomVDBGrid (Grid), Columns [SelectedIndex] .Field do begin Masterfield: = dataset.fieldByname (keyfields); if masterfield.canmodify dam dataset.edit; masterfield.value: = listValue; end; end; else if (not VarIsNull (ListValue)) and EditCanModify then with TCustomVDBGrid (Grid), Columns [SelectedIndex] .Field do Text: = ListValue; end; end; procedure TVDBGridInplaceEdit.DoDropDownKeys (var Key: Word; Shift: TShiftState); begin case Key of VK_UP, VK_DOWN: if ssAlt in Shift then begin if FListVisible then CloseUp (True) else DropDown; Key: = 0; end; VK_RETURN, VK_ESCAPE: if FListVisible and not (ssAlt in Shift) then begin CloseUp (Key = VK_RETURN ); Key: = 0; end; end; procedure TVDBGridInplaceEdit.DropDown; var P: TPoint; I, J, Y: Integer; Column: TColumn; begin if not FListVisible and Assigned (FActiveList) then begin FActiveList.Width: = Width; with TCustomVDBGrid (Grid) do Column: = Columns [SelectedIndex]; if FActiveList = FDataList then with Column.Field do begin FDataList.Color: = Color; FDataList.Font: = Font; FDataList.RowCount: = Column.DropDownRows; FLookupSource.DataSet: = LookupDataSet; FDataList.KeyField: = LookupKeyFields; FDataList.ListField: = LookupResultField; FDataList.ListSource: = FLookupSource; FDataList.KeyValue: = DataSet.FieldByName (KeyFields) .Value; {J: = Column.DefaultWidth; if J> FDataList.ClientWidth then FDataList.ClientWidth: = J;} end else beg, fpicklist.color: = color; fpicklist.font: = font; fpicklist.items: = column.picklist; if fpicklist.items.count> = column.dropdownrows the fPickList.Height: = column .DropDownRows * FPickList.ItemHeight 4 else FPickList.Height: = FPickList.Items.Count * FPickList.ItemHeight 4; if Column.Field.IsNull then FPickList.ItemIndex: = -1 else FPickList.ItemIndex: = FPickList.Items. Indexof (Column.field.Value); J: = fpicklist.clientwidth; for i: = 0 to fpicklist.items.count - 1 do begin y: = fpicklist.canvas.textwidth (fpicklist.items [i]); if y: > J THEN J: = Y; End; fpicklist.clientwidth: = j; end; p: = parent.clienttoscreen (Point (Left, TOP)); Y: = Py Height; if Y FActiveList.Height> Screen.Height then Y: = PY - FActiveList.Height; SetWindowPos (FActiveList.Handle, HWND_TOP, PX, Y, 0, 0, SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW); FListVisible: = True; Invalidate; Windows.SetFocus (Handle); end; end; type twinControlcracker = class (twincontrol) end; procedure TVDBGridInplaceEdit.KeyDown (var Key: Word; Shift: TShiftState); begin if (EditStyle = esEllipsis) and (Key = VK_RETURN) and (Shift = [ssCtrl]) then begin TCustomVDBGrid (Grid) .EditButtonClick; KillMessage (Handle, WM_CHAR ); ELSE inherited keydown (key, shift); procedure TVDBGridInplaceEdit.ListMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then CloseUp (PtInRect (FActiveList.ClientRect, Point (X, Y))); end; procedure TVDBGridInplaceEdit.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Button = mbLeft) and (FEditStyle <> esSimple) and PtInRect (Rect (Width - FButtonWidth, 0, Width, Height), Point (X, Y)) then begin if FListVisible then CloseUp (False) else begin MouseCapture: = True; FTracking: = True; TrackButton (X, Y); if Assigned (FActiveList) then DropDown; end; end; inherited MouseDown ( Button, SHIFT, X, Y); END; procedure TVDBGridInplaceEdit.MouseMove (Shift: TShiftState; X, Y: Integer); var ListPos: TPoint; MousePos: TSmallPoint; begin if FTracking then begin TrackButton (X, Y); if FListVisible then begin ListPos: = FActiveList.ScreenToClient (ClientToScreen ( Point (X, Y))); if PtInRect (FActiveList.ClientRect, ListPos) then begin StopTracking; MousePos: = PointToSmallPoint (ListPos); SendMessage (FActiveList.Handle, WM_LBUTTONDOWN, 0, Integer (MousePos)); Exit; end; end; end; inherited MouseMove (Shift, X, Y); end; procedure TVDBGridInplaceEdit.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var WasPressed: Boolean; begin WasPressed: = FPressed; StopTracking; if (Button = mbleft) and waspressed the TCUSTOMVDBGRID (GRID) .editbuttonClick; inherited Mouseup (Button, Shift, X, Y); procedure TVDBGridInplaceEdit.PaintWindow (DC: HDC); var R: TRect; Flags: Integer; W: Integer; begin if FEditStyle <> esSimple then begin SetRect (R, Width - FButtonWidth, 0, Width, Height); Flags: = 0 ; if FEditStyle in [esDataList, esPickList] then begin if FActiveList = nil then Flags: = DFCS_INACTIVE else if FPressed then Flags: = DFCS_FLAT or DFCS_PUSHED; DrawFrameControl (DC, R, DFC_SCROLL, Flags or DFCS_SCROLLCOMBOBOX); end else {esEllipsis} begin If FPRESSED THEN FLAGS: = BF_FLAT; DRAWEDGE (DC, R, EDGE_RAISED, BF_RECT OR BF_MIDDLE OR FLAGS); Flags: = ((R.right - R.Left) Shr 1) - 1 ORD (FPRESSED); W: = Height SHR 3; IF W = 0 THEN W: = 1; Patblt (DC, R.LEFT FLAGS, R.TOP FLAGS, W, W, Blackness); Patblt (DC, R.LEFT FLAGS - (w * 2), R.Top Flags, W, W, Blackness; Patblt (DC, R.LEFT FLAGS (W * 2), R.Top Flags, W, W, Blackness); End; ExcludeClipRect (DC , R.LEFT, R.TOP, R .Right, r.bottom; end; inherited paintwindow (dc); procedure TVDBGridInplaceEdit.SetEditStyle (Value: TEditStyle); begin if Value = FEditStyle then Exit; FEditStyle: = Value; case Value of esPickList: begin if FPickList = nil then begin FPickList: = TPopupListbox.Create (Self); FPickList.Visible: = false; FPickList.Parent: = Self; FPickList.OnMouseUp: = ListMouseUp; FPickList.IntegralHeight: = True; FPickList.ItemHeight: = 11; end; FActiveList: = FPickList; end; esDataList: begin if FDataList = nil then begin FDataList: = TPopupDataList.Create (Self); FDataList.Visible: = False; FDataList.Parent: = Self; FDataList.OnMouseUp: = ListMouseUp; end; FActiveList: = FDataList; end; else {cbsNone, cbsEllipsis, or read only field} FActiveList : = nil; end; with tcustomvdbgrid (grid) do self.readonly: = columns [selectedindex] .readonly; repaint; end; procedure tvdbgridi NPLACEEDIT.STOPTRACKING; Begin if FTRACKING THEN TRACKBUTTON (-1, -1); fTRACKING: = false; mousecapture: = false; end; procedure TVDBGridInplaceEdit.TrackButton (X, Y: Integer); var NewState: Boolean; R: TRect; begin SetRect (R, ClientWidth - FButtonWidth, 0, ClientWidth, ClientHeight); NewState: = PtInRect (R, Point (X, Y) ); If fpressed <> newstate dam fpressed: = newstate; invalidateect (handle, @R, false); end; end; procedure TVDBGridInplaceEdit.UpdateContents; var Column: TColumn; NewStyle: TEditStyle; MasterField: TField; begin with TCustomVDBGrid (Grid) do Column: = Columns [SelectedIndex]; NewStyle: = esSimple; case Column.ButtonStyle of cbsEllipsis: NewStyle: = esEllipsis; cbsAuto: if Assigned (Column.Field) then with Column.Field do begin {Show the dropdown button only if the field is editable} if FieldKind = fkLookup then begin MasterField: = Dataset.FieldByName (KeyFields); {Column.DefaultReadonly will always be True for a lookup field. Test if Column.ReadOnly has been assigned a value of True} if Assigned (MasterField) and MasterField.CanModify and not ((cvReadOnly in Column.AssignedValues) and Column.ReadOnly) then with TCustomVDBGrid (Grid) Do if not readonly and datalink.active and not datalink.readonly the newstyle: = esdatalist end else if Assigned (Column.Picklist) and (Column.PickList.Count> 0) and not Column.Readonly then NewStyle: = esPickList; end; end; EditStyle: = NewStyle; inherited UpdateContents; end; procedure TVDBGridInplaceEdit.CMCancelMode (var Message: TCMCancelMode) Begin IF (Message.Sender <> Self) and (Message.Sender <> FactiveList)... Procedure TvdbGridinplaceEdit.wmcancelmode (var message: tMessage); begin stoptracking; inherited; procedure TVDBGridInplaceEdit.WMKillFocus (var Message: TMessage); begin if SysLocale.FarEast then begin ImeName: = Screen.DefaultIme; ImeMode: = imDontCare; end; inherited; CloseUp (False); end; procedure TVDBGridInplaceEdit.WMLButtonDblClk (var Message: TWMLButtonDblClk); begin with Message do if (FEditStyle <> esSimple) and PtInRect (Rect (Width - FButtonWidth, 0, Width, Height), Point (XPos, YPos)) then Exit; inherited; End; procedure tvdbGridinplaceEdit.wmpaint (var message: twmpaint); begin painthandler (message); end; procedure TVDBGridInplaceEdit.WMSetCursor (var Message: TWMSetCursor); var P: TPoint; begin GetCursorPos (P); if (FEditStyle <> esSimple) and PtInRect (Rect (Width - FButtonWidth, 0, Width, Height), ScreenToClient (P)) THEN Windows.Setcursor (LoadCursor (0, IDC_ARROW) Else Inherited; procedure TVDBGridInplaceEdit.WndProc (var Message: TMessage); begin case Message.Msg of wm_KeyDown, wm_SysKeyDown, wm_Char: if EditStyle in [esPickList, esDataList] then with TWMKey (Message) do begin DoDropDownKeys (CharCode, KeyDataToShiftState (KeyData)); if (Charcode <> 0) AND flistvisible kiln with tmessage (Message) Do SendMessage (FactiveList.Handle, MSG, WPARAM, LPARAM); EXIT; END; end; {TGRIDDATALINK} TYPE TINTARRAY = Array [0..maxmapsize] of integer; pintaRray = ^ TintArray; Constructor TgridDataLink.create (AGRID: TCUSTOMVDBGRID); begin inherited create; fgrid: = AGRID; DESTRUCTOR TGRIDDATALINK.DESTROY; "inherited destroy; function TGridDataLink.GetDefaultFields: Boolean; var I: Integer; begin Result: = True; if DataSet <> nil then Result: = DataSet.DefaultFields; if Result and SparseMap then for I: = 0 to FFieldCount-1 do if PIntArray (FFieldMap ) ^ [I] <0 THEN Begin Result: = false; exit; end; end; function TGridDataLink.getfields (i: integer): tfield; begin if (0 <= i) AND (i function TGridDataLink.AddMapping (const FieldName: string): Boolean; var Field: TField; NewSize: Integer; begin Result: = True; if FFieldCount> = MaxMapSize then RaiseGridError (STooManyColumns); if SparseMap then Field: = DataSet.FindField (FieldName Else Field: = Dataset.fieldByname (FieldName); if FFieldCount = FFieldMapSize then begin NewSize: = FFieldMapSize; if NewSize = 0 then NewSize: = 8 else Inc (NewSize, NewSize); if (NewSize Procedure TgridDataLink.ActiveChanged; Begin Fgrid.LinkActive (Active); procedure TGridDataLink.ClearMapping; begin if FFieldMap <> nil then begin FreeMem (FFieldMap, FFieldMapSize * SizeOf (Integer)); FFieldMap: = nil; FFieldMapSize: = 0; FFieldCount: = 0; end; end; procedure TGridDataLink.Modified; begin FMODIFIED: = True; Procedure tgriddataLink.datasetchanged; begin fgrid.datachanged; fmodified: = false; Procedure TGridDataLink.DataSetscrolled (Distance: Integer); Begin Fgrid.Scroll (DISTANCE); procedure TGridDataLink.LayoutChanged; var SaveState: Boolean; begin {FLayoutFromDataset determines whether default column width is forced to be at least wide enough for the column title.} SaveState: = FGrid.FLayoutFromDataset; FGrid.FLayoutFromDataset: = True; try FGrid.LayoutChanged Finally fgrid.flayoutfromDataSet: = savestate; end; inherited layoutchanged; procedure TGridDataLink.FocusControl (Field: TFieldRef); begin if Assigned (Field) and Assigned (Field ^) then begin FGrid.SelectedField: = Field ^; if (FGrid.SelectedField = Field ^) and FGrid.AcquireFocus then begin Field ^: = NIL; FGRID.SHOWEDITOR; END; Procedure tgriddataLink.editationchanged; begin fgrid.editingchanged; Procedure TgridDataLink.Recordchanged (Field: Tfield); Begin Fgrid.Recordchanged (FDIED); FMODIFIED: = FALSE; END; Proceduredata; begin finupdatedata: = true; tryding: = false; end; function TGridDataLink.GetMappedIndex (ColIndex: Integer): Integer; begin if (0 <= ColIndex) and (ColIndex {TColumnTitle} constructor TColumnTitle.Create (Column: TColumn); begin inherited Create; FColumn: = Column; FFont: = TFont.Create; FFont.Assign (DefaultFont); FFont.OnChange: = FontChanged; end; DESTRUCTOR TCOLUMNTILE.DESTROY; inherited destroy; procedure TColumnTitle.Assign (Source: TPersistent); begin if Source is TColumnTitle then begin if cvTitleAlignment in TColumnTitle (Source) .FColumn.FAssignedValues then Alignment: = TColumnTitle (Source) .Alignment; if cvTitleColor in TColumnTitle (Source) .FColumn.FAssignedValues then Color: = TColumnTitle (Source) .Color; if cvTitleCaption in TColumnTitle (Source) .FColumn.FAssignedValues then Caption: = TColumnTitle (Source) .Caption; if cvTitleFont in TColumnTitle (Source) .FColumn.FAssignedValues then Font: = TColumnTitle ( Source) .font; end else inherited assign (source); Function TColumnTitle.defaultAlignment: Talignment; Begin Result: = taleftjusti; Function TColumnTitle.defaultColor: Tcolor; var Grid: tcustom; begin grid: = fcolumn.getgrid; if assigned (grid) Then Result: = Grid.FixedColor else result: = CLBTNFACE; Function TColumn: TFont; Var Grid: TcustomvdbGrid; Begin Grid: = fcolumn.getgrid; if Assigned (Grid) Then Result: = Grid.Titlefont Else Result: = fcolumn.font; end; function TColumnTitle.DefaultCaption: string; var Field: TField; begin Field: = FColumn.Field; if Assigned (Field) then Result: = Field.DisplayName else Result: = FColumn.FieldName; end; procedure TColumnTitle.FontChanged (Sender: TObject begin include (fcolumn.fassigned); cvtitlefont); fcolumn.changed (true); Function TColumnTitle.GETAlignment; begin if cvtitlealignment in fcolumn.fassignedValues1 Result: = FALIGNMENT ELSE RESULT: = DEFAULTALIGNMENT; END; Function TColumnTitle.getColor: Tcolor; Begin if Cvtitlecolor in fcolumn.fassignedvalues the result: = fcolor else result: = defaultcolor; Function TColumnTitle.getCaption: string; begin if cvtitlecaption in fcolumn.fassignedValues the result: = fcaption else result: = defaultcaption; function TColumnTitle.GetFont: TFont; var Save: TNotifyEvent; Def: TFont; begin if not (cvTitleFont in FColumn.FAssignedValues) then begin Def: = DefaultFont; if (FFont.Handle <> Def.Handle) or (FFont.Color < > Def.color) The begin Save: = ffont.onchange; ffont.onchange: = nil; ffont.assign (default); ffont.onchange: = save; end; end; result: = ffont; end; Function TColumnTitle.IsalignmentStore: Boolean; Begin Result: = (CVTitleAlignment in fcolumn.fassignedValues) and (falignment <> defaultALIGN); END; Function TColumnTitle.iscolorstored: Boolean; Begin Result: = (Cvtitlecolor in fcolumn.fassigned) and (fcolor <> defaultcolor); Function tcolumntitle.isfontstored: boolean; begin result: = (CVTITEFONT IN FCOLUMN.FASSIGNEDVALUES); END; function TColumnTitle.IsCaptionStored: Boolean; begin Result: = (cvTitleCaption in FColumn.FAssignedValues) and (FCaption <> DefaultCaption); end; procedure TColumnTitle.RefreshDefaultFont; var Save: TNotifyEvent; begin if (cvTitleFont in FColumn.FAssignedValues) then Exit; Save: = ffont.onchange; ffont.onchange: = nil; try ffont.Assign (factory ffont.onchange: = save; end; procedure TColumnTitle.RestoreDefaults; var FontAssigned: Boolean; begin FontAssigned: = cvTitleFont in FColumn.FAssignedValues; FColumn.FAssignedValues: = FColumn.FAssignedValues - ColumnTitleValues; FCaption: = ''; RefreshDefaultFont; {If font was assigned, changing it back to default May Affect Grid Title Height, And Title Height Changes Require Layout and Redraw of the Grid.} fcolumn.changed (fontassigned); procedure TColumnTitle.SetAlignment (Value: TAlignment); begin if (cvTitleAlignment in FColumn.FAssignedValues) and (Value = FAlignment) then Exit; FAlignment: = Value; Include (FColumn.FAssignedValues, cvTitleAlignment); FColumn.Changed (False); end ; procedure TColumnTitle.SetColor (Value: TColor); begin if (cvTitleColor in FColumn.FAssignedValues) and (Value = FColor) then Exit; FColor: = Value; Include (FColumn.FAssignedValues, cvTitleColor); FColumn.Changed (False); end ; Procedure tcolumntitle.setfont (value: tfont); begin ffont.assign (value); procedure TColumnTitle.SetCaption (const Value: string); begin if (cvTitleCaption in FColumn.FAssignedValues) and (Value = FCaption) then Exit; FCaption: = Value; Include (FColumn.FAssignedValues, cvTitleCaption); FColumn.Changed (False); END; {Tcolumn} constructor TColumn.Create (Collection: TCollection); var Grid: TCustomVDBGrid; begin Grid: = nil; if Assigned (Collection) and (Collection is TDBGridColumns) then Grid: = TDBGridColumns (Collection) .Grid; if Assigned (Grid) then Grid .BeginLayout; try inherited Create (Collection); FDropDownRows: = 7; FButtonStyle: = cbsAuto; FFont: = TFont.Create; FFont.Assign (DefaultFont); FFont.OnChange: = FontChanged; FImeMode: = imDontCare; FImeName: = Screen .DefaultIme; FTitle: = CreateTitle; finally if Assigned (Grid) then Grid.EndLayout; end; end; destructor TColumn.Destroy; begin FTitle.Free; FFont.Free; FPickList.Free; inherited Destroy; end; procedure TColumn.Assign (Source: TPersistent); begin if Source is TColumn then begin if Assigned (Collection) then Collection.BeginUpdate; try RestoreDefaults; FieldName: = TColumn (Source) .FieldName; if cvColor in TColumn (Source) .AssignedValues then Color: = TColumn (Source) .Color; if cvWidth in TColumn (Source) .AssignedValues then Width: = TColumn (Source) .Width; if cvFont in TColumn (Source) .AssignedValues then Font: = TColumn (Source) .Font; if cvImeMode in TColumn (Source) .AssignedValues then ImeMode: = TColumn (Source) .ImeMode; if cvImeName in TColumn (Source) .AssignedValues then ImeName: = TColumn (Source) .ImeName; if cvAlignment in TColumn (Source) .AssignedValues then Alignment: = TColumn (Source) .Alignment; if cvReadOnly in TColumn (Source) .AssignedValues then ReadOnly: = TColumn (Source) .ReadOnly; Title: = TColumn (Source) .Title; DropDownRows: = TColumn (Source) .DropDownRows; BUT tonStyle: = TColumn (Source) .ButtonStyle; PickList: = TColumn (Source) .PickList; PopupMenu: = TColumn (Source) .PopupMenu; finally if Assigned (Collection) then Collection.EndUpdate; end; end else inherited Assign (Source) End; function tcolumn.createTitle: tcolumntitle; begin result: = tcolumntitle.create (self); Function Tcolumn.defaultAlignment: TaRignment; Begin if Assigned (Field) Then Result: = ffield.Aliety Else Result: = TALEFTJUSTIFY; END; Function tcolumn.defaultcolor: tcolor; var grid: tcustomvdbgrid; begin grid: = getGrid; if Assigned (grid) Then Result: = grid.color else result: = CLWindow; END; function TColumn.DefaultFont: TFont; var Grid: TCustomVDBGrid; begin Grid: = GetGrid; if Assigned (Grid) then Result: = Grid.Font else Result: = FFont; end; function TColumn.DefaultImeMode: TImeMode; var Grid: TCustomVDBGrid; Begin Grid: = getGrid; if Assigned (Grid) THEN Result: = Grid.imemode else result: = fimemode; Function tcolumn.defaultimename: Timename; var grid: tcustomvdbgrid; begin grid: = getGrid; if assigned (grid) Then Result: = Grid.imename else result: = fimename; function TColumn.DefaultReadOnly: Boolean; var Grid: TCustomVDBGrid; begin Grid: = GetGrid; Result: = (Assigned (Grid) and Grid.ReadOnly) or (Assigned (Field) and FField.ReadOnly); end; function TColumn.DefaultWidth: Integer; var W: Integer; RestoreCanvas: Boolean; TM: TTextMetric; begin if GetGrid = nil then begin Result: = 64; Exit; end; with GetGrid do begin if Assigned (Field) then begin RestoreCanvas: = NOT HandleAlOcated; if restorecanvas kilocas.handle: = getdc (0); try canvas.font: = Self.Font; GetTextMetrics (Canvas.HandLe, TM); Result: = Field.displayWidth * (canvas.textwidth ('0' ) - TM.TMOVERHANG) TM.TMOVERHANG 4; if DGTIS IN Options the beginning.font; w: = canvas.textwidth (title.caption) 4; if Result procedure TColumn.FontChanged; begin Include (FAssignedValues, cvFont); Title.RefreshDefaultFont; Changed (False); end; function TColumn.GetAlignment: TAlignment; begin if cvAlignment in FAssignedValues then Result: = FAlignment else Result: = DefaultAlignment; end; Function TCOLUMN.GETCOLOR: TCOLOR; Begin IF CVCOLOR IN FASSIGNEDVALUES THEN RESULT: = fcolor else result: = defaultcolor; function TColumn.GetField: TField; var Grid: TCustomVDBGrid; begin {Returns Nil if FieldName can not be found in dataset} Grid: = GetGrid; if (FField = nil) and (Length (FFieldName)> 0) and Assigned (Grid ) and assigned (grid.datalink.dataset) THEN with GRID.DATALINK.DataSet Do IF Active or (Not DefeeLTfields) The setfield (FieldName); Result: = ffield; function TColumn.GetFont: TFont; var Save: TNotifyEvent; begin if not (cvFont in FAssignedValues) and (FFont.Handle <> DefaultFont.Handle) then begin Save: = FFont.OnChange; FFont.OnChange: = nil; FFont.Assign (Default); ffont.onchange: = save; end; result: = ffont; Function TCOLUMN.GETGRID: TCUSTomvdbGrid; Begin if Assign (Collection is TdbGridColumns). Function tcolumn.getdisplayName: string; begin result: = ffieldname; if result = '' Then Result: = inherited getDisplayName; Function tcolumn.getimemode: Timemode; Begin IF CVIMEMODE IN FASSIGNEDVALUES THEN RESULT: = FimeMode else result: function TColumn.GetImeName: TImeName; begin if cvImeName in FAssignedValues then Result: = FImeName else Result: = DefaultImeName; end; function TColumn.GetPickList: TStrings; begin if FPickList = nil then FPickList: = TStringList.Create; Result: = FPickList; END; Function tcolumn.getreadonly: boolean; begin if cvreadonly in fassignedValues the result: = freadonly else result: = defaultreadOrthnly; Function TCOLUMN.GETWIDTH: INTEGER; Begin IF Cvwidth in FassignedValues Then Result: = fwidth else result: = defaultwidth; Function TColumn.isalignmentStored: Boolean; Begin Result: = (CVALIGNMENT IN FASSIGNEDVALUES) AND (FALIGNMENT <> DefaultAlign); Function TColumn.iscolorstored: Boolean; Begin Result: = (cvcolor in fassignedvalues) and (fcolor <> defaultcolor); Function tcolumn.isfontstored: boolean; begin result: = (CVFONT IN FASSIGNEDVALUES); END; Function TColumn.isimemodestored: Boolean; Begin Result: = (CVIMEMODE IN FASSIGNEDVALUES) AND (FIMEMODE <> DefaultiMode); Function tcolumn.isimenamestored: boolean; begin result: = (cvimename in fassignedValues) and (fimename <> defaultimen); Function tcolumn.isreadonlystored: Boolean; Begin Result: = (cvreadonly in fassignedvalues) and (freadonly <> defaultreadonly); Function tcolumn.iswidthstored: boolean; begin result: = (cvwidth in fassignedValues) and (fwidth <> defaultwidth); procedure TColumn.RefreshDefaultFont; var Save: TNotifyEvent; begin if cvFont in FAssignedValues then Exit; Save: = FFont.OnChange; FFont.OnChange: = nil; try FFont.Assign (DefaultFont); finally FFont.OnChange: = Save; end; end; procedure TColumn.RestoreDefaults; var FontAssigned: Boolean; begin FontAssigned: = cvFont in FAssignedValues; FTitle.RestoreDefaults; FAssignedValues: = []; RefreshDefaultFont; FPickList.Free; FPickList: = nil; ButtonStyle: = cbsAuto; Changed (FontAssigned) ; procedure TColumn.SetAlignment (Value: TAlignment); begin if (cvAlignment in FAssignedValues) and (Value = FAlignment) then Exit; FAlignment: = Value; Include (FAssignedValues, cvAlignment); Changed (False); end; Procedure tcolumn.setButtonStyle (Value: tcolumnbuttonstyle); begin if value = fbuttonStyle the exit; fbuttonStyle: = value; changed (false); Procedure tcolumn.setcolor (value: tcolor); begin if (cvcolor in fassignedvalues) and (value = fcolor) THEN EXIT; FCOLOR: = Value; Include (FASSIGNEDVALUES, CVCOLOR); Changed (false); Procedure tcolumn.setfield (value: tfield); begin if field = value; ffield: = value; if assigned (value) the ffieldname: = value.fieldName; Changed (false); procedure TColumn.SetFieldName (const Value: String); var AField: TField; Grid: TCustomVDBGrid; begin AField: = nil; Grid: = GetGrid; if Assigned (Grid) and Assigned (Grid.DataLink.DataSet) and not (csLoading in Grid.componentState) and (value)> 0) Then Afield: = Grid.datalink.DataSet.Findfield (value); {no exceptions} ffieldname: = value; setfield (false); procedure TColumn.SetFont (Value: TFont); begin FFont.Assign (Value); Include (FAssignedValues, cvFont); Changed (False); end; procedure TColumn.SetImeMode (Value: TImeMode); begin if (cvImeMode in FAssignedValues) or (Value <> default)........................................... .. procedure TColumn.SetImeName (Value: TImeName); begin if (cvImeName in FAssignedValues) or (Value <> DefaultImeName) then begin FImeName: = Value; Include (FAssignedValues, cvImeName); end; Changed (False); end; Procedure tcolumn.SetPickList (value: tstrings); begin if value = nil dam fpicklist.free; fpicklist: = nil; exit; end; picklist.assign (value); Procedure tcolumn.setpopupmenu (value: tpopupmenu); begin fpopupmenu: = value; if value <> nil kilure.freenotification (getGrid); procedure TColumn.SetReadOnly (Value: Boolean); begin if (cvReadOnly in FAssignedValues) and (Value = FReadOnly) then Exit; FReadOnly: = Value; Include (FAssignedValues, cvReadOnly); Changed (False); end; Procedure tcolumn.settitle (value: tcolumn); begin ftitle.assign (value); procedure TColumn.SetWidth (Value: Integer); begin if (cvWidth in FAssignedValues) or (Value <> DefaultWidth) then begin FWidth: = Value; Include (FAssignedValues, cvWidth); end; Changed (False); end; {TPASSTHROUGHCOLUMN} TYPE TPASSTHROUGHCOLUMNTILE = Class (TColumnTitle) Private Procedure SetCaption; Override; End; TPassthroughColumn = class (TColumn) private procedure SetAlignment (Value: TAlignment); override; procedure SetField (Value: TField); override; procedure SetIndex (Value: Integer); override; procedure SetReadOnly (Value: Boolean); override; procedure SetWidth ( Value: integer; protected function createTitle: TColumnTitle; Override; end; {tparsthroughcolumntitle} procedure TPassthroughColumnTitle.SetCaption (const Value: string); var Grid: TCustomVDBGrid; begin Grid: = FColumn.GetGrid; if Assigned (Grid) and (Grid.Datalink.Active) and Assigned (FColumn.Field) then FColumn.Field.DisplayLabel : = Value else inherited setcaption (value); {TPASSTHROUGHCOLUMN} Function TPASSTHROUGHCOLUMN.CREATTITLE: TCOLumnTitle; Begin Result: = TPASSTHROUGHCOLUMNTILE.CREATE (Self); procedure TPassthroughColumn.SetAlignment (Value: TAlignment); var Grid: TCustomVDBGrid; begin Grid: = GetGrid; if Assigned (Grid) and (Grid.Datalink.Active) and Assigned (Field) then Field.Alignment: = Value else inherited SetAlignment ( Value); Procedure tPassthroughcolumn.setfield (value: tfield); begin inherited setfield (value); if value = nil dam1 ffieldname: = '; restingefaults; procedure TPassthroughColumn.SetIndex (Value: Integer); var Grid: TCustomVDBGrid; Fld: TField; begin Grid: = GetGrid; if Assigned (Grid) and Grid.Datalink.Active then begin Fld: = Grid.Datalink.Fields [Value]; IF Assigned (FLD) THEN FIELD.INDEX: = Fld.index; end; inherited setIndex (value); procedure TPassthroughColumn.SetReadOnly (Value: Boolean); var Grid: TCustomVDBGrid; begin Grid: = GetGrid; if Assigned (Grid) and Grid.Datalink.Active and Assigned (Field) then Field.ReadOnly: = Value else inherited SetReadOnly (Value) ; end; procedure TPassthroughColumn.SetWidth (Value: Integer); var Grid: TCustomVDBGrid; TM: TTextMetric; begin Grid: = GetGrid; if Assigned (Grid) then begin if Grid.HandleAllocated and Assigned (Field) and Grid.FUpdateFields then with Grid Do Begin Canvas.Font: = Self.Font; GetTextMetrics (Canvas.Handle, TM); Field.displayWidth: = (Value (TM.TMAVECHARWIDTH DIV 2) - TM.TMOVERHANG - 3) DIV TM.TMAVECHARWIDTH; END; IF (Not Grid.FlayoutfromDataSet) or (Cvwidth In FacedValues) THENEERITED SETWIDTH (Value); Else Inherited setWidth (Value); {TDBGRIDCOLUMNS} Constructor TDBGRIDCOLUMNS.CREATE (Grid: tcustomvdbgrid; columnclass: tcolumnclass); begin inherited create (columnClass); fgrid: = grid; Function TDBGRIDCOLUMNS.ADD: TCOLUMN; Begin Result: = TCOLUMN (Inherited Add); Function TDBGRIDCOLUMNS.GETCOLUMN (Index: Integer): TColumn; Begin Result: = TCOLUMN (Inherited Items [Index]); Function TDBGRIDCOLUMNS.GETOWNER: TPERSISTENT; Begin Result: = FGRID; Function TDBGRIDCOLUMNS.GETSTATE: TDBGRIDCOLUMNSSTATE; Begin Result: = TDBGRIDCOLUMNSSTATE ((Count> 0) And not (items [0] is tpsyroughcolumn); procedure TDBGridColumns.LoadFromFile (const Filename: string); var S: TFileStream; begin S: = TFileStream.Create (Filename, fmOpenRead); try LoadFromStream (S); finally S.Free; end; end; type TColumnsWrapper = class (TComponent) private FColumns: TDBGridColumns; published property Columns: TDBGridColumns read FColumns write FColumns; end; procedure TDBGridColumns.LoadFromStream (S: TStream); var Wrapper: TColumnsWrapper; begin Wrapper: = TColumnsWrapper.Create (nil); Try wrapper.columns: = fgrid.createcolumns; sreadcomponent; assign (wrapper.column); finally wrapper.columns.free; wrapper.free; end; end; Procedure tdbgridcolumns.restoredefaults; var i: integer; begin beginupdate; try i: = 0 to count-1 do items [i] .restoreDefault; fin or end; procedure TDBGridColumns.RebuildColumns; var I: Integer; begin if Assigned (FGrid) and Assigned (FGrid.DataSource) and Assigned (FGrid.Datasource.Dataset) then begin FGrid.BeginLayout; try Clear; with FGrid.Datasource.Dataset do for I : = 0 TO FieldCount-1 Do Add.fieldName: = Fields [i] .fieldName Finally Fgrid.Endlayout; END ELSE CLIAR; END; Procedure TDBGRIDCOLUMNS.SAVETOFILE (const filename: string); var s: TSTREAM; begin s: = tfilestream.create (filename, fmcreate); tryally s.free; end; end; procedure TDBGridColumns.SaveToStream (S: TStream); var Wrapper: TColumnsWrapper; begin Wrapper: = TColumnsWrapper.Create (nil); try Wrapper.Columns: = Self; S.WriteComponent (Wrapper); finally Wrapper.Free; end; end; Procedure tdbgridcolumns.setColumn (index: integer; value: tcolumn); begin items [index] .assign (value); procedure TDBGridColumns.SetState (NewState: TDBGridColumnsState); begin if NewState = State then Exit; if NewState = csDefault then Clear else RebuildColumns; end; procedure TDBGridColumns.Update (Item: TCollectionItem); var Raw: Integer; begin if (FGrid = nil ) or (csLoading in FGrid.ComponentState) then Exit; if Item = nil then begin FGrid.LayoutChanged; end else begin Raw: = FGrid.DataToRawColumn (Item.Index); if FGrid.Vertical then begin FGrid.InvalidateRow (Raw); {Fgrid.colwidths [raw]: = tcolumn (item) .width;} end else begin fgrid.invalidatecol (raw); fgrid.colwidths [RAW]: = tcolumn (item) .width; end; end; end; {TBOOKMARKLIST} Constructor TBookmarkList.create (agrid: tcustomvdbgrid); begin inherited create; flist: = tstringlist.create; flist.onchange: = stringschanged; fgrid: = agridge; Destructor TBookmarkList.destroy; begin clear; inherited destroy; Procedure tbookmarklist.clear; begin if flist.count = 0 dam; flist.clear; fgrid.invalidate; function TBookmarkList.Compare (const Item1, Item2: TBookmarkStr): Integer; begin with FGrid.Datalink.Datasource.Dataset do Result: = CompareBookmarks (TBookmark (Item1), TBookmark (Item2)); end; Function TBOOKMARKLIST.CURRENTROW: TBOOKMARKSTR; Begin if not flinkActive dam.DataSource.DataLink.DataSource.DataSet.bookmark; end; Function TBOOKMARKLIST.GETCURRENTROWSELECTED: BOOLEAN; VAR INDEX: INTEGER; Begin Result: = Find (Currentrow, INDEX); Function TBOOKMARKLIST.FIND (Const Item: TBOOKMARKSTR; VAR INDEX: Integer): Boolean; Var L, H, I, C: Integer; Begin if (item = fcache) and (fcacheindex> = 0) THEN BEGIN INDEX: = FcacheIndex; Result: = fcachefind; EXIT; End; Result: = false; l: = 0; h: = flist.count - 1; while l <= h do begin i: = (l h) SHR 1; C: = Compare (FLIST [I], ITEM); IF C <0 THEN L: = I 1 else Begin H: = I - 1; IF C = 0 THEN Begin Result: = true; l: = i; end; end; end; = L; fcache: = item; fcacheindex: = index; fcachefind: = result; end; function tbookmarklist.getcount: integer; begin result: = flist.count; Function TBOOKMARKLIST.GETITEM (INDEX: Integer): TBOOKMARKSTR; Begin Result: = flist [index]; Function TBOOKMARKLIST.INDEXOF (Const Item: TBOOKMARKSTR): Integer; begin if not find (item, result) THEN Result: = -1; Procedure TBookmarkList.LinkActive (Value: Boolean); Begin Clear; FlinkActive: = Value; procedure TBookmarkList.Delete; var I: Integer; begin with FGrid.Datalink.Datasource.Dataset do begin DisableControls; try for I: = FList.Count-1 downto 0 do begin Bookmark: = FList [I]; Delete; FList.Delete (I); end; end; end; function TBookmarkList.Refresh: Boolean; var I: Integer; begin Result: = False; with FGrid.DataLink.Datasource.Dataset do try CheckBrowseMode; for I: = FList.Count - 1 downto 0 do if not BookmarkValid (TBookmark (FList [ I])) then begin Result: = True; FList.Delete (I); end; finally UpdateCursorPos; if Result then FGrid.Invalidate; end; end; procedure TBookmarkList.SetCurrentRowSelected (Value: Boolean); var Index: Integer; Current : TBOOKMARKSTR; Begin Current: = currentrow; if (length (current) = 0) or (Find (Current, INDEX) = value) THEN EXIT; IF Value The Flist.insert (Index, Current) Else Flist.delete (INDEX) Fgrid.invalidaterow (fgrid.row); Procedure tbookmarklist.stringschanged; begin fcache: = '; fcacheIndex: = -1; {Tcustomvdbgrid} Var drawbitmap: tbitmap; usercount: integer; Function IIF (Expr: Boolean; Casetrue, Casefalse: Variant): Variant; Begin if expr Then Result: = Case Else Result: = CASEFALSE; Procedure Usesbitmap; begin if Usercount = 0 THEN DRAWBITMAP: = Tbitmap.create; INC (userCount); Procedure ReleaseBitMap; Begin Dec (UserCount); if Usercount = 0 Then DrawbitMap.Free; Function max (x, y: integer): Integer; Begin Result: = Y; IF x> y Then Result: = x; procedure WriteText (ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const Text: string; Alignment: TAlignment); const AlignFlags: array [TAlignment] of Integer = (DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX); var B, R: TRect; I, Left: Integer; begin I: = ColorToRGB (ACanvas.Brush.Color); if GetNearestColor (ACanvas.Handle, I) = I then begin {Use ExtTextOut for solid colors} case Alignment of taLeftJustify: Left: = ARect.Left DX; taRightJustify: Left: = ARect.Right - ACanvas.TextWidth (Text) - 3; else {taCenter} Left: = aRect. LEFT (ARECT.RIGHT - ARECT.LEFT) SHR 1 - (Acanvas.TextWidth (Text) Shr 1); End; EXTTEXTOUT (Acanvas.Handle, Left, Arect.top DY, ETO_OPAQUE OR ETO_CLIPPED, @arect, Pchar ( Text), Length (Text), NIL; Else Begin {USE Fill Rect and Drawtext for dithered colors} DrawBitmap.Canvas.Lock; try with DrawBitmap, ARect do {Use offscreen bitmap to eliminate flicker and} begin {brush origin tics in painting / scrolling} Width:. = Max (Width, Right - Left) Height: = Max (Height, Bottom - TOP); R: = Rect (DX, DY, Right - Left - 1, Bottom - Top - 1); B: = Rect (0, 0, Right - Left, Bottom - TOP); end; with drawbitmap.canvas do begin font: = acanvas.font; font.color: = acanvas.font.color; brush: = acanvas.brush; brush.style: = bssolid; FillRect (b); setbkmode Handle, transparent); DrawText (Handle, Pchar (Text), Length (Text), R, AlignFlags [Alignment]); End; Acanvas.copyRect (all, drawbitmap.canvas, b); finally drawbitmap.canvas.unlock; constructor TCustomVDBGrid.Create (AOwner: TComponent); var Bmp: TBitmap; begin inherited Create (AOwner); inherited DefaultDrawing: = False; FAcquireFocus: = True; Bmp: = TBitmap.Create; try Bmp.LoadFromResourceName (HInstance, bmArrow); FIndicators: = TImageList.CreateSize (Bmp.Width, Bmp.Height); FIndicators.AddMasked (Bmp, clWhite); Bmp.LoadFromResourceName (hInstance, bmEdit); FIndicators.AddMasked (Bmp, clWhite); Bmp.LoadFromResourceName (hInstance, bmInsert ); FIndicators.AddMasked (Bmp, clWhite); Bmp.LoadFromResourceName (hInstance, bmMultiDot); FIndicators.AddMasked (Bmp, clWhite); Bmp.LoadFromResourceName (hInstance, bmMultiArrow); FIndicators.AddMasked (Bmp, clWhite); finally Bmp. Free; end; FTitleOffset: = 1; FIndicatorOffset: = 1; FUpdateFields: = True; FOptions: = [dgEditing, dgTitles, dgIndicator, dgColumnResize, dgColLines, dgRowLines, dgTabs, dgConfirmDelete, dgCancelOnExit]; DesignOptionsBoost: = [goColSizing]; VirtualView : = True; UsesBitmap; ScrollBars: = ssHorizontal; inherited Options: = [goFixedHorzLine, goFixedVertLine, goHorzLine, goVertLine, goColSizing, goColMoving, goTabs, goEditing]; FVertical: = False; FOnlyOne: = False; FTitlesWidth: = 100; FColumns: = CreateColumns; inherited RowCount: = 2; inherited ColCount: = 2; FDataLink: = TGridDataLink.Create (Self); Color: = clWindow; ParentColor: = False; FTitleFont: = TFont.Create; FTitleFont.OnChange: = TitleFontChanged; FSaveCellExtents: = False; FUSERCHANGE: = true; fdefaultdrawing: = true; fupdatingeditor: = false; fbookmarks: = TBOOKMARKLIST.CREATE (Self); hideEditor; destructor TCustomVDBGrid.Destroy; begin FColumns.Free; FColumns: = nil; FDataLink.Free; FDataLink: = nil; FIndicators.Free; FTitleFont.Free; FTitleFont: = nil; FBookmarks.Free; FBookmarks: = nil; inherited Destroy; ReleaseBitmap ; end; procedure TCustomVDBGrid.SetVertical (Value: Boolean); var i: integer; begin if Value <> FVertical then begin FVertical: = Value; if Value then {change to vertical} begin inherited Options: = inherited Options - [goColMoving] ; inherited Options: = inherited Options [goRowMoving]; ScrollBars: = ssVertical; for I: = FIndicatorOffset to ColCount-1 do ColWidths [I]: = DefaultColWidth; end else {change to horizontal} begin inherited Options: = inherited Options - [gorowmoving]; inherited options: = inherited options [gocolmoving]; scrollbars: = sshorizontal; end; layoutchanged; UpdateScrollbar; InvalidateEditor; ValidateRect (HANDL) E, NIL); invalidate; end; procedure TCustomVDBGrid.SetOnlyOne (Value: Boolean); begin if Value <> FOnlyOne then begin FOnlyOne: = Value; LayoutChanged; UpdateScrollBar; InvalidateEditor; ValidateRect (Handle, nil); Invalidate; end; end; procedure TCustomVDBGrid.SetTitlesWidth (Value: integer); begin if Value <> FTitlesWidth then begin FTitlesWidth: = Value; if FVertical and (dgTitles in Options) then ColWidths [0]: = FTitlesWidth; end; end; function TCustomVDBGrid.AcquireFocus: Boolean; begin Result: = True; if FAcquireFocus and CanFocus and not (csDesigning in ComponentState) then begin SetFocus; Result: = Focused or (InplaceEditor <> nil) and InplaceEditor.Focused; end; end; function TCustomVDBGrid . Grawtodatacolumn (Acol: Integer): Integer; Begin Result: = Acol - FindicatorOffset; Function TCUSTomvdbGrid.DataTaWCOLUMN (Acol: Integer): Integer; Begin Result: = Acol FindicatorOffset; Function tcustomvdbgrid.acquireLayoutlock: boolean; begin result: = (fuPDateLock = 0) and (FLAYOUTLOCK = 0); ifout damlayout; Procedure tcustomvdbgrid.beginLayout; begin beginupdate; if FlayoutLock = 0 THEN Column.BeginUpdate; inc (FLAYOUTLOCK); Procedure tcustomvdbgrid.beginupdate; begin inckey; end; Procedure tcustomvdbgrid.cancellayout; begin if FlayOutlock> 0 dam = 1 damns.endupdate; dec (FLAYOUTLOCK); endupdate; end; Function tcustomvdbgrid.caneditacceptkey (key: char): boolean; begin with columns [selected "; function TCustomVDBGrid.CanEditModify: Boolean; begin Result: = False; if not ReadOnly and FDatalink.Active and not FDatalink.Readonly then with Columns [SelectedIndex] do if (not ReadOnly) and Assigned (Field) and Field.CanModify and (not Field .Ssblob or assocaLink.edit; result: = fdataLink.editation; if Result dam, = fdataLink.Modified; End; End; function TCustomVDBGrid.CanEditShow: Boolean; begin Result: = (LayoutLock = 0) and inherited CanEditShow; end; procedure TCustomVDBGrid.CellClick (Column: TColumn); begin if Assigned (FOnCellClick) then FOnCellClick (Column); end; Procedure tcustomvdbgrid.colirenter; begin update; if Assigned (foncolenter) THEN FONCOLENTER (Self); Procedure tcustomvdbgrid.coleXit; begin if assigned (foncolexit) THEN FONCOLEXIT (SELF); procedure TCustomVDBGrid.ColumnMoved (FromIndex, ToIndex: Longint); begin FromIndex: = RawToDataColumn (FromIndex); ToIndex: = RawToDataColumn (ToIndex); Columns [FromIndex] .Index: = ToIndex; if Assigned (FOnColumnMoved) then FOnColumnMoved (Self, FromIndex , Toindex); procedure TCustomVDBGrid.RowMoved (FromIndex, ToIndex: Longint); begin FromIndex: = RawToDataColumn (FromIndex); ToIndex: = RawToDataColumn (ToIndex); Columns [FromIndex] .Index: = ToIndex; if Assigned (FOnColumnMoved) then FOnColumnMoved (Self, FromIndex , Toindex); procedure TCustomVDBGrid.ColWidthsChanged; var I: Integer; begin inherited ColWidthsChanged; if (FDatalink.Active or (FColumns.State = csCustomized)) and AcquireLayoutLock then try if FVertical then for I: = FIndicatorOffset to FColumns.Count - 1 do FColumns [I - FindicatorOffset] .width: = defaultColWidth Else for i: = findicatoroffset to colcount - 1 do fcolumns [i - findicatoroffset] .width: = COLWIDTHS [I]; finally endlayout; end; end; Function TCUSTOMVDBGRID.CREATECOLUMVDBGRID.CREATECOLUMNS: TDBGRIDCOLUMNS; Begin Result: = TDBGRIDCOLUMNS.CREATE (Self, Tcolumn); Function TCUSTOMVDBGRID.CREATEEDITOR: TINPLACEEDIT; begin Result: = tvdbGridinplaceEDit.create (self); procedure TCustomVDBGrid.CreateWnd; begin BeginUpdate; {prevent updates in WMSize message that follows WMCreate} try inherited CreateWnd; finally EndUpdate; end; UpdateRowCount; UpdateActive; UpdateScrollBar; FOriginalImeName: = ImeName; FOriginalImeMode: = ImeMode; end; procedure TCustomVDBGrid.DataChanged; Begin if not handleallocated kilod; updatective; invalidateEditor; validateelectric (handle, nil); procedure TCustomVDBGrid.DefaultHandler (var Msg); var P: TPopupMenu; Cell: TGridCoord; begin inherited DefaultHandler (Msg); if TMessage (Msg) .Msg = wm_RButtonUp then with TWMRButtonUp (Msg) do begin Cell: = MouseCoord (XPos, YPos ); If Fvertical Then Begin IF (Cell.x procedure TCustomVDBGrid.DeferLayout; var M: TMsg; begin if HandleAllocated and not PeekMessage (M, Handle, cm_DeferLayout, cm_DeferLayout, pm_NoRemove) then PostMessage (Handle, cm_DeferLayout, 0, 0); CancelLayout; end; procedure TCustomVDBGrid.DefineFieldMap; var I: Integer; begin if FColumns.State = csCustomized then begin {Build the column / field map from the column attributes} DataLink.SparseMap: = True; for I: = 0 to FColumns.Count-1 do FDataLink.AddMapping (FColumns [I] .FieldName); end else {Build the column / field map from the field list order} begin FDataLink.SparseMap: = False; with Datalink.Dataset do for I: = 0 to FieldCount - 1 do with Fields [I] do if Visible then Datalink.AddMapping (FieldName); end; end; procedure TCustomVDBGrid.DefaultDrawDataCell (const Rect: TRect; Field: TField; State: TGridDrawState); var Alignment: TAlignment; Value: string; begin Alignment : = TALEFTJUSTIFY; Value: = '; if Assigned (Field) THEN BEGIN Alignment: = Field.Alignment; Value: = Field.displaytext; End; WriteText (Canvas, Rect, 2, 2, Value, Alignment); END; procedure TCustomVDBGrid.DefaultDrawColumnCell (const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); var Value: string; begin Value: = ''; if Assigned (Column.Field) then Value: = Column.Field. Displaytext; Writetext (Canvas, Rect, 2, 2, Value, Column.Alignment); Procedure tcustomvdbgrid.readcolumns (reader: Treader); recomcuMns.clear; Reader.ReadValue; Reader.ReadCollection (Column); Procedure tcustomvdbgrid.writecolumns (Writer: twriter); begin Writer.writecollection (Column); procedure TCustomVDBGrid.DefineProperties (Filer: TFiler); begin Filer.DefineProperty ( 'Columns', ReadColumns, WriteColumns, ((Columns.State = csCustomized) and (Filer.Ancestor = nil)) or ((Filer.Ancestor <> nil) and ((Columns.State <> TCustomVDBGrid (Filer.Ancestor) .Columns.State) or (not CollectionsEqual (Columns, TCustomVDBGrid (Filer.Ancestor) .Columns, nil, nil))))); end; procedure TCustomVDBGrid.DrawCell (ACOL, AROW: longint; all; Function RowismUltiSelected: boolean; var index: integer; begin result: = (DGMULTITISELECT IN OPTION) AND DATALINK.Active and fbookmarks.Find (DataLink.DataSource.DataSet.bookmark, index); var OldActive: Integer; Indicator: Integer; Highlight: Boolean; Value: string; DrawColumn: TColumn; FrameOffs: Byte; MultiSelected: Boolean; AACol, AARow: Longint; begin if csLoading in ComponentState then begin Canvas.Brush.Color: = Color Canvas.FillRect (all;); AROW: = IIF (Fvertical, ACOL, AROW); AACOL: = IIF (Fvertical, Arow, Acol); DEC (AROW, FTITLEOFFSET); DEC (AACOL, FindicatorOffset); IF (gdfixed in astate) and ([DGROWLINES, DGCOLLINES] * Options = [DGROWLINES, DGCOLLINES]) THEN BEGINES: = 1; FrameOffs: = 1; Else FrameOffs: = 2; if (gdFixed in AState) and (AACol <0) then begin Canvas.Brush.Color: = FixedColor; Canvas.FillRect (ARect); if Assigned (DataLink) and DataLink.Active then begin MultiSelected: = False; if AARow> = 0 then begin OldActive: = FDataLink.ActiveRecord; try FDatalink.ActiveRecord: = AARow; MultiSelected: = RowIsMultiselected; finally FDatalink.ActiveRecord: = OldActive; end; end; if (AARow = FDataLink.ActiveRecord) or MultiSelected then begin Indicator: = 0; if fdataLink.dataset <> nil dam, fdatalicit: indeicator: = 1; dsinsert: indeicator: = 2; dsbrowse: if MultiSelected Then IF (AROW <> fdataLink.activeRecord) THEN INDICATOR: = 3 Else Indicator: = 4; // MultiSelected and current row end; findicators.bkcolor: = fixedcol or; if FVertical then FIndicators.Draw (Canvas, ARect.Left FrameOffs, (ARect.Top ARect.Bottom - FIndicators.Height) shr 1, Indicator) else FIndicators.Draw (Canvas, ARect.Right - FIndicators.Width - FrameOffs, (ARect.Top ARect.Bottom - FIndicators.Height) shr 1, Indicator); if AARow = FDatalink.ActiveRecord then FSelRow: = AARow FTitleOffset; end; end; end else with Canvas do begin DrawColumn: = Columns [ Aacol]; if gdfixed in astate the beginning: = drawcolumn.title.font; brush.color: = DrawColumn.title.color; end else begin Font: = DrawColumn.Font; Brush.Color: = DrawColumn.Color; end; if AARow <0 then with DrawColumn.Title do WriteText (Canvas, ARect, FrameOffs, FrameOffs, Caption, Alignment) else if (FDataLink = nil) or not FDataLink.Active then FillRect (aRect) else begin Value: = ''; OldActive: = FDataLink.ActiveRecord; try FDataLink.ActiveRecord: = AARow; if Assigned (DrawColumn.Field) then Value: = DrawColumn.Field. DisplayText; Highlight: = HighlightCell (AACol, AARow, Value, aState); if Highlight then begin Brush.Color: = clHighlight; Font.Color: = clHighlightText; end; if FDefaultDrawing then WriteText (Canvas, aRect, 2, 2, Value , DrawColumn.Alignment); if Columns.State = csDefault then DrawDataCell (aRect, DrawColumn.Field, aState); DrawColumnCell (aRect, AACol, DrawColumn, aState); finally FDataLink.ActiveReco rd: = OldActive; end; if FDefaultDrawing and (gdSelected in AState) and ((dgAlwaysShowSelection in Options) or Focused) and not (csDesigning in ComponentState) and not (dgRowSelect in Options) and (UpdateLock = 0) and (ValidParentForm (Self ) .ActiveControl = Self) then Windows.DrawFocusRect (Handle, aRect); end; end; if (gdFixed in aState) and ([dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines]) then begin InflateRect (aRect, 1, 1); DrawEdge (canvas.handle, all, bf_bottomright); DrawEdge (canvas.handle, all, bf_topleft); end; procedure TCustomVDBGrid.DrawDataCell (const Rect: TRect; Field: TField; State: TGridDrawState); begin if Assigned (FOnDrawDataCell) then FOnDrawDataCell (Self, Rect, Field, State); end; procedure TCustomVDBGrid.DrawColumnCell (const Rect: TRect; DataCol : Integer; Column: Tcolumn; State: TgriddrawState; Begin IF Assign (OnDrawColumn). OndrawColumnCell (Self, Rect, Datacol, Column, State); Procedure tcustom; begin if assigned (foney).. Procedure tcustomvdbgrid.editingchanged; begin if DGindicator in Options Ten if Fvertical Ten invalidatecell (fselrow, 0) Else Invalidatecell (0, FSELROW); procedure TCustomVDBGrid.EndLayout; begin if FLayoutLock> 0 then begin try try if FLayoutLock = 1 then InternalLayout; finally if FLayoutLock = 1 then FColumns.EndUpdate; end; finally Dec (FLayoutLock); EndUpdate; end; end; end; Procedure tcustomvdbgrid.endupdate; begin if fupdatelock> 0 Then Decock; function TCustomVDBGrid.GetColField (DataCol: Integer): TField; begin Result: = nil; if (DataCol> = 0) and FDatalink.Active and (DataCol Function TCUSTomvdbgrid.getdataSource: TDataSource; Begin Result: = fdataLink.dataSource; Function TCustomvdbgrid.Geteditlimit: Integer; Begin Result: = 0; if Assigned (SELECTEDFIELD) AND (SELECTEDFIELD) AND (SELECTEDFIELD) AND (SELECTEDFIELD) AND (SELECTEDFIELD.DATATYPE = ftstring). function TCustomVDBGrid.GetEditMask (ACol, ARow: Longint): string; begin Result: = ''; if FDatalink.Active then with Columns [RawToDataColumn (IIF (FVertical, ARow, ACol))] do if Assigned (Field) then Result: = Field.EditMask; end; function TCustomVDBGrid.GetEditText (ACol, aRow: Longint): string; begin Result: = ''; if FDatalink.Active then with Columns [RawToDataColumn (IIF (FVertical, aRow, ACol))] do if Assigned (Field) Then Result: = Field.Text; feditText: = Result; Function tcustomvdbgrid.getfieldcount: integer; begin result: = fdataLink.fieldcount; Function TCUSTomvdbGrid.getfields (FieldIndex: Integer): Tfield; Begin Result: = fdataLink.fields [FieldIndex]; Function TCUSTomvdbGrid.getFieldValue (acol: integer): string; var field: tfield; begin result: = '; Field: = getColfield (acol); iffield <> nil dam = field.displaytext; Function tcustomvdbgrid.getSelectedfield: tfield; var index: integer; begin index: = selectedindex; if index <> -1 the result: = columns [index] .field else result: = nil; end; Function TCUSTomvdbgrid.getSelected Indidex: Integer; Begin Result: = RawTodatacolumn (IIF (Fvertical, Row, Col)); function TCustomVDBGrid.HighlightCell (DataCol, DataRow: Integer; const Value: string; AState: TGridDrawState): Boolean; var Index: Integer; begin Result: = False; if (dgMultiSelect in Options) and Datalink.Active then Result: = FBookmarks. Find (Datalink.Datasource.Dataset.Bookmark, Index); if not Result then Result: = (gdSelected in aState) and ((dgAlwaysShowSelection in Options) or Focused) {updatelock eliminates flicker when tabbing between rows} and ((updateLock = 0 ) or (DGROWSELECT IN OPTIONS)); end; procedure tcustomvdbgrid.keydown (var key: word; shift: tshiftstate); var keydownevent: tKeyEvent; Procedure Clearselection; Begin IF (DGMultiselect In Options) The begin fbookmarks.clear; fselecting: = false; end; procedure DoSelection (Select: Boolean; Direction: Integer); var AddAfter: Boolean; begin AddAfter: = False; BeginUpdate; try if (dgMultiSelect in Options) and FDatalink.Active then if Select and (ssShift in Shift) then begin if not FSelecting then begin FSelectionAnchor: = FBookmarks.CurrentRow; FBookmarks.CurrentRowSelected: = True; FSelecting: = True; AddAfter: = True; end else with FBookmarks do begin AddAfter: = Compare (CurrentRow, FSelectionAnchor) <> -Direction; if not AddAfter then Currentrowselected: = false; end end else clearslection; fdataLink.dataset.moveby; if additional the fbookmarks.currentrowselected: = true; fin or endupdate; procedure NextRow (Select: Boolean); begin with FDatalink.Dataset do begin if (State = dsInsert) and not Modified and not FDatalink.FModified then if EOF then Exit else Cancel else DoSelection (Select, 1); if EOF and CanModify and ( not ReadOnly) and (dgEditing in Options) then Append; end; end; procedure PriorRow (Select: Boolean); begin with FDatalink.Dataset do if (State = dsInsert) and not Modified and EOF and not FDatalink.FModified then Cancel else DoSelection (SELECT, -1); END; procedure Tab (GoForward: Boolean); var ACol, Original: Integer; begin ACol: = IIF (FVertical, Row, Col); Original: = ACol; BeginUpdate; {Prevent highlight flicker on tab to next / prior row} try while True do begin if GoForward then Inc (ACol) else Dec (ACol); if ACol> = IIF (FVertical, RowCount, ColCount) then begin NextRow (False); ACol: = FIndicatorOffset; end else if ACol function DeletePrompt: Boolean; var Msg: string; begin if (FBookmarks.Count> 1) then Msg: = SDeleteMultipleRecordsQuestion else Msg: = SDeleteRecordQuestion; Result: = not (dgConfirmDelete in Options) or (MessageDlg (Msg, mtConfirmation, mbOKCancel, 0 <> idcancel); end; const rowmovementKeys = [VK_UP, VK_PRIOR, VK_DOWN, VK_NEXT, VK_HOME, VK_END]; begin KeyDownEvent: = OnKeyDown; if Assigned (KeyDownEvent) then KeyDownEvent (Self, Key, Shift); if not FDatalink.Active or not CanGridAcceptKey (Key, Shift) then Exit; with FDatalink.DataSet do if FVertical then if ssCtrl in Shift then begin if (Key in RowMovementKeys) then ClearSelection; case Key of VK_LEFT, VK_PRIOR: MoveBy (-FDatalink.ActiveRecord); VK_RIGHT, VK_NEXT: MoveBy (FDatalink.BufferCount - FDatalink.ActiveRecord - 1); VK_UP: MoveCol (FIndicatorOffset); VK_DOWN : MoveCol (RowCount - 1); VK_HOME: First; VK_END: Last; VK_DELETE: if (not ReadOnly) and not IsEmpty and CanModify and DeletePrompt then if FBookmarks.Count> 0 then FBookmarks.Delete else Delete; end end else case Key of VK_LEFT: PRIORROW (TRUE); vk_right: next (true); VK_UP: IF DGROWSELECT IN OPTIONS THEN PRIORROW (FALSE) ELSE MoveCol (Row - 1); VK_DOWN: if dgRowSelect in Options then NextRow (False) else MoveCol (Row 1); VK_HOME: if (RowCount = FIndicatorOffset 1) or (dgRowSelect in Options) then begin ClearSelection; First; end else MoveCol (FIndicatorOffset); VK_END: if (RowCount = FIndicatorOffset 1) or (dgRowSelect in Options) then begin ClearSelection; Last; end else MoveCol (RowCount - 1); VK_NEXT: begin ClearSelection; MoveBy (VisibleColCount); end; VK_PRIOR: begin ClearSelection; MoveBy (-VisibleColCount); end; VK_INSERT: if CanModify and (not ReadOnly) and (dgEditing in Options) then begin ClearSelection; Insert; end; VK_TAB: if not (ssAlt in Shift) then Tab (not ( ssShift in Shift)); VK_ESCAPE: begin FDatalink.Reset; ClearSelection; if not (dgAlwaysShowEditor in Options) then HideEditor; end; VK_F2: EditorMode: = True; end else if ssCtrl in Shift then begin if (Key in RowMovementKeys) then ClearSelection ; case Key of VK_UP, VK_PRIOR: MoveBy (-FDatalink.ActiveRecord); VK_DOWN, VK_NEXT: MoveBy (FDatalink.BufferCount - FDatalink.ActiveRecord - 1); VK_LEFT: MoveCol (FIndicatorOffset); VK_RIGHT: MoveCol (ColCount - 1); VK_HOME : First; vk_end: last; vk_delete: if (not readonly) and not tempty and CanModify and DeletePrompt then if FBookmarks.Count> 0 then FBookmarks.Delete else Delete; end end else case Key of VK_UP: PriorRow (True); VK_DOWN: NextRow (True); VK_LEFT: if dgRowSelect in Options then PriorRow (False) else MoveCol (Col - 1); VK_RIGHT: if dgRowSelect in Options then NextRow (False) else MoveCol (Col 1); VK_HOME: if (ColCount = FIndicatorOffset 1) or (dgRowSelect in Options) then begin ClearSelection; First; end else Movecol (FindicatorOffset); VK_END: if (ColCount = FIndicatorOffset 1) or (dgRowSelect in Options) then begin ClearSelection; Last; end else MoveCol (ColCount - 1); VK_NEXT: begin ClearSelection; MoveBy (VisibleRowCount); end; VK_PRIOR: begin ClearSelection; MoveBy ( -VisibleRowCount); end; VK_INSERT: if CanModify and (not ReadOnly) and (dgEditing in Options) then begin ClearSelection; Insert; end; VK_TAB: if not (ssAlt in Shift) then Tab (not (ssShift in Shift)); VK_ESCAPE : begin FDatalink.Reset; ClearSelection; if not (dgAlwaysShowEditor in Options) then HideEditor; end; VK_F2: EditorMode: = True; end; end; procedure TCustomVDBGrid.KeyPress (var Key: Char); begin if not (dgAlwaysShowEditor in Options) AND (key = # 13) Then fdataLink.updatedata; inherited keypress (key); {InternalLayout is called with layout locks and column locks in effect} procedure TCustomVDBGrid.InternalLayout; var I, J, K: Integer; Fld: TField; Column: TColumn; SeenPassthrough: Boolean; RestoreCanvas: Boolean; Function Fieldismapped (f: tfield): Boolean; var x: integer; begin result: = false; if f = nil dam, for x: = 0 to fdataLink.fieldcount-1 do if fdataLink.fields [x] = f Then . Begin if (cslineing in componentstate). If HandleAllocated Ten KillMessage (Handle, Cm_deferLayout); {Check for Columns.State flip-flop} SeenPassthrough: = False; for I: = 0 to FColumns.Count-1 do begin if (FColumns [I] is TPassthroughColumn) then SeenPassthrough: = True else if SeenPassthrough then begin {We have both custom and passthrough columns Kill the latter} for J: = FColumns.Count-1 downto 0 do begin Column: = FColumns [J]; if Column is TPassthroughColumn then Column.Free; end; Break; end; end;. FIndicatorOffset: = 0; if dgIndicator in Options then Inc (FIndicatorOffset); FDatalink.ClearMapping; if FDatalink.Active then DefineFieldMap; if FColumns.State = csDefault then begin {Destroy columns whose fields have been destroyed or are no longer in field map} if (not FDataLink.Active) and (FDatalink.DefaultFields) then FColumns.Clear else for J: = FColumns.Count-1 downto 0 do with FColumns [J] do if not Assigned (Field) or not FieldIsMapped (Field) then Free I: = fdataLink.fieldcount; if (i = 0) and (fcolumns.count = 0) THEN INC (i); for j: = 0 to i-1 do beg: = fdataLink.fields [j]; if Assigned (Fld) then begin K: = J; {Pointer compare is valid here because the grid sets matching column.field properties to nil in response to field object free notifications Closing a dataset that has only default field objects will destroy all the fields. And SET ASSO Ciated column.field props to nil.} WHILE (K inherited FixedRows: = FIndicatorOffset; end else begin ColCount: = FColumns.Count FIndicatorOffset; inherited FixedCols: = FIndicatorOffset; end; FTitleOffset: = 0; if dgTitles in Options then FTitleOffset: = 1; RestoreCanvas: = not HandleAllocated; if RestoreCanvas then Canvas.Handle: = getdc (0); try canvas.font: = font; k: = canvas.textheight ('wg') 3; if Dgrowlines in Options Ten Inc (K, GridLineWidth); defaultRowHeight: = K; if DGTI = 0; for i: = 0 to fcolumns.count-1 do begin canvas.font: = fcolumns [i] .title.font; j: = canvas.textheight ('wg') 4 ; If j> k THEN K: = J; END; if k = 0 THEN becom canvas.font: = ftitlefont; k: = canvas.textheight ('wg') 4; end; if Fvertical and (k> defaultRowheight) Then Defaultrowheight: = k else rowheights [0]: = k; end; finally if restorecanvas the begin ReleaseDC (0, Canvas.Handle); Canvas.Handle: = 0; end; end; UpdateRowCount; SetColumnAttributes; UpdateActive; Invalidate; end; procedure TCustomVDBGrid.LayoutChanged; begin if FColumns.Count> 0 then if FVertical then RowCount: = Fcolumns.count FindicatorOffset Else Colcount: = fcolumns.count FindicatorOffset; if acquirelayoutlock dam. procedure TCustomVDBGrid.LinkActive (Value: Boolean); begin if not Value then HideEditor; FBookmarks.LinkActive (Value); LayoutChanged; UpdateScrollBar; if Value and (dgAlwaysShowEditor in Options) then ShowEditor; end; procedure TCustomVDBGrid.Loaded; begin inherited Loaded; LayoutChanged; procedure TCustomVDBGrid.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Cell: TGridCoord; OldCol, OldRow: Integer; begin if not AcquireFocus then Exit; if (ssDouble in Shift) and (Button = mbLeft) INT; if Sizing (x, y) Then Begin fdataLink.Updatedata; inherited mousedown (Button, Shift, x, y) end else beg: = mousecoord (x, y); if ((csdesigning in) ComponentState) or (dgColumnResize in Options)) and (IIF (FVertical, Cell.X, Cell.Y) OldRow)) or (dgAlwaysShowEditor in Options)) then ShowEditor {put grid in edit mode} else InvalidateEditor; {draw editor, if needed} finally EndUpdate; end; end; end; end; procedure TCustomVDBGrid.MouseUp (Button: TMouseButton; Shift : TShiftState; X, Y: Integer); var Cell: TGridCoord; SaveState: TGridState; begin SaveState: = FGridState; inherited MouseUp (Button, Shift, X, Y); if (SaveState = gsRowSizing) or (SaveState = gsColSizing) or (InplaceEditor <> NIL) and (PtinRect (PtinRect (InplaceEditor.BoundSRect, Point (x, y)))). (IIF (Fvertical, Cell.y, Cell.x)> = Findicatoroffset) and (IIF (Fvertical, Cell.x, Cell.y)> = 0) Then Iif (Fvertical, Cell.x, Cell.y) < FtitleOffset The title CLICK (Columns [Rawtodatacolumn (IIF (Fvertical, Cell.y, Cell.x)]) Else CellClick (Column Cellclick (Columns [SELECTEDEX]); procedure TCustomVDBGrid.MoveCol (RawCol: Integer); var OldCol: Integer; begin FDatalink.UpdateData; if RawCol> = IIF (FVertical, RowCount, ColCount) then RawCol: = IIF (FVertical, RowCount, ColCount) - 1; if RawCol < FIndicatorOffset then RawCol: = FIndicatorOffset; OldCol: = IIF (FVertical, Row, Col); if RawCol <> OldCol then begin if not FInColExit then begin FInColExit: = True; try ColExit; finally FInColExit: = False; end; if IIF ( Fvertical, row, col) <> iv. iver (DGALWAYSSHOWEDITOR IN OPTION) THEN HideEditor; if fvertical dam: = rawcol else col: = rawcol; procedure TCustomVDBGrid.Notification (AComponent: TComponent; Operation: TOperation); var I: Integer; NeedLayout: Boolean; begin inherited Notification (AComponent, Operation); if (Operation = opRemove) then begin if (AComponent is TPopupMenu) then begin for I : = 0 to columns.count-1 DO if column [i] .popupmenu = Acomponent the column = .popupmenu: = nil; Else IF (fdataLink <> nil) Then if (Acomponent = Datasource) Then DataSource: = NIL ELSE IF (Acomponent Is Tfield) THEN Begin NeedLayout: = false; beginlayout; try for i: = 0 to columns.count-1 do with columns [i] do iffield = Acomponent The begin Field: = nil; needustom: = True; end; finally if Needlayout and assigned (fdataLink.dataset) and not fdataLink.DataSet.Controlsdisabled the endlayout else Defer Layout; end; end; end; end; procedure TCustomVDBGrid.RecordChanged (Field: TField); var I: Integer; CField: TField; begin if not HandleAllocated then Exit; if Field = nil then Invalidate else begin for I: = 0 to Columns.Count - 1 do if Columns [I] .Field = Field then if FVertical then InvalidateRow (DataToRawColumn (I)) else InvalidateCol (DataToRawColumn (I)); end; CField: = selectedField; if ((Field = nil) or (Cfield = field)) and (cfield.text <> feditText)................................ procedure TCustomVDBGrid.Scroll (Distance: Integer); var OldRect, NewRect: TRect; RowHeight: Integer; begin if not HandleAllocated then Exit; if FVertical then OldRect: = BoxRect (Col, 0, Col, RowCount - 1) else OldRect: = BoxRect (0, Row, ColCount - 1, Row); if (FDataLink.ActiveRecord> = IIF (FVertical, ColCount, RowCount) - FTitleOffset) then UpdateRowCount; UpdateScrollBar; UpdateActive; if FVertical then NewRect: = BoxRect (Col, 0, COL, ROWCOUNT - 1) Else NewRect: = BoxRect (0, Row, Colcount - 1, ROW); ValidateRect (Handle, @oldRect); InvalIdateRect (Handle, @oldRect, False); InvaliDateRect (Handle, @newRect, false) ; if Distance <> 0 then begin HideEditor; try Invalidate; Exit; {FOLLOWING CODE CAUSED CONFUSION SO ALWAYS INVALIDATE} if Abs (Distance)> IIF (FVertical, VisibleColCount, visibleRowCount) then begin Invalidate; Exit; end else begin RowHeight: = Defaultrowheight; if dgRowLines in Options then Inc (RowHeight, GridLineWidth); if dgIndicator in Options then begin if FVertical then OldRect: = BoxRect (FSelRow, 0, FSelRow, RowCount - 1) else OldRect: = BoxRect (0, FSelRow, ColCount - 1, FSELROW); InvaliDateRect (Handle, @oldRect, false); End; if Fvertical Then newRect: = BoxRect (ftitleoffset, 0, 1000, rowcount - 1) else newRect: = BoxRect (0, FtitleOffset, Colcount - 1, 1000); If Fvertical Then ScrollWindowEx (Handle, -defaultColwidth * distance, 0, @newRect, @ NewRect, {VERT ???} 0, nil, SW_Invalidate) else ScrollWindowEx (Handle, 0, -RowHeight * Distance, @NewRect, @NewRect, 0, nil, SW_Invalidate); if dgIndicator in Options then begin if FVertical then NewRect: = BoxRect (Col, 0, Col, Rowcount - 1) Else NewRect: = BoxRect (0, Row, Colcount - 1, Row); InvaliDateRect (Handle, @newRect, False); end; end; finally if dgalwaysshoweditor in Options Then SHOWEDITOR; END; if UpdateLock = 0 THEN UPDATE; END; Procedure TcustomvdbGrid.SetColumns (Value: TDBGRIDCOLUMNS); Begin Column.Assign (Value); function ReadOnlyField (Field: TField): Boolean; var MasterField: TField; begin Result: = Field.ReadOnly; if not Result and (Field.FieldKind = fkLookup) then begin Result: = True; if Field.DataSet = nil then Exit; Masterfield: = field.DataSet.Findfield (Field.Keyfields); if masterfield = nil dam; result: = Masterfield.ReadOnly; End; procedure TCustomVDBGrid.SetColumnAttributes; var I: Integer; begin if not FVertical then for I: = 0 to FColumns.Count-1 do with FColumns [I] do begin TabStops [I FIndicatorOffset]: = not ReadOnly and DataLink.Active and Assigned (Field) and not (Field.FieldKind = fkCalculated) and not ReadOnlyField (Field); ColWidths [I FIndicatorOffset]: = Width; end; if (dgIndicator in Options) then ColWidths [0]: = IIF (FVertical, TitlesWidth, IndicatorWidth; END; function TCustomVDBGrid.TabStopRow (Arow: integer): Boolean; var DataCol: integer; begin Result: = False; DataCol: = RawToDataColumn (ARow); if (DataCol> = 0) and (DataCol Procedure tcustomvdbgrid.setedittext (acol, impongint; const value: string); begin feditText: = value; procedure TCustomVDBGrid.SetOptions (Value: TDBGridOptions); const LayoutOptions = [dgEditing, dgAlwaysShowEditor, dgTitles, dgIndicator, dgColLines, dgRowLines, dgRowSelect, dgAlwaysShowSelection]; var NewGridOptions: TGridOptions; ChangedOptions: TDBGridOptions; begin if FOptions <> Value then begin NewGridOptions: = []; if dgColLines in Value then NewGridOptions: = NewGridOptions [goFixedVertLine, goVertLine]; if dgRowLines in Value then NewGridOptions: = NewGridOptions [goFixedHorzLine, goHorzLine]; if dgColumnResize in Value then if FVertical then NewGridOptions: = NewGridOptions [ goColSizing, goRowMoving] else NewGridOptions: = NewGridOptions [goColSizing, goColMoving]; if dgTabs in Value then Include (NewGridOptions, goTabs); if dgRowSelect in Value then begin Include (NewGridOptions, goRowSelect); Exclude (Value, dgAlwaysShowEditor); Exclude ( Value, DGEDITING; End; if DGEDITIN VALUE TH en Include (NewGridOptions, goEditing); if dgAlwaysShowEditor in Value then Include (NewGridOptions, goAlwaysShowEditor); inherited Options: = NewGridOptions; if dgMultiSelect in (FOptions - Value) then FBookmarks.Clear; ChangedOptions: = (FOptions Value) - (FOptions * Value); FOptions: = Value; if ChangedOptions * LayoutOptions <> [] then LayoutChanged; end; end; procedure TCustomVDBGrid.SetSelectedField (Value: TField); var I: Integer; begin if Value = nil then Exit; for I: = 0 to columns.count - 1 do if columns [i] .field = value the movecol (DataLuMolumn (i)); procedure TCustomVDBGrid.SetSelectedIndex (Value: Integer); begin MoveCol (DataToRawColumn (Value)); end; procedure TCustomVDBGrid.SetTitleFont (Value: TFont); begin FTitleFont.Assign (Value); if dgTitles in Options then LayoutChanged; end; Function TCUSTOMVDBGRID.StoreColumns: Boolean; Begin Result: = Column.State = CSCUSTOMIZED; procedure TCustomVDBGrid.TimedScroll (Direction: TGridScrollDirection); begin if FDatalink.Active then begin with FDatalink do begin if sdUp in Direction then begin DataSet.MoveBy (-ActiveRecord - 1); Exclude (Direction, sdUp); end; if sdDown in Direction THEN BEGIN DATASET.MOVEBY (RECORDCOUNT - ActiveRecord); Exclude (Direction, SDDown); End; End; if Direction <> [] THEN INHERITED TIMEDSCROLL (DIND); Procedure tcustomvdbgrid.titleclick (Column: tcolumn); Begin if Assign (FontitleClick) THEN FONTICLICK (Column); procedure TCustomVDBGrid.TitleFontChanged (Sender: TObject); begin if (not FSelfChangingTitleFont) and not (csLoading in ComponentState) then ParentFont: = False; if dgTitles in Options then LayoutChanged; end; procedure TCustomVDBGrid.UpdateActive; var NewRow: Integer; Field: TField; begin if FDatalink.Active and HandleAllocated and not (csLoading in ComponentState) then begin NewRow: = FDatalink.ActiveRecord FTitleOffset; if IIF (FVertical, Col, Row) <> NewRow then begin if not (dgAlwaysShowEditor in Options) then HideEditor; if FVertical then MoveColRow (NewRow, Row, False, False) else MoveColRow (Col, NewRow, False, False); InvalidateEditor; end; Field: = selectedField; if Assigned ( Field) and (Field.Text <> FEditText) then InvalidateEditor; end; end; procedure TCustomVDBGrid.UpdateData; var Field: TField; begin Field: = selectedField; if Assigned (Field) then Field.Text: = FEditText; end; procedure TCustomVDBGrid.UpdateRowCount; begin if FVertical then begin if ColCount <= FTitleOffset then ColCount: = FTitleOffset 1; end else if RowCount <= FTitleOffset then RowCount: = FTitleOffset 1; if FVertical then FixedCols: = FTitleOffset else FixedRows: = FTitleOffset ; with FDataLink do if not Active or (RecordCount = 0) or not HandleAllocated then if FVertical then ColCount: = 1 FTitleOffset else RowCount: = 1 FTitleOffset else begin if FVertical then ColCount: = IIF (FOnlyOne, 1 FTitleOffset, 1000 ) else RowCount: = IIF (FOnlyOne, 1 FTitleOffset, 1000); FDataLink.BufferCount: = IIF (FVertical, VisibleColCount, visibleRowCount); if FVertical then ColCount: = IIF (FOnlyOne, 1 FTitleOffset, RecordCount FTitleOffset) else RowCount : = IIF (Fonlyone, 1 FTILEOFFSET, RecordCount ftitleoffset); if DGROWSELECT IN OPTIONS THEN TOPROW: = Fi Xedrows; UpdateActive; End; procedure TCustomVDBGrid.UpdateScrollBar; var SIOld, SINew: TScrollInfo; begin if FDatalink.Active and HandleAllocated then with FDatalink.DataSet do begin SIOld.cbSize: = sizeof (SIOld); SIOld.fMask: = SIF_ALL; if FVertical then GetScrollInfo (Self. Handle, SB_HORZ, SIOld) else GetScrollInfo (Self.Handle, SB_VERT, SIOld); SINew: = SIOld; if IsSequenced then begin SINew.nMin: = 1; SINew.nPage: = IIF (FVertical, Self.VisibleColCount, Self.VisibleRowCount SINEW.NMAX: = RecordCount Sinew.Npage -1; if State In [DSINACTIVE, DSBROWSE, DSEDIT] THEN SINEW.NPOS: = Recno; // Else Keep Old Pos Else Begin SINEW.NMIN: = 0; SINEW .npage: = 0; sinew.nmax: = 4; if bof then sinew.npos: = 0 else if EOF twsew.npos: = 4 else sinew.npos: = 2; end; if (SINEW.NMIN <> SiOLD .nmin) or (SINEW.NMAX <> SiOLD.NMAX) OR (SINEW.NPAGE <> Siol D.NPAGE) or (SINEW.NPOS <> SiOLD.NPOS) THEN IF FVERTICAL THEN STSCROLLINFO (SINEW, TRUE) Else SetscrollInfo (SELF.HANDLE, SB_VERT, SINEW, TRUE); end; end; function Tcustomvdbgrid.validfieldIndex (FieldIndex: Integer): Boolean; Begin Result: = Datalink.getMappedIndex (FieldIndex)> = 0; procedure TCustomVDBGrid.CMParentFontChanged (var Message: TMessage); begin inherited; if ParentFont then begin FSelfChangingTitleFont: = True; try TitleFont: = Font; finally FSelfChangingTitleFont: = False; end; LayoutChanged; end; end; procedure TCustomVDBGrid.CMExit (var Message: TMessage); begin try if FDatalink.Active then with FDatalink.Dataset do if (dgCancelOnExit in Options) and (State = dsInsert) and not Modified and not FDatalink.FModified then Cancel else FDataLink.UpdateData; except SetFocus; raise; end; inherited; end; procedure TCustomVDBGrid.CMFontChanged (var Message: TMessage); var I: Integer; begin inherited; BeginLayout; try for I: = 0 to Columns.Count-1 do Columns [I]. REFRESHDEFAULTFONT; FINALLY endLayout; end; Procedure tcustomvdbgrid.cmdeferLayout (var message); begin if acquirelayoutlock dam procedure TCustomVDBGrid.CMDesignHitTest (var Msg: TCMDesignHitTest); begin inherited; if (Msg.Result = 1) and ((FDataLink = nil) or ((Columns.State = csDefault) and (FDataLink.DefaultFields or (not FDataLink.Active) )))))......................... procedure TCustomVDBGrid.WMSetCursor (var Msg: TWMSetCursor); begin if (csDesigning in ComponentState) and ((FDataLink = nil) or ((Columns.State = csDefault) and (FDataLink.DefaultFields or (not FDataLink.Active)))) then Windows.SetCursor (LoadCursor (0, IDC_ARROW) Else Inherited; Procedure tcustomvdbgrid.wmsize (var message: twmsize); begin inherited; if updatelock = 0 dam = procedure TCustomVDBGrid.WMVScroll (var Message: TWMVScroll); var SI: TScrollInfo; begin if FVertical then begin inherited; Exit; end; if not AcquireFocus then Exit; if FDatalink.Active then with Message, FDataLink.DataSet do case ScrollCode of SB_LINEUP: MoveBy (-FDatalink.ActiveRecord - 1); SB_LINEDOWN: MoveBy (FDatalink.RecordCount - FDatalink.ActiveRecord); SB_PAGEUP: MoveBy (-VisibleRowCount); SB_PAGEDOWN: MoveBy (visibleRowCount); SB_THUMBPOSITION: begin if IsSequenced then begin SI.cbSize: = SIZEOF (SI); Si.fmask: = Sif_all; GetScrollInfo (Self.handle, SB_VERT, SI); if Si.ntrackPOS <= 1 Then First else if si.ntrackpos> = RecordCount dam = si.ntrackpos; ELSE CASE POS OF 0: First; 1: Moveby (-visibleRowcount); 2: EXI T; 3: Moveby (visibleRowcount); 4: Last; end; end; sb_bottom: last; sb_top: first; end; procedure TCustomVDBGrid.WMHScroll (var Message: TWMHScroll); var SI: TScrollInfo; begin if not FVertical then begin inherited; Exit; end; if not AcquireFocus then Exit; if FDatalink.Active then with Message, FDataLink.DataSet do case ScrollCode of SB_LINELEFT : MoveBy (-FDatalink.ActiveRecord - 1); SB_LINERIGHT: MoveBy (FDatalink.RecordCount - FDatalink.ActiveRecord); SB_PAGEUP: MoveBy (-VisibleColCount); SB_PAGEDOWN: MoveBy (VisibleColCount); SB_THUMBPOSITION: begin if IsSequenced then begin SI.cbSize: = SIZEOF (SI); Si.fmask: = Sif_all; GetScrollinfo (Self.handle, Sb_horz, Si); if si.ntrackpos <= 1 Then First else if si.ntrackpos> = RecordCount Ten Last else recno: = si.ntrackpos END ELSE CASE POS OF 0: First; 1: Moveby (-visiblecolcount); 2: Exit; 3: Moveby (VisibleColcount); 4: Last; End; end; sb_bottom: last; sb_top: first; end; end; procedure tcustomvdbgrid.setime; var column: tcolumn; begin if not syslocale.fareast kiln if FUpdatingEditor or FDataLink.FInUpdateData then begin ImeName: = Screen.DefaultIme; ImeMode: = imDontCare; end else begin Column: = Columns [SelectedIndex]; ImeName: = FOriginalImeName; ImeMode: = FOriginalImeMode; if cvImeMode in Column.FAssignedValues then begin ImeName : = Column.imename; IMEMODE: = column.imode; end; if InplaceEditor <> nil then begin TVDBGridInplaceEdit (Self) .ImeName: = ImeName; TVDBGridInplaceEdit (Self) .ImeMode: = ImeMode; end; end; procedure TCustomVDBGrid.UpdateIme; begin if not SysLocale.Fareast then Exit; SetIme; if InplaceEditor < > NIL TVDBGRIDINPLACEEDIT (SELF) .Setime; END; Procedure tcustomvdbgrid.wmimestartcomp (var message: tMessage); begin inherited; fuPDatingeditor: = true; showeditor; fuPDANGETOR: Procedure tcustomvdbgrid.wmsetfocus (var message: twmsetfocus); begin setime; inherited; Procedure tcustomvdbgrid.wmkillfocus; begin IMENAME: = Screen.defaultime; IMEMODE: = Imdontcare; inherited; End.
