让你的dbgrid竖着站（1）_delphi教程-IDC资讯中心

{
File Name…….: DBVGrids.zip
File Description: Implementation of a Vertical DBGrid based on Vcls DBGrids.pas.
Targets………: Delphi 3.
Author Name…..: George Vavoylogiannis
EMail………..: georgev@hol.gr
WEB………….: http://users.hol.gr/~georgev
File Status…..: Freeware
Category……..: 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 Greece i started changing the code and finally
a TRUE VERTICAL DBGRID component is what we have here.

I wonder why Borland didt 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 titles width.

NOTE: because all the code is duplicated from the VCL, all the classes are
redefined (TColumn, TDBGridColumns, TGridDatalink e.t.c).
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 if someone finds a
way to solve it or even has property editor for the columns please drop me
an E-Mail.

Free to use and redistribute, but my name must
appear somewhere in the source code, or in the software.
No warranty is given by the author, expressed or implied.

WARNING! THE CODE IS PROVIDED AS IS WITH NO GUARANTEES OF ANY KIND!
USE THIS AT YOUR OWN RISK – YOU ARE THE ONLY PERSON RESPONSIBLE FOR
ANY DAMAGE THIS CODE MAY CAUSE – YOU HAVE BEEN WARNED!

}
{**********************************************************************************}

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
ColumnTitleValues = [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 RestoreDefaults; virtual;
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, cbsNone);

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;
    function 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;
    procedure SetTitle(Value: TColumnTitle);
    procedure SetWidth(Value: Integer); virtual;
protected
    function CreateTitle: TColumnTitle; virtual;
    function GetGrid: TCustomVDBGrid;
    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 read GetWidth write SetWidth stored IsWidthStored;
end;

TColumnClass = class of TColumn;

TDBGridColumnsState = (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;
end;

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;
    property FieldCount: Integer read FFieldCount;
    property Fields[I: Integer]: TField read GetFields;
    property SparseMap: Boolean read FSparseMap write FSparseMap;
end;

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: Integer 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, dgCancelOnExit, dgMultiSelect);
TDBGridOptions = set of TDBGridOption;

{ The VDBGrids DrawDataCell virtual method and OnDrawDataCell event are only
    called when the grids Columns.State is csDefault. This is for compatibility
    with existing code. These routines dont provide sufficient information to
    determine which column is being drawn, so the column attributes arent
    easily accessible in these routines. Column attributes also introduce the
    possibility that a columns 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 VDBGrids 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 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: 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 CanEditModify: Boolean; override;
    function CanEditShow: 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;
    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 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, dgTitles, dgIndicator, 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 write 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 OnDblClick;
    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 EInvalidGridOperation.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 return
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;

{ 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, esEllipsis, esPickList, esDataList);
TPopupListbox = 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(Owner: TComponent); 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;
end;

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 TPopupListbox.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);
end;

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 < Width) and (Y < Height));
end;

constructor TVDBGridInplaceEdit.Create(Owner: TComponent);
begin
inherited Create(Owner);
FLookupSource := TDataSource.Create(Self);
FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
FEditStyle := esSimple;
end;

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 then
SetImeCompositionWindow(Font, R.Left, R.Top);
end;

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 then
          begin
            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;
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
    begin
      FPickList.Color := Color;
      FPickList.Font := Font;
      FPickList.Items := Column.Picklist;
      if FPickList.Items.Count >= Column.DropDownRows then
        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 := P.Y + Height;
    if Y + FActiveList.Height > Screen.Height then Y := P.Y – FActiveList.Height;
    SetWindowPos(FActiveList.Handle, HWND_TOP, P.X, 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);
end
else
    inherited KeyDown(Key, Shift);
end;

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 (FEditStyle = esEllipsis) and WasPressed then
TCustomVDBGrid(Grid).EditButtonClick;
inherited MouseUp(Button, Shift, X, Y);
end;

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);
end;

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 TVDBGridInplaceEdit.StopTracking;
begin
if FTracking then
begin
    TrackButton(-1, -1);
    FTracking := False;
    MouseCapture := False;
