Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001

Выберите пункт меню File|New Application. Щелкните правой кнопкой мыши на форме (Form1) и выберите View As Text. Скопируйте приведенный ниже исходный код формы GridU1 в Form1. Щелкните правой кнопкой мыши на форме и выберите View As Form. Убедитесь в активности ваших таблиц. Скопируйте расположенный ниже модуль GridU1 в ваш модуль Unit1.

Выберите пункт меню File|Save Project As. Сохраните модуль как GridU1.pas. Сохраните проект как GridProj.dpr.

Теперь запустите проект и наслаждайтесь функцией Drag and Drop между двумя табличными сетками.

unitMyDBGrid;

interface

usesWindows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids;

typeTMyDBGrid = class(TDBGrid)

private

{ Private declarations }

FOnMouseDown: TMouseEvent;

protected

{ Protected declarations }

procedureMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

published

{ Published declarations }

propertyRow;

propertyOnMouseDown readFOnMouseDown writeFOnMouseDown;

end;

procedure Register;

implementation

procedureTMyDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

ifAssigned(FOnMouseDown) thenFOnMouseDown(Self, Button, Shift, X, Y);

inheritedMouseDown(Button, Shift, X, Y);

end;

procedure Register;

begin

RegisterComponents('Samples', [TMyDBGrid]);

end;

end.

unitGridU1;

interface

usesWindows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Db, DBTables, Grids, DBGrids, MyDBGrid, StdCtrls;

typeTForm1 = class(TForm)

MyDBGrid1: TMyDBGrid;

Table1: TTable;

DataSource1: TDataSource;

Table2: TTable;

DataSource2: TDataSource;

MyDBGrid2: TMyDBGrid;

procedureMyDBGrid1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

procedureMyDBGrid1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; varAccept: Boolean);

procedureMyDBGrid1DragDrop(Sender, Source: TObject; X, Y: Integer);

private

{ Private declarations }

public

{ Public declarations }

end;

varForm1: TForm1;

implementation

{$R *.DFM}

varSGC : TGridCoord;

procedureTForm1.MyDBGrid1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

varDG : TMyDBGrid;

begin

DG := Sender asTMyDBGrid;

SGC := DG.MouseCoord(X,Y);

if(SGC.X > 0) and(SGC.Y > 0) then(Sender asTMyDBGrid).BeginDrag(False);

end;

procedureTForm1.MyDBGrid1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; varAccept: Boolean);

varGC : TGridCoord;

begin

GC := (Sender asTMyDBGrid).MouseCoord(X,Y);

Accept := Source isTMyDBGrid and(GC.X > 0) and(GC.Y > 0);

end;

procedureTForm1.MyDBGrid1DragDrop(Sender, Source: TObject; X, Y: Integer);

var

DG : TMyDBGrid;

GC : TGridCoord;

CurRow : Integer;

begin

DG := Sender asTMyDBGrid;

GC := DG.MouseCoord(X,Y);

withDG.DataSource.DataSet do begin

with(Source asTMyDBGrid).DataSource.DataSet do

Caption := 'Вы перетащили «'+Fields[SGC.X-1].AsString+'"';

DisableControls;

CurRow := DG.Row;

MoveBy(GC.Y-CurRow);

Caption := Caption+' в «'+Fields[GC.X-1].AsString+'"';

MoveBy(CurRow-GC.Y);

EnableControls;

end;

end;

end.

objectForm1: TForm1

Left = 200

Top = 108

Width = 544

Height = 437

Caption = 'Form1'

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

PixelsPerInch = 96

TextHeight = 13

objectMyDBGrid1: TMyDBGrid

Left = 8

Top = 8

Width = 521

Height = 193

DataSource = DataSource1

Row = 1

TabOrder = 0

TitleFont.Charset = DEFAULT_CHARSET

TitleFont.Color = clWindowTextTitle

Font.Height = -11

TitleFont.Name = 'MS Sans Serif'

TitleFont.Style = []

OnDragDrop = MyDBGrid1DragDrop

OnDragOver = MyDBGrid1DragOver

OnMouseDown = MyDBGrid1MouseDown

end

objectMyDBGrid2: TMyDBGrid

Left = 7

Top = 208

Width = 521

Height = 193

DataSource = DataSource2

Row = 1

TabOrder = 1

TitleFont.Charset = DEFAULT_CHARSET

TitleFont.Color = clWindowText

TitleFont.Height = -11

TitleFont.Name = 'MS Sans Serif'

TitleFont.Style = []

OnDragDrop = MyDBGrid1DragDrop

OnDragOver = MyDBGrid1DragOver

OnMouseDown = MyDBGrid1MouseDown

end

objectTable1: TTableActive = True

DatabaseName = 'DBDEMOS'

TableName = 'ORDERS'

Left = 104

Top = 48

end

objectDataSource1: TDataSource

DataSet = Table1

Left = 136

Top = 48

end

objectTable2: TTable

Active = True

DatabaseName = 'DBDEMOS'

TableName = 'CUSTOMER'

Left = 104

Top = 240

end

objectDataSource2: TDataSource

DataSet = Table2

Left = 136

Top = 240

end

end

Nomadicсоветует:

Кyсочек кода, чтобы повесить на clickable столбец RxGrid, показывающий RxQuery с определенным макросом %Order. Работать не бyдет (без модyлей), но в качестве идеи может быть полезен.

unitvgRXutil;

interface

usesSysUtils, Classes, DB, DBTables, rxLookup, RxQuery;

{ TrxDBLookup }

procedureRefreshRXLookup(Lookup: TrxLookupControl);

procedureRefreshRXLookupLookupSource(Lookup: TrxLookupControl);

functionRxLookupValueInteger(Lookup: TrxLookupControl): Integer;

{ TRxQuery }

{ Applicatable to SQL's without SELECT * syntax }

{ Inserts FieldName into first position in '%Order' macro and refreshes query }

procedureHandleOrderMacro(Query: TRxQuery; Field: TField);

{ Sets '%Order' macro, if defined, and refreshes query }

procedureInsertOrderBy(Query: TRxQuery; NewOrder: String);

{ Converts list of order fields if defined and refreshes query }

procedureUpdateOrderFields(Query: TQuery; OrderFields: TStrings);

implementation

usesvgUtils, vgDBUtl, vgBDEUtl;

{ TrxDBLookup refresh }

typeTRXLookupControlHack = class(TrxLookupControl)

propertyDataSource;

propertyLookupSource;

propertyValue;

propertyEmptyValue;

end;

procedureRefreshRXLookup(Lookup: TrxLookupControl);

varSaveField: String;

begin

withTRXLookupControlHack(Lookup) do begin

SaveField := DataField;

DataField := '';

DataField := SaveField;

end;

end;

procedureRefreshRXLookupLookupSource(Lookup: TrxLookupControl);