Delphi控件源码

开发平台：

Delphi

bsdbgrids.pas：源码内容

{*******************************************************************}
{ }
{ Almediadev Visual Component Library }
{ BusinessSkinForm }
{ Version 1.98 }
{ }
{ }
{ Home: http://www.almdev.com }
{ Support: support@almdev.com }
{ }
{*******************************************************************}
unit bsDBGrids;
{$R-}
{$WARNINGS OFF}
{$HINTS OFF}
interface
uses Windows, SysUtils, Messages, Classes, Controls, Forms, StdCtrls,
Graphics, bsSkinGrids, DBCtrls, Db, Menus, ImgList, bsSkinCtrls, bsUtils,
bsSkinBoxCtrls, bsMessages;
type
TbsColumnValue = (cvColor, cvWidth, cvFont, cvAlignment, cvReadOnly, cvTitleColor,
cvTitleCaption, cvTitleAlignment, cvTitleFont, cvImeMode, cvImeName);
TbsColumnValues = set of TbsColumnValue;
const
ColumnTitleValues = [cvTitleColor..cvTitleFont];
cm_DeferLayout = WM_USER + 100;
type
TbsColumn = class;
TbsSkinCustomDBGrid = class;
TbsColumnTitle = class(TPersistent)
private
FColumn: TbsColumn;
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: TbsColumn);
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
function DefaultAlignment: TAlignment;
function DefaultColor: TColor;
function DefaultFont: TFont;
function DefaultCaption: string;
procedure RestoreDefaults; virtual;
property Column: TbsColumn read FColumn;
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;
TbsColumnButtonStyle = (cbsAuto, cbsEllipsis, cbsNone);
TbsColumn = class(TCollectionItem)
private
FField: TField;
FFieldName: string;
FColor: TColor;
FWidth: Integer;
FTitle: TbsColumnTitle;
FFont: TFont;
FImeMode: TImeMode;
FImeName: TImeName;
FPickList: TStrings;
FPopupMenu: TPopupMenu;
FDropDownRows: Cardinal;
FButtonStyle: TbsColumnButtonStyle;
FAlignment: TAlignment;
FReadonly: Boolean;
FAssignedValues: TbsColumnValues;
FVisible: Boolean;
FExpanded: Boolean;
FStored: Boolean;
procedure FontChanged(Sender: TObject);
function GetAlignment: TAlignment;
function GetColor: TColor;
function GetExpanded: Boolean;
function GetField: TField;
function GetFont: TFont;
function GetImeMode: TImeMode;
function GetImeName: TImeName;
function GetParentColumn: TbsColumn;
function GetPickList: TStrings;
function GetReadOnly: Boolean;
function GetShowing: Boolean;
function GetWidth: Integer;
function GetVisible: Boolean;
function IsAlignmentStored: Boolean;
function IsColorStored: Boolean;
function IsFontStored: Boolean;
function IsImeModeStored: Boolean;
function IsImeNameStored: Boolean;
function IsReadOnlyStored: Boolean;
function IsWidthStored: Boolean;
procedure SetAlignment(Value: TAlignment); virtual;
procedure SetButtonStyle(Value: TbsColumnButtonStyle);
procedure SetColor(Value: TColor);
procedure SetExpanded(Value: Boolean);
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;
procedure SetTitle(Value: TbsColumnTitle);
procedure SetWidth(Value: Integer); virtual;
procedure SetVisible(Value: Boolean);
function GetExpandable: Boolean;
protected
function CreateTitle: TbsColumnTitle; virtual;
function GetGrid: TbsSkinCustomDBGrid;
function GetDisplayName: string; override;
procedure RefreshDefaultFont;
procedure SetIndex(Value: Integer); override;
property IsStored: Boolean read FStored write FStored default True;
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;
function Depth: Integer;
procedure RestoreDefaults; virtual;
property Grid: TbsSkinCustomDBGrid read GetGrid;
property AssignedValues: TbsColumnValues read FAssignedValues;
property Expandable: Boolean read GetExpandable;
property Field: TField read GetField write SetField;
property ParentColumn: TbsColumn read GetParentColumn;
property Showing: Boolean read GetShowing;
published
property Alignment: TAlignment read GetAlignment write SetAlignment
stored IsAlignmentStored;
property ButtonStyle: TbsColumnButtonStyle 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 Expanded: Boolean read GetExpanded write SetExpanded default True;
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: TbsColumnTitle read FTitle write SetTitle;
property Width: Integer read GetWidth write SetWidth stored IsWidthStored;
property Visible: Boolean read GetVisible write SetVisible;
end;
TbsColumnClass = class of TbsColumn;
TbsDBGridColumnsState = (csDefault, csCustomized);
TbsDBGridColumns = class(TCollection)
private
FGrid: TbsSkinCustomDBGrid;
function GetColumn(Index: Integer): TbsColumn;
function InternalAdd: TbsColumn;
procedure SetColumn(Index: Integer; Value: TbsColumn);
procedure SetState(NewState: TbsDBGridColumnsState);
function GetState: TbsDBGridColumnsState;
protected
function GetOwner: TPersistent; override;
procedure Update(Item: TCollectionItem); override;
public
constructor Create(Grid: TbsSkinCustomDBGrid; ColumnClass: TbsColumnClass);
function Add: TbsColumn;
procedure LoadFromFile(const Filename: string);
procedure LoadFromStream(S: TStream);
procedure RestoreDefaults;
procedure RebuildColumns;
procedure SaveToFile(const Filename: string);
procedure SaveToStream(S: TStream);
property State: TbsDBGridColumnsState read GetState write SetState;
property Grid: TbsSkinCustomDBGrid read FGrid;
property Items[Index: Integer]: TbsColumn read GetColumn write SetColumn; default;
end;
TbsGridDataLink = class(TDataLink)
private
FGrid: TbsSkinCustomDBGrid;
FFieldCount: Integer;
FFieldMap: array of Integer;
FModified: Boolean;
FInUpdateData: Boolean;
FSparseMap: Boolean;
function GetDefaultFields: Boolean;
function GetFields(I: Integer): TField;
protected
procedure ActiveChanged; override;
procedure BuildAggMap;
procedure DataSetChanged; override;
procedure DataSetScrolled(Distance: Integer); override;
procedure FocusControl(Field: TFieldRef); override;
procedure EditingChanged; override;
function IsAggRow(Value: Integer): Boolean; virtual;
procedure LayoutChanged; override;
procedure RecordChanged(Field: TField); override;
procedure UpdateData; override;
function GetMappedIndex(ColIndex: Integer): Integer;
public
constructor Create(AGrid: TbsSkinCustomDBGrid);
destructor Destroy; override;
function AddMapping(const FieldName: string): Boolean;
procedure ClearMapping;
procedure Modified;
procedure Reset;
property DefaultFields: Boolean read GetDefaultFields;
property FieldCount: Integer read FFieldCount;
property Fields[I: Integer]: TField read GetFields;
property SparseMap: Boolean read FSparseMap write FSparseMap;
end;
TbsBookmarkList = class
private
FList: TStringList;
FGrid: TbsSkinCustomDBGrid;
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: TbsSkinCustomDBGrid);
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: Integer read GetCount;
property CurrentRowSelected: Boolean read GetCurrentRowSelected
write SetCurrentRowSelected;
property Items[Index: Integer]: TBookmarkStr read GetItem; default;
end;
TbsDBGridOption = (dgEditing, dgAlwaysShowEditor, dgTitles, dgIndicator,
dgColumnResize, dgColLines, dgRowLines, dgTabs, dgRowSelect,
dgAlwaysShowSelection, dgConfirmDelete, dgCancelOnExit, dgMultiSelect);
TbsDBGridOptions = set of TbsDBGridOption;
TDrawDataCellEvent = procedure (Sender: TObject; const Rect: TRect; Field: TField;
State: TGridDrawState) of object;
TDrawColumnCellEvent = procedure (Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TbsColumn; State: TGridDrawState) of object;
TDBGridClickEvent = procedure (Column: TbsColumn) of object;
TbsSkinCustomDBGrid = class(TbsSkinCustomGrid)
private
FMouseWheelSupport: Boolean;
FSkinMessage: TbsSkinMessage;
FPickListBoxSkinDataName: String;
FPickListBoxCaptionMode: Boolean;
FIndicators: TImageList;
FTitleFont: TFont;
FReadOnly: Boolean;
FOriginalImeName: TImeName;
FOriginalImeMode: TImeMode;
FUserChange: Boolean;
FIsESCKey: Boolean;
FLayoutFromDataset: Boolean;
FOptions: TbsDBGridOptions;
FTitleOffset, FIndicatorOffset: Byte;
FUpdateLock: Byte;
FLayoutLock: Byte;
FInColExit: Boolean;
FDefaultDrawing: Boolean;
FSelfChangingTitleFont: Boolean;
FSelecting: Boolean;
FSelRow: Integer;
FDataLink: TbsGridDataLink;
FOnColEnter: TNotifyEvent;
FOnColExit: TNotifyEvent;
FOnDrawDataCell: TDrawDataCellEvent;
FOnDrawColumnCell: TDrawColumnCellEvent;
FEditText: string;
FColumns: TbsDBGridColumns;
FVisibleColumns: TList;
FBookmarks: TbsBookmarkList;
FSelectionAnchor: TBookmarkStr;
FOnEditButtonClick: TNotifyEvent;
FOnColumnMoved: TMovedEvent;
FOnCellClick: TDBGridClickEvent;
FOnTitleClick: TDBGridClickEvent;
FDragCol: TbsColumn;
function AcquireFocus: 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, Direction: Integer);
function PtInExpandButton(X,Y: Integer; var MasterCol: TbsColumn): Boolean;
procedure ReadColumns(Reader: TReader);
procedure RecordChanged(Field: TField);
procedure SetIme;
procedure SetColumns(Value: TbsDBGridColumns);
procedure SetDataSource(Value: TDataSource);
procedure SetOptions(Value: TbsDBGridOptions);
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 CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
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 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;
procedure PickListBoxOnCheckButtonClick(Sender: TObject);
procedure SetHScrollBar(Value: TbsSkinScrollBar); override;
procedure UpdateScrollPos(UpDateVert: Boolean); override;
procedure UpdateScrollRange(UpDateVert: Boolean); override;
function RawToDataColumn(ACol: Integer): Integer;
function DataToRawColumn(ACol: Integer): Integer;
function AcquireLayoutLock: Boolean;
procedure BeginLayout;
procedure BeginUpdate;
procedure CalcSizingState(X, Y: Integer; var State: TbsGridState;
var Index: Longint; var SizingPos, SizingOfs: Integer;
var FixedInfo: TbsGridDrawInfo); override;
procedure CancelLayout;
function CanEditAcceptKey(Key: Char): Boolean; override;
function CanEditModify: Boolean; override;
function CanEditShow: Boolean; override;
procedure CellClick(Column: TbsColumn); dynamic;
procedure ColumnMoved(FromIndex, ToIndex: Longint); override;
function CalcTitleRect(Col: TbsColumn; ARow: Integer;
var MasterCol: TbsColumn): TRect;
function ColumnAtDepth(Col: TbsColumn; ADepth: Integer): TbsColumn;
procedure ColEnter; dynamic;
procedure ColExit; dynamic;
procedure ColWidthsChanged; override;
function CreateColumns: TbsDBGridColumns; dynamic;
function CreateEditor: TbsSkinInplaceEdit; override;
procedure CreateWnd; override;
procedure DeferLayout;
procedure DefineFieldMap; virtual;
procedure DefineProperties(Filer: TFiler); override;
procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
procedure DrawSkinCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
procedure DrawDefaultCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
procedure DrawDataCell(const Rect: TRect; Field: TField;
State: TGridDrawState); dynamic; { obsolete }
procedure DrawColumnCell(const Rect: TRect; DataCol: Integer;
Column: TbsColumn; State: TGridDrawState); dynamic;
procedure EditButtonClick; dynamic;
procedure EndLayout;
procedure EndUpdate;
function 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 InvalidateTitles;
procedure LayoutChanged; virtual;
procedure LinkActive(Value: Boolean); virtual;
procedure Loaded; override;
procedure WMMouseWheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL;
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: TbsColumn); dynamic;
procedure TopLeftChanged; override;
function UseRightToLeftAlignmentForField(const AField: TField;
Alignment: TAlignment): Boolean;
function BeginColumnDrag(var Origin, Destination: Integer;
const MousePt: TPoint): Boolean; override;
function CheckColumnDrag(var Origin, Destination: Integer;
const MousePt: TPoint): Boolean; override;
function EndColumnDrag(var Origin, Destination: Integer;
const MousePt: TPoint): Boolean; override;
property Columns: TbsDBGridColumns read FColumns write SetColumns;
property DefaultDrawing: Boolean read FDefaultDrawing write FDefaultDrawing default True;
property DataLink: TbsGridDataLink read FDataLink;
property IndicatorOffset: Byte read FIndicatorOffset;
property LayoutLock: Byte read FLayoutLock;
property Options: TbsDBGridOptions read FOptions write SetOptions
default [dgEditing, dgTitles, dgIndicator, dgColumnResize, dgColLines,
dgRowLines, dgTabs, dgConfirmDelete, dgCancelOnExit];
property ParentColor default False;
property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
property SelectedRows: TbsBookmarkList 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 ChangeSkinData; override;
procedure DefaultDrawDataCell(const Rect: TRect; Field: TField;
State: TGridDrawState); { obsolete }
procedure DefaultDrawColumnCell(const Rect: TRect; DataCol: Integer;
Column: TbsColumn; State: TGridDrawState);
procedure DefaultHandler(var Msg); override;
function ExecuteAction(Action: TBasicAction): Boolean; override;
procedure ShowPopupEditor(Column: TbsColumn; X: Integer = Low(Integer);
Y: Integer = Low(Integer)); dynamic;
function UpdateAction(Action: TBasicAction): Boolean; override;
function ValidFieldIndex(FieldIndex: Integer): Boolean;
property SkinMessage: TbsSkinMessage read FSkinMessage write FSkinMessage;
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 write SetSelectedIndex;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property PickListBoxSkinDataName: String read FPickListBoxSkinDataName
write FPickListBoxSkinDataName;
property PickListBoxCaptionMode: Boolean read FPickListBoxCaptionMode
write FPickListBoxCaptionMode;
property MouseWheelSupport: Boolean
read FMouseWheelSupport write FMouseWheelSupport;
end;
TbsSkinDBGrid = class(TbsSkinCustomDBGrid)
public
property Canvas;
property SelectedRows;
published
property MouseWheelSupport;
property SkinMessage;
property PickListBoxSkinDataName;
property PickListBoxCaptionMode;
property Align;
property Anchors;
property BiDiMode;
property BorderStyle;
property Color;
property Columns stored False;
property Constraints;
property Ctl3D;
property DataSource;
property DefaultDrawing;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FixedColor;
property Font;
property ImeMode;
property ImeName;
property Options;
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property TabStop;
property TitleFont;
property Visible;
property OnCellClick;
property OnColEnter;
property OnColExit;
property OnColumnMoved;
property OnDrawDataCell; { obsolete }
property OnDrawColumnCell;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEditButtonClick;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property OnTitleClick;
end;
const
IndicatorWidth = 11;
implementation
uses Math, DBConsts, Dialogs {$IFDEF VER140}, Variants{$ENDIF}
{$IFDEF VER150}, Variants{$ENDIF};
{$R BSDBGRIDS.RES}
const
bmArrow = 'BSDBGARROW';
bmEdit = 'BSDBEDIT';
bmInsert = 'BSDBINSERT';
bmMultiDot = 'BSDBMULTIDOT';
bmMultiArrow = 'BSDBMULTIARROW';
MaxMapSize = (MaxInt div 2) div SizeOf(Integer); { 250 million }
{ Error reporting }
procedure RaiseGridError(const S: string);
begin
// raise EInvalidGridOperation.Create(S);
end;
procedure KillMessage(Wnd: HWnd; Msg: Integer);
var
M: TMsg;
begin
M.Message := 0;
if PeekMessage(M, Wnd, Msg, Msg, pm_Remove) and (M.Message = WM_QUIT) then
PostQuitMessage(M.wparam);
end;
{ TDBGridInplaceEdit }
type
TEditStyle = (esSimple, esEllipsis, esPickList, esDataList);
TbsDBPopupListbox = class;
TDBGridInplaceEdit = class(TbsSkinInplaceEdit)
private
FButtonWidth: Integer;
FDataList: TDBLookupListBox;
FPickList: TbsDBPopupListbox;
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;
function OverButton(const P: TPoint): Boolean;
function ButtonRect: TRect;
protected
procedure BoundsChanged; override;
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: TbsDBPopupListbox read FPickList;
public
procedure CloseUp(Accept: Boolean);
constructor Create(Owner: TComponent); override;
end;
{ TbsDBPopupListbox }
TbsDBPopupListbox = class(TbsPopupListBox)
protected
FListBoxWindowProc: TWndMethod;
procedure ListBoxWindowProcHook(var Message: TMessage);
procedure ListBoxMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
end;
constructor TbsDBPopupListbox.Create(Owner: TComponent);
begin
inherited;
FListBoxWindowProc := ListBox.WindowProc;
ListBox.WindowProc := ListBoxWindowProcHook;
ListBox.OnMouseMove := ListBoxMouseMove;
end;
destructor TbsDBPopupListbox.Destroy;
begin
inherited;
end;
procedure TbsDBPopupListbox.ListBoxWindowProcHook(var Message: TMessage);
var
FOld: Boolean;
begin
FOld := True;
case Message.Msg of
WM_LBUTTONUP:
begin
TDBGridInPlaceEdit(Owner).CloseUp(True);
end;
WM_RBUTTONDOWN, WM_RBUTTONUP,
WM_MBUTTONDOWN, WM_MBUTTONUP,
WM_LBUTTONDOWN:
begin
FOLd := False;
end;
WM_MOUSEACTIVATE:
begin
Message.Result := MA_NOACTIVATE;
end;
end;
if FOld then FListBoxWindowProc(Message);
end;
procedure TbsDBPopupListbox.ListBoxMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var
Index: Integer;
begin
Index := ListBox.ItemAtPos(Point (X, Y), True);
if (Index >= 0) and (Index < Items.Count)
then
ItemIndex := Index;
end;
constructor TDBGridInplaceEdit.Create(Owner: TComponent);
begin
inherited Create(Owner);
FLookupSource := TDataSource.Create(Self);
FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
FEditStyle := esSimple;
end;
procedure TDBGridInplaceEdit.BoundsChanged;
var
R: TRect;
begin
Windows.SetRect(R, 2, 2, Width - 2, Height);
if FEditStyle <> esSimple then
if not TbsSkinCustomDBGrid(Owner).UseRightToLeftAlignment then
Dec(R.Right, FButtonWidth)
else
Inc(R.Left, FButtonWidth - 2);
SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@R));
SendMessage(Handle, EM_SCROLLCARET, 0, 0);
if SysLocale.FarEast then
SetImeCompositionWindow(Font, R.Left, R.Top);
end;
procedure TDBGridInplaceEdit.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];
TbsDBPopupListBox(FActiveList).Hide;
FActiveList.Visible := False;
FListVisible := False;
if Assigned(FDataList) then
FDataList.ListSource := nil;
FLookupSource.Dataset := nil;
Invalidate;
if Accept then
if FActiveList = FDataList then
with TbsSkinCustomDBGrid(Grid), Columns[SelectedIndex].Field do
begin
MasterField := DataSet.FieldByName(KeyFields);
if MasterField.CanModify and FDataLink.Edit then
MasterField.Value := ListValue;
end
else
if (not VarIsNull(ListValue)) and EditCanModify then
with TbsSkinCustomDBGrid(Grid), Columns[SelectedIndex].Field do
Text := ListValue;
end;
end;
procedure TDBGridInplaceEdit.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;
end;
procedure TDBGridInplaceEdit.DropDown;
var
P: TPoint;
I,J,Y: Integer;
Column: TbsColumn;
begin
if not FListVisible and Assigned(FActiveList) then
begin
FActiveList.Width := Width;
with TbsSkinCustomDBGrid(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;
end
else
begin
//
with FPickList do
begin
SkinData := Grid.SkinData;
SkinDataName := TbsSkinCustomDbGrid(Grid).PickListBoxSkinDataName;
CaptionMode := TbsSkinCustomDbGrid(Grid).PickListBoxCaptionMode;
if CaptionMode
then
begin
Caption := Column.Title.Caption;
OnCheckButtonClick := TbsSkinCustomDbGrid(Grid).PickListBoxOnCheckButtonClick;
end;
end;
FPickList.ChangeSkinData;
//
if FPickList.FIndex = -1
then
begin
FPickList.Font := Font;
end;
FPickList.Items := Column.Picklist;
if FPickList.Items.Count >= Integer(Column.DropDownRows) then
FPickList.Height := Integer(Column.DropDownRows) * FPickList.ListBox.ItemHeight + 4
else
FPickList.Height := FPickList.Items.Count * FPickList.ListBox.ItemHeight + 4;
if Column.Field.IsNull then
FPickList.ItemIndex := -1
else
FPickList.ItemIndex := FPickList.Items.IndexOf(Column.Field.Text);
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 := P.Y + Height;
if Y + FActiveList.Height > Screen.Height then Y := P.Y - FActiveList.Height;
TbsDBPopupListBox(FActiveList).Show(Point(P.X, Y));
FListVisible := True;
Invalidate;
Windows.SetFocus(Handle);
end;
end;
type
TWinControlCracker = class(TWinControl) end;
procedure TDBGridInplaceEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
if (EditStyle = esEllipsis) and (Key = VK_RETURN) and (Shift = [ssCtrl]) then
begin
TbsSkinCustomDBGrid(Grid).EditButtonClick;
KillMessage(Handle, WM_CHAR);
end
else
inherited KeyDown(Key, Shift);
end;
procedure TDBGridInplaceEdit.ListMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
CloseUp(PtInRect(FActiveList.ClientRect, Point(X, Y)));
end;
procedure TDBGridInplaceEdit.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if (Button = mbLeft) and (FEditStyle <> esSimple) and
OverButton(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 TDBGridInplaceEdit.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 TDBGridInplaceEdit.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
WasPressed: Boolean;
begin
WasPressed := FPressed;
StopTracking;
if (Button = mbLeft) and (FEditStyle = esEllipsis) and WasPressed then
TbsSkinCustomDBGrid(Grid).EditButtonClick;
inherited MouseUp(Button, Shift, X, Y);
end;
procedure TDBGridInplaceEdit.PaintWindow(DC: HDC);
procedure DrawButton(R: TRect);
var
SaveIndex: Integer;
C: TCanvas;
begin
SaveIndex := SaveDC(DC);
C := TCanvas.Create;
C.Handle := DC;
with C do
begin
Brush.Color := Color;
FillRect(R);
DrawArrowImage(C, R, Font.Color, 4);
end;
C.Handle := 0;
C.Free;
RestoreDC(DC, SaveIndex);
end;
procedure DrawButton2(R: TRect);
var
SaveIndex: Integer;
C: TCanvas;
W, X, Y: Integer;
begin
SaveIndex := SaveDC(DC);
C := TCanvas.Create;
C.Handle := DC;
with C do
begin
Brush.Color := Color;
FillRect(R);
X := R.Left + ((R.Right - R.Left) shr 1) - 1;
Y := R.Top + ((R.Bottom - R.Top) shr 1) - 1;
W := FButtonWidth shr 3;
if W = 0 then W := 1;
Pen.Color := Font.Color;
Rectangle(X, Y, X + W, Y + W);
Rectangle(X - (W * 2), Y, X - (W * 2) + W, Y + W);
Rectangle(X + (W * 2), Y, X + (W * 2) + W, Y + W);
end;
C.Handle := 0;
C.Free;
RestoreDC(DC, SaveIndex);
end;
var
R: TRect;
begin
if FEditStyle <> esSimple
then
begin
R := ButtonRect;
if FEditStyle in [esDataList, esPickList]
then
DrawButton(R)
else
DrawButton2(R);
ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
end;
inherited PaintWindow(DC);
end;
procedure TDBGridInplaceEdit.SetEditStyle(Value: TEditStyle);
begin
if Value = FEditStyle then Exit;
FEditStyle := Value;
case Value of
esPickList:
begin
if FPickList = nil then
begin
FPickList := TbsDBPopupListbox.Create(Self);
FPickList.Visible := False;
FPickList.Parent := Self;
FPickList.OnMouseUp := ListMouseUp;
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 TbsSkinCustomDBGrid(Grid) do
Self.ReadOnly := Columns[SelectedIndex].ReadOnly;
Repaint;
end;
procedure TDBGridInplaceEdit.StopTracking;
begin
if FTracking then
begin
TrackButton(-1, -1);
FTracking := False;
MouseCapture := False;
end;
end;
procedure TDBGridInplaceEdit.TrackButton(X,Y: Integer);
var
NewState: Boolean;
R: TRect;
begin
R := ButtonRect;
NewState := PtInRect(R, Point(X, Y));
if FPressed <> NewState then
begin
FPressed := NewState;
InvalidateRect(Handle, @R, False);
end;
end;
procedure TDBGridInplaceEdit.UpdateContents;
var
Column: TbsColumn;
NewStyle: TEditStyle;
MasterField: TField;
begin
with TbsSkinCustomDBGrid(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 TbsSkinCustomDBGrid(Grid) do
if not ReadOnly and DataLink.Active and not Datalink.ReadOnly then
NewStyle := esDataList
end
else
if Assigned(Column.Picklist) and (Column.PickList.Count > 0) and
not Column.Readonly then
NewStyle := esPickList
else if DataType in [ftDataset, ftReference] then
NewStyle := esEllipsis;
end;
end;
EditStyle := NewStyle;
inherited UpdateContents;
Font.Assign(Column.Font);
ImeMode := Column.ImeMode;
ImeName := Column.ImeName;
end;
procedure TDBGridInplaceEdit.CMCancelMode(var Message: TCMCancelMode);
function NotActiveListHandle: Boolean;
begin
if FActiveList <> nil
then
with TbsDBPopupListbox(FActiveList) do
begin
Result := (Message.Sender <> FPickList) and
(Message.Sender <> FPickList.ListBox);
if FPickList.ScrollBar <> nil
then
Result := Result and (Message.Sender <> FPickList.ScrollBar);
end
else
Result := False;
end;
begin
if (Message.Sender <> Self) and (Message.Sender <> FActiveList) and
NotActiveListHandle
then
CloseUp(False);
end;
procedure TDBGridInplaceEdit.WMCancelMode(var Message: TMessage);
begin
StopTracking;
inherited;
end;
type
TParentGrid = class(TbsSkinDBGrid);
procedure TDBGridInplaceEdit.WMKillFocus(var Message: TMessage);
begin
if not SysLocale.FarEast then inherited
else
begin
ImeName := Screen.DefaultIme;
ImeMode := imDontCare;
inherited;
if HWND(Message.WParam) <> TbsSkinCustomDBGrid(Grid).Handle then
ActivateKeyboardLayout(Screen.DefaultKbLayout, KLF_ACTIVATE);
end;
CloseUp(False);
with TParentGrid(Grid) do
if FIndex = -1 then InvalidateCell(Col, Row);
end;
function TDBGridInplaceEdit.ButtonRect: TRect;
begin
if not TbsSkinCustomDBGrid(Owner).UseRightToLeftAlignment then
Result := Rect(Width - FButtonWidth, 0, Width, Height)
else
Result := Rect(0, 0, FButtonWidth, Height);
end;
function TDBGridInplaceEdit.OverButton(const P: TPoint): Boolean;
begin
Result := PtInRect(ButtonRect, P);
end;
procedure TDBGridInplaceEdit.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
with Message do
if (FEditStyle <> esSimple) and OverButton(Point(XPos, YPos)) then
Exit;
inherited;
end;
procedure TDBGridInplaceEdit.WMPaint(var Message: TWMPaint);
begin
PaintHandler(Message);
end;
procedure TDBGridInplaceEdit.WMSetCursor(var Message: TWMSetCursor);
var
P: TPoint;
begin
GetCursorPos(P);
P := ScreenToClient(P);
if (FEditStyle <> esSimple) and OverButton(P) then
Windows.SetCursor(LoadCursor(0, idc_Arrow))
else
inherited;
end;
procedure TDBGridInplaceEdit.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 then
begin
with TMessage(Message) do
SendMessage(TbsDBPopupListbox(FActiveList).ListBox.Handle, Msg, WParam, LParam);
Exit;
end;
end
end;
inherited;
end;
{ TbsGridDataLink }
type
TIntArray = array[0..MaxMapSize] of Integer;
PIntArray = ^TIntArray;
constructor TbsGridDataLink.Create(AGrid: TbsSkinCustomDBGrid);
begin
inherited Create;
FGrid := AGrid;
VisualControl := True;
end;
destructor TbsGridDataLink.Destroy;
begin
ClearMapping;
inherited Destroy;
end;
function TbsGridDataLink.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 FFieldMap[I] < 0 then
begin
Result := False;
Exit;
end;
end;
function TbsGridDataLink.GetFields(I: Integer): TField;
begin
if (0 <= I) and (I < FFieldCount) and (FFieldMap[I] >= 0) then
Result := DataSet.FieldList[FFieldMap[I]]
else
Result := nil;
end;
function TbsGridDataLink.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 = Length(FFieldMap) then
begin
NewSize := Length(FFieldMap);
if NewSize = 0 then
NewSize := 8
else
Inc(NewSize, NewSize);
if (NewSize < FFieldCount) then
NewSize := FFieldCount + 1;
if (NewSize > MaxMapSize) then
NewSize := MaxMapSize;
SetLength(FFieldMap, NewSize);
end;
if Assigned(Field) then
begin
FFieldMap[FFieldCount] := Dataset.FieldList.IndexOfObject(Field);
Field.FreeNotification(FGrid);
end
else
FFieldMap[FFieldCount] := -1;
Inc(FFieldCount);
end;
procedure TbsGridDataLink.ActiveChanged;
begin
FGrid.LinkActive(Active);
FModified := False;
end;
procedure TbsGridDataLink.ClearMapping;
begin
FFieldMap := nil;
FFieldCount := 0;
end;
procedure TbsGridDataLink.Modified;
begin
FModified := True;
end;
procedure TbsGridDataLink.DataSetChanged;
begin
FGrid.DataChanged;
FModified := False;
end;
procedure TbsGridDataLink.DataSetScrolled(Distance: Integer);
begin
FGrid.Scroll(Distance);
end;
procedure TbsGridDataLink.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;
end;
procedure TbsGridDataLink.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;
end;
end;
procedure TbsGridDataLink.EditingChanged;
begin
FGrid.EditingChanged;
end;
procedure TbsGridDataLink.RecordChanged(Field: TField);
begin
FGrid.RecordChanged(Field);
FModified := False;
end;
procedure TbsGridDataLink.UpdateData;
begin
FInUpdateData := True;
try
if FModified then FGrid.UpdateData;
FModified := False;
finally
FInUpdateData := False;
end;
end;
function TbsGridDataLink.GetMappedIndex(ColIndex: Integer): Integer;
begin
if (0 <= ColIndex) and (ColIndex < FFieldCount) then
Result := FFieldMap[ColIndex]
else
Result := -1;
end;
procedure TbsGridDataLink.Reset;
begin
if FModified then RecordChanged(nil) else Dataset.Cancel;
end;
function TbsGridDataLink.IsAggRow(Value: Integer): Boolean;
begin
Result := False;
end;
procedure TbsGridDataLink.BuildAggMap;
begin
end;
{ TbsColumnTitle }
constructor TbsColumnTitle.Create(Column: TbsColumn);
begin
inherited Create;
FColumn := Column;
FFont := TFont.Create;
FFont.Assign(DefaultFont);
FFont.OnChange := FontChanged;
end;
destructor TbsColumnTitle.Destroy;
begin
FFont.Free;
inherited Destroy;
end;
procedure TbsColumnTitle.Assign(Source: TPersistent);
begin
if Source is TbsColumnTitle then
begin
if cvTitleAlignment in TbsColumnTitle(Source).FColumn.FAssignedValues then
Alignment := TbsColumnTitle(Source).Alignment;
if cvTitleColor in TbsColumnTitle(Source).FColumn.FAssignedValues then
Color := TbsColumnTitle(Source).Color;
if cvTitleCaption in TbsColumnTitle(Source).FColumn.FAssignedValues then
Caption := TbsColumnTitle(Source).Caption;
if cvTitleFont in TbsColumnTitle(Source).FColumn.FAssignedValues then
Font := TbsColumnTitle(Source).Font;
end
else
inherited Assign(Source);
end;
function TbsColumnTitle.DefaultAlignment: TAlignment;
begin
Result := taLeftJustify;
end;
function TbsColumnTitle.DefaultColor: TColor;
var
Grid: TbsSkinCustomDBGrid;
begin
Grid := FColumn.GetGrid;
if Assigned(Grid) then
Result := Grid.FixedColor
else
Result := clBtnFace;
end;
function TbsColumnTitle.DefaultFont: TFont;
var
Grid: TbsSkinCustomDBGrid;
begin
Grid := FColumn.GetGrid;
if Assigned(Grid) then
Result := Grid.TitleFont
else
Result := FColumn.Font;
end;
function TbsColumnTitle.DefaultCaption: string;
var
Field: TField;
begin
Field := FColumn.Field;
if Assigned(Field) then
Result := Field.DisplayName
else
Result := FColumn.FieldName;
end;
procedure TbsColumnTitle.FontChanged(Sender: TObject);
begin
Include(FColumn.FAssignedValues, cvTitleFont);
FColumn.Changed(True);
end;
function TbsColumnTitle.GetAlignment: TAlignment;
begin
if cvTitleAlignment in FColumn.FAssignedValues then
Result := FAlignment
else
Result := DefaultAlignment;
end;
function TbsColumnTitle.GetColor: TColor;
begin
if cvTitleColor in FColumn.FAssignedValues then
Result := FColor
else
Result := DefaultColor;
end;
function TbsColumnTitle.GetCaption: string;
begin
if cvTitleCaption in FColumn.FAssignedValues then
Result := FCaption
else
Result := DefaultCaption;
end;
function TbsColumnTitle.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) then
begin
Save := FFont.OnChange;
FFont.OnChange := nil;
FFont.Assign(DefaultFont);
FFont.OnChange := Save;
end;
end;
Result := FFont;
end;
function TbsColumnTitle.IsAlignmentStored: Boolean;
begin
Result := (cvTitleAlignment in FColumn.FAssignedValues) and
(FAlignment <> DefaultAlignment);
end;
function TbsColumnTitle.IsColorStored: Boolean;
begin
Result := (cvTitleColor in FColumn.FAssignedValues) and
(FColor <> DefaultColor);
end;
function TbsColumnTitle.IsFontStored: Boolean;
begin
Result := (cvTitleFont in FColumn.FAssignedValues);
end;
function TbsColumnTitle.IsCaptionStored: Boolean;
begin
Result := (cvTitleCaption in FColumn.FAssignedValues) and
(FCaption <> DefaultCaption);
end;
procedure TbsColumnTitle.RefreshDefaultFont;
var
Save: TNotifyEvent;
begin
if (cvTitleFont in FColumn.FAssignedValues) then Exit;
Save := FFont.OnChange;
FFont.OnChange := nil;
try
FFont.Assign(DefaultFont);
finally
FFont.OnChange := Save;
end;
end;
procedure TbsColumnTitle.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);
end;
procedure TbsColumnTitle.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 TbsColumnTitle.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 TbsColumnTitle.SetFont(Value: TFont);
begin
FFont.Assign(Value);
end;
procedure TbsColumnTitle.SetCaption(const Value: string);
var
Grid: TbsSkinCustomDBGrid;
begin
if Column.IsStored then
begin
if (cvTitleCaption in FColumn.FAssignedValues) and (Value = FCaption) then Exit;
FCaption := Value;
Include(Column.FAssignedValues, cvTitleCaption);
Column.Changed(False);
end
else
begin
Grid := Column.GetGrid;
if Assigned(Grid) and (Grid.Datalink.Active) and Assigned(Column.Field) then
Column.Field.DisplayLabel := Value;
end;
end;
{ TbsColumn }
constructor TbsColumn.Create(Collection: TCollection);
var
Grid: TbsSkinCustomDBGrid;
begin
Grid := nil;
if Assigned(Collection) and (Collection is TbsDBGridColumns) then
Grid := TbsDBGridColumns(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;
FVisible := True;
FExpanded := True;
FStored := True;
finally
if Assigned(Grid) then Grid.EndLayout;
end;
end;
destructor TbsColumn.Destroy;
begin
FTitle.Free;
FFont.Free;
FPickList.Free;
inherited Destroy;
end;
procedure TbsColumn.Assign(Source: TPersistent);
begin
if Source is TbsColumn then
begin
if Assigned(Collection) then Collection.BeginUpdate;
try
RestoreDefaults;
FieldName := TbsColumn(Source).FieldName;
if cvColor in TbsColumn(Source).AssignedValues then
Color := TbsColumn(Source).Color;
if cvWidth in TbsColumn(Source).AssignedValues then
Width := TbsColumn(Source).Width;
if cvFont in TbsColumn(Source).AssignedValues then
Font := TbsColumn(Source).Font;
if cvImeMode in TbsColumn(Source).AssignedValues then
ImeMode := TbsColumn(Source).ImeMode;
if cvImeName in TbsColumn(Source).AssignedValues then
ImeName := TbsColumn(Source).ImeName;
if cvAlignment in TbsColumn(Source).AssignedValues then
Alignment := TbsColumn(Source).Alignment;
if cvReadOnly in TbsColumn(Source).AssignedValues then
ReadOnly := TbsColumn(Source).ReadOnly;
Title := TbsColumn(Source).Title;
DropDownRows := TbsColumn(Source).DropDownRows;
ButtonStyle := TbsColumn(Source).ButtonStyle;
PickList := TbsColumn(Source).PickList;
PopupMenu := TbsColumn(Source).PopupMenu;
FVisible := TbsColumn(Source).FVisible;
FExpanded := TbsColumn(Source).FExpanded;
finally
if Assigned(Collection) then Collection.EndUpdate;
end;
end
else
inherited Assign(Source);
end;
function TbsColumn.CreateTitle: TbsColumnTitle;
begin
Result := TbsColumnTitle.Create(Self);
end;
function TbsColumn.DefaultAlignment: TAlignment;
begin
if Assigned(Field) then
Result := FField.Alignment
else
Result := taLeftJustify;
end;
function TbsColumn.DefaultColor: TColor;
var
Grid: TbsSkinCustomDBGrid;
begin
Grid := GetGrid;
if Assigned(Grid) then
Result := Grid.Color
else
Result := clWindow;
end;
function TbsColumn.DefaultFont: TFont;
var
Grid: TbsSkinCustomDBGrid;
begin
Grid := GetGrid;
if Assigned(Grid) then
Result := Grid.Font
else
Result := FFont;
end;
function TbsColumn.DefaultImeMode: TImeMode;
var
Grid: TbsSkinCustomDBGrid;
begin
Grid := GetGrid;
if Assigned(Grid) then
Result := Grid.ImeMode
else
Result := FImeMode;
end;
function TbsColumn.DefaultImeName: TImeName;
var
Grid: TbsSkinCustomDBGrid;
begin
Grid := GetGrid;
if Assigned(Grid) then
Result := Grid.ImeName
else
Result := FImeName;
end;
function TbsColumn.DefaultReadOnly: Boolean;
var
Grid: TbsSkinCustomDBGrid;
begin
Grid := GetGrid;
Result := (Assigned(Grid) and Grid.ReadOnly) or
(Assigned(Field) and FField.ReadOnly);
end;
function TbsColumn.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 HandleAllocated;
if RestoreCanvas then
Canvas.Handle := GetDC(0);
try
Canvas.Font := Self.Font;
GetTextMetrics(Canvas.Handle, TM);
Result := Field.DisplayWidth * (Canvas.TextWidth('0') - TM.tmOverhang)
+ TM.tmOverhang + 4;
if dgTitles in Options then
begin
Canvas.Font := Title.Font;
W := Canvas.TextWidth(Title.Caption) + 4;
if Result < W then
Result := W;
end;
finally
if RestoreCanvas then
begin
ReleaseDC(0,Canvas.Handle);
Canvas.Handle := 0;
end;
end;
end
else
Result := DefaultColWidth;
end;
end;
procedure TbsColumn.FontChanged;
begin
Include(FAssignedValues, cvFont);
Title.RefreshDefaultFont;
Changed(False);
end;
function TbsColumn.GetAlignment: TAlignment;
begin
if cvAlignment in FAssignedValues then
Result := FAlignment
else
Result := DefaultAlignment;
end;
function TbsColumn.GetColor: TColor;
begin
if cvColor in FAssignedValues then
Result := FColor
else
Result := DefaultColor;
end;
function TbsColumn.GetExpanded: Boolean;
begin
Result := FExpanded and Expandable;
end;
function TbsColumn.GetField: TField;
var
Grid: TbsSkinCustomDBGrid;
begin { Returns Nil if FieldName can't 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 DefaultFields) then
SetField(FindField(FieldName));
Result := FField;
end;
function TbsColumn.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(DefaultFont);
FFont.OnChange := Save;
end;
Result := FFont;
end;
function TbsColumn.GetGrid: TbsSkinCustomDBGrid;
begin
if Assigned(Collection) and (Collection is TbsDBGridColumns) then
Result := TbsDBGridColumns(Collection).Grid
else
Result := nil;
end;
function TbsColumn.GetDisplayName: string;
begin
Result := FFieldName;
if Result = '' then Result := inherited GetDisplayName;
end;
function TbsColumn.GetImeMode: TImeMode;
begin
if cvImeMode in FAssignedValues then
Result := FImeMode
else
Result := DefaultImeMode;
end;
function TbsColumn.GetImeName: TImeName;
begin
if cvImeName in FAssignedValues then
Result := FImeName
else
Result := DefaultImeName;
end;
function TbsColumn.GetParentColumn: TbsColumn;
var
Col: TbsColumn;
Fld: TField;
I: Integer;
begin
Result := nil;
Fld := Field;
if (Fld <> nil) and (Fld.ParentField <> nil) and (Collection <> nil) then
for I := Index - 1 downto 0 do
begin
Col := TbsColumn(Collection.Items[I]);
if Fld.ParentField = Col.Field then
begin
Result := Col;
Exit;
end;
end;
end;
function TbsColumn.GetPickList: TStrings;
begin
if FPickList = nil then FPickList := TStringList.Create;
Result := FPickList;
end;
function TbsColumn.GetReadOnly: Boolean;
begin
if cvReadOnly in FAssignedValues then
Result := FReadOnly
else
Result := DefaultReadOnly;
end;
function TbsColumn.GetShowing: Boolean;
var
Col: TbsColumn;
begin
Result := not Expanded and Visible;
if Result then
begin
Col := Self;
repeat
Col := Col.ParentColumn;
until (Col = nil) or not Col.Expanded;
Result := Col = nil;
end;
end;
function TbsColumn.GetVisible: Boolean;
var
Col: TbsColumn;
begin
Result := FVisible;
if Result then
begin
Col := ParentColumn;
Result := Result and ((Col = nil) or Col.Visible);
end;
end;
function TbsColumn.GetWidth: Integer;
begin
if not Showing then
Result := -1
else if cvWidth in FAssignedValues then
Result := FWidth
else
Result := DefaultWidth;
end;
function TbsColumn.IsAlignmentStored: Boolean;
begin
Result := (cvAlignment in FAssignedValues) and (FAlignment <> DefaultAlignment);
end;
function TbsColumn.IsColorStored: Boolean;
begin
Result := (cvColor in FAssignedValues) and (FColor <> DefaultColor);
end;
function TbsColumn.IsFontStored: Boolean;
begin
Result := (cvFont in FAssignedValues);
end;
function TbsColumn.IsImeModeStored: Boolean;
begin
Result := (cvImeMode in FAssignedValues) and (FImeMode <> DefaultImeMode);
end;
function TbsColumn.IsImeNameStored: Boolean;
begin
Result := (cvImeName in FAssignedValues) and (FImeName <> DefaultImeName);
end;
function TbsColumn.IsReadOnlyStored: Boolean;
begin
Result := (cvReadOnly in FAssignedValues) and (FReadOnly <> DefaultReadOnly);
end;
function TbsColumn.IsWidthStored: Boolean;
begin
Result := (cvWidth in FAssignedValues) and (FWidth <> DefaultWidth);
end;
procedure TbsColumn.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 TbsColumn.RestoreDefaults;
var
FontAssigned: Boolean;
begin
FontAssigned := cvFont in FAssignedValues;
FTitle.RestoreDefaults;
FAssignedValues := [];
RefreshDefaultFont;
FPickList.Free;
FPickList := nil;
ButtonStyle := cbsAuto;
Changed(FontAssigned);
end;
procedure TbsColumn.SetAlignment(Value: TAlignment);
var
Grid: TbsSkinCustomDBGrid;
begin
if IsStored then
begin
if (cvAlignment in FAssignedValues) and (Value = FAlignment) then Exit;
FAlignment := Value;
Include(FAssignedValues, cvAlignment);
Changed(False);
end
else
begin
Grid := GetGrid;
if Assigned(Grid) and (Grid.Datalink.Active) and Assigned(Field) then
Field.Alignment := Value;
end;
end;
procedure TbsColumn.SetButtonStyle(Value: TbsColumnButtonStyle);
begin
if Value = FButtonStyle then Exit;
FButtonStyle := Value;
Changed(False);
end;
procedure TbsColumn.SetColor(Value: TColor);
begin
if (cvColor in FAssignedValues) and (Value = FColor) then Exit;
FColor := Value;
Include(FAssignedValues, cvColor);
Changed(False);
end;
procedure TbsColumn.SetField(Value: TField);
begin
if FField = Value then Exit;
if Assigned(FField) and
(GetGrid <> nil) then
FField.RemoveFreeNotification(GetGrid);
FField := Value;
if Assigned(Value) then
begin
if GetGrid <> nil then
FField.FreeNotification(GetGrid);
FFieldName := Value.FullName;
end;
if not IsStored then
begin
if Value = nil then
FFieldName := '';
RestoreDefaults;
end;
Changed(False);
end;
procedure TbsColumn.SetFieldName(const Value: String);
var
AField: TField;
Grid: TbsSkinCustomDBGrid;
begin
AField := nil;
Grid := GetGrid;
if Assigned(Grid) and Assigned(Grid.DataLink.DataSet) and
not (csLoading in Grid.ComponentState) and (Length(Value) > 0) then
AField := Grid.DataLink.DataSet.FindField(Value); { no exceptions }
FFieldName := Value;
SetField(AField);
Changed(False);
end;
procedure TbsColumn.SetFont(Value: TFont);
begin
FFont.Assign(Value);
Include(FAssignedValues, cvFont);
Changed(False);
end;
procedure TbsColumn.SetImeMode(Value: TImeMode);
begin
if (cvImeMode in FAssignedValues) or (Value <> DefaultImeMode) then
begin
FImeMode := Value;
Include(FAssignedValues, cvImeMode);
end;
Changed(False);
end;
procedure TbsColumn.SetImeName(Value: TImeName);
begin
if (cvImeName in FAssignedValues) or (Value <> DefaultImeName) then
begin
FImeName := Value;
Include(FAssignedValues, cvImeName);
end;
Changed(False);
end;
procedure TbsColumn.SetIndex(Value: Integer);
var
Grid: TbsSkinCustomDBGrid;
Fld: TField;
I, OldIndex: Integer;
Col: TbsColumn;
begin
OldIndex := Index;
Grid := GetGrid;
if IsStored then
begin
Grid.BeginLayout;
try
I := OldIndex + 1; // move child columns along with parent
while (I < Collection.Count) and (TbsColumn(Collection.Items[I]).ParentColumn = Self) do
Inc(I);
Dec(I);
if OldIndex > Value then // column moving left
begin
while I > OldIndex do
begin
Collection.Items[I].Index := Value;
Inc(OldIndex);
end;
inherited SetIndex(Value);
end
else
begin
inherited SetIndex(Value);
while I > OldIndex do
begin
Collection.Items[OldIndex].Index := Value;
Dec(I);
end;
end;
finally
Grid.EndLayout;
end;
end
else
begin
if (Grid <> nil) and Grid.Datalink.Active then
begin
if Grid.AcquireLayoutLock then
try
Col := Grid.ColumnAtDepth(Grid.Columns[Value], Depth);
if (Col <> nil) then
begin
Fld := Col.Field;
if Assigned(Fld) then
Field.Index := Fld.Index;
end;
finally
Grid.EndLayout;
end;
end;
inherited SetIndex(Value);
end;
end;
procedure TbsColumn.SetPickList(Value: TStrings);
begin
if Value = nil then
begin
FPickList.Free;
FPickList := nil;
Exit;
end;
PickList.Assign(Value);
end;
procedure TbsColumn.SetPopupMenu(Value: TPopupMenu);
begin
FPopupMenu := Value;
if Value <> nil then Value.FreeNotification(GetGrid);
end;
procedure TbsColumn.SetReadOnly(Value: Boolean);
var
Grid: TbsSkinCustomDBGrid;
begin
Grid := GetGrid;
if not IsStored and Assigned(Grid) and Grid.Datalink.Active and Assigned(Field) then
Field.ReadOnly := Value
else
begin
if (cvReadOnly in FAssignedValues) and (Value = FReadOnly) then Exit;
FReadOnly := Value;
Include(FAssignedValues, cvReadOnly);
Changed(False);
end;
end;
procedure TbsColumn.SetTitle(Value: TbsColumnTitle);
begin
FTitle.Assign(Value);
end;
procedure TbsColumn.SetWidth(Value: Integer);
var
Grid: TbsSkinCustomDBGrid;
TM: TTextMetric;
DoSetWidth: Boolean;
begin
DoSetWidth := IsStored;
if not DoSetWidth then
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 FAssignedValues) then
DoSetWidth := True;
end
else
DoSetWidth := True;
end;
if DoSetWidth then
begin
if ((cvWidth in FAssignedValues) or (Value <> DefaultWidth))
and (Value <> -1) then
begin
FWidth := Value;
Include(FAssignedValues, cvWidth);
end;
Changed(False);
end;
end;
procedure TbsColumn.SetVisible(Value: Boolean);
begin
if Value <> FVisible then
begin
FVisible := Value;
Changed(True);
end;
end;
procedure TbsColumn.SetExpanded(Value: Boolean);
const
Direction: array [Boolean] of ShortInt = (-1,1);
var
Grid: TbsSkinCustomDBGrid;
WasShowing: Boolean;
begin
if Value <> FExpanded then
begin
Grid := GetGrid;
WasShowing := (Grid <> nil) and Grid.Columns[Grid.SelectedIndex].Showing;
FExpanded := Value;
Changed(True);
if (Grid <> nil) and WasShowing then
begin
if not Grid.Columns[Grid.SelectedIndex].Showing then
// The selected cell was hidden by this expand operation
// Select 1st child (next col = 1) when parent is expanded
// Select child's parent (prev col = -1) when parent is collapsed
Grid.MoveCol(Grid.Col, Direction[FExpanded]);
end;
end;
end;
function TbsColumn.Depth: Integer;
var
Col: TbsColumn;
begin
Result := 0;
Col := ParentColumn;
if Col <> nil then Result := Col.Depth + 1;
end;
function TbsColumn.GetExpandable: Boolean;
var
Fld: TField;
begin
Fld := Field;
Result := (Fld <> nil) and (Fld.DataType in [ftADT, ftArray]);
end;
{ TbsDBGridColumns }
constructor TbsDBGridColumns.Create(Grid: TbsSkinCustomDBGrid; ColumnClass: TbsColumnClass);
begin
inherited Create(ColumnClass);
FGrid := Grid;
end;
function TbsDBGridColumns.Add: TbsColumn;
begin
Result := TbsColumn(inherited Add);
end;
function TbsDBGridColumns.GetColumn(Index: Integer): TbsColumn;
begin
Result := TbsColumn(inherited Items[Index]);
end;
function TbsDBGridColumns.GetOwner: TPersistent;
begin
Result := FGrid;
end;
procedure TbsDBGridColumns.LoadFromFile(const Filename: string);
var
S: TFileStream;
begin
S := TFileStream.Create(Filename, fmOpenRead);
try
LoadFromStream(S);
finally
S.Free;
end;
end;
type
TbsColumnsWrapper = class(TComponent)
private
FColumns: TbsDBGridColumns;
published
property Columns: TbsDBGridColumns read FColumns write FColumns;
end;
procedure TbsDBGridColumns.LoadFromStream(S: TStream);
var
Wrapper: TbsColumnsWrapper;
begin
Wrapper := TbsColumnsWrapper.Create(nil);
try
Wrapper.Columns := FGrid.CreateColumns;
S.ReadComponent(Wrapper);
Assign(Wrapper.Columns);
finally
Wrapper.Columns.Free;
Wrapper.Free;
end;
end;
procedure TbsDBGridColumns.RestoreDefaults;
var
I: Integer;
begin
BeginUpdate;
try
for I := 0 to Count-1 do
Items[I].RestoreDefaults;
finally
EndUpdate;
end;
end;
procedure TbsDBGridColumns.RebuildColumns;
procedure AddFields(Fields: TFields; Depth: Integer);
var
I: Integer;
begin
Inc(Depth);
for I := 0 to Fields.Count-1 do
begin
Add.FieldName := Fields[I].FullName;
if Fields[I].DataType in [ftADT, ftArray] then
AddFields((Fields[I] as TObjectField).Fields, Depth);
end;
end;
begin
if Assigned(FGrid) and Assigned(FGrid.DataSource) and
Assigned(FGrid.Datasource.Dataset) then
begin
FGrid.BeginLayout;
try
Clear;
AddFields(FGrid.Datasource.Dataset.Fields, 0);
finally
FGrid.EndLayout;
end
end
else
Clear;
end;
procedure TbsDBGridColumns.SaveToFile(const Filename: string);
var
S: TStream;
begin
S := TFileStream.Create(Filename, fmCreate);
try
SaveToStream(S);
finally
S.Free;
end;
end;
procedure TbsDBGridColumns.SaveToStream(S: TStream);
var
Wrapper: TbsColumnsWrapper;
begin
Wrapper := TbsColumnsWrapper.Create(nil);
try
Wrapper.Columns := Self;
S.WriteComponent(Wrapper);
finally
Wrapper.Free;
end;
end;
procedure TbsDBGridColumns.SetColumn(Index: Integer; Value: TbsColumn);
begin
Items[Index].Assign(Value);
end;
procedure TbsDBGridColumns.SetState(NewState: TbsDBGridColumnsState);
begin
if NewState = State then Exit;
if NewState = csDefault then
Clear
else
RebuildColumns;
end;
procedure TbsDBGridColumns.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);
FGrid.InvalidateCol(Raw);
FGrid.ColWidths[Raw] := TbsColumn(Item).Width;
end;
end;
function TbsDBGridColumns.InternalAdd: TbsColumn;
begin
Result := Add;
Result.IsStored := False;
end;
function TbsDBGridColumns.GetState: TbsDBGridColumnsState;
begin
Result := TbsDBGridColumnsState((Count > 0) and Items[0].IsStored);
end;
{ TbsBookmarkList }
constructor TbsBookmarkList.Create(AGrid: TbsSkinCustomDBGrid);
begin
inherited Create;
FList := TStringList.Create;
FList.OnChange := StringsChanged;
FGrid := AGrid;
end;
destructor TbsBookmarkList.Destroy;
begin
Clear;
FList.Free;
inherited Destroy;
end;
procedure TbsBookmarkList.Clear;
begin
if FList.Count = 0 then Exit;
FList.Clear;
FGrid.Invalidate;
end;
function TbsBookmarkList.Compare(const Item1, Item2: TBookmarkStr): Integer;
begin
with FGrid.Datalink.Datasource.Dataset do
Result := CompareBookmarks(TBookmark(Item1), TBookmark(Item2));
end;
function TbsBookmarkList.CurrentRow: TBookmarkStr;
begin
if not FLinkActive then RaiseGridError(sDataSetClosed);
Result := FGrid.Datalink.Datasource.Dataset.Bookmark;
end;
function TbsBookmarkList.GetCurrentRowSelected: Boolean;
var
Index: Integer;
begin
Result := Find(CurrentRow, Index);
end;
function TbsBookmarkList.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;
Index := L;
FCache := Item;
FCacheIndex := Index;
FCacheFind := Result;
end;
function TbsBookmarkList.GetCount: Integer;
begin
Result := FList.Count;
end;
function TbsBookmarkList.GetItem(Index: Integer): TBookmarkStr;
begin
Result := FList[Index];
end;
function TbsBookmarkList.IndexOf(const Item: TBookmarkStr): Integer;
begin
if not Find(Item, Result) then
Result := -1;
end;
procedure TbsBookmarkList.LinkActive(Value: Boolean);
begin
Clear;
FLinkActive := Value;
end;
procedure TbsBookmarkList.Delete;
var
I: Integer;