end;
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 then
begin
FPressed := NewState;
InvalidateRect(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 then
               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) then
CloseUp(False);
end;

procedure TVDBGridInplaceEdit.WMCancelMode(var Message: TMessage);
begin
StopTracking;
inherited;
end;

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;
end;

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 then
        begin
          with TMessage(Message) do
            SendMessage(FActiveList.Handle, Msg, WParam, LParam);
          Exit;
        end;
      end
end;
inherited;
end;

{ TGridDataLink }

type
TIntArray = array[0..MaxMapSize] of Integer;
PIntArray = ^TIntArray;

constructor TGridDataLink.Create(AGrid: TCustomVDBGrid);
begin
inherited Create;
FGrid := AGrid;
end;

destructor TGridDataLink.Destroy;
begin
ClearMapping;
inherited Destroy;
end;

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 < FFieldCount) and (PIntArray(FFieldMap)^[I] >= 0) then
Result := DataSet.Fields[PIntArray(FFieldMap)^[I]]
else
Result := nil;
end;

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 < FFieldCount) then
      NewSize := FFieldCount + 1;
    if (NewSize > MaxMapSize) then
      NewSize := MaxMapSize;
    ReallocMem(FFieldMap, NewSize * SizeOf(Integer));
    FFieldMapSize := NewSize;
end;
if Assigned(Field) then
begin
    PIntArray(FFieldMap)^[FFieldCount] := Field.Index;
    Field.FreeNotification(FGrid);
end
else
    PIntArray(FFieldMap)^[FFieldCount] := -1;
Inc(FFieldCount);
end;

procedure TGridDataLink.ActiveChanged;
begin
FGrid.LinkActive(Active);
end;

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;
end;

procedure TGridDataLink.DataSetChanged;
begin
FGrid.DataChanged;
FModified := False;
end;

procedure TGridDataLink.DataSetScrolled(Distance: Integer);
begin
FGrid.Scroll(Distance);
end;

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;
end;

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;
end;
end;

procedure TGridDataLink.EditingChanged;
begin
FGrid.EditingChanged;
end;

procedure TGridDataLink.RecordChanged(Field: TField);
begin
FGrid.RecordChanged(Field);
FModified := False;
end;

procedure TGridDataLink.UpdateData;
begin
FInUpdateData := True;
try
    if FModified then FGrid.UpdateData;
    FModified := False;
finally
    FInUpdateData := False;
end;
end;

function TGridDataLink.GetMappedIndex(ColIndex: Integer): Integer;
begin
if (0 <= ColIndex) and (ColIndex < FFieldCount) then
Result := PIntArray(FFieldMap)^[ColIndex]
else
Result := -1;
end;

procedure TGridDataLink.Reset;
begin
if FModified then RecordChanged(nil) else Dataset.Cancel;
end;

{ TColumnTitle }
constructor TColumnTitle.Create(Column: TColumn);
begin
inherited Create;
FColumn := Column;
FFont := TFont.Create;
FFont.Assign(DefaultFont);
FFont.OnChange := FontChanged;
end;

destructor TColumnTitle.Destroy;
begin
FFont.Free;
inherited Destroy;
end;

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);
end;

function TColumnTitle.DefaultAlignment: TAlignment;
begin
Result := taLeftJustify;
end;

function TColumnTitle.DefaultColor: TColor;
var
Grid: TCustomVDBGrid;
begin
Grid := FColumn.GetGrid;
if Assigned(Grid) then
Result := Grid.FixedColor
else
Result := clBtnFace;
end;

function TColumnTitle.DefaultFont: 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.FAssignedValues, cvTitleFont);
FColumn.Changed(True);
end;

function TColumnTitle.GetAlignment: TAlignment;
begin
if cvTitleAlignment in FColumn.FAssignedValues then
Result := FAlignment
else
Result := DefaultAlignment;
end;

function TColumnTitle.GetCo

让你的dbgrid竖着站（1）_delphi教程

相关推荐

热门标签

热门文章

分类目录