Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001
procedure MyDBGrid1DragDrop(Sender, Source: TObject; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
var SGC : TGridCoord;
procedure TForm1.MyDBGrid1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var DG : TMyDBGrid;
begin
DG := Sender as TMyDBGrid;
SGC := DG.MouseCoord(X,Y);
if (SGC.X > 0) and (SGC.Y > 0) then (Sender as TMyDBGrid).BeginDrag(False);
end;
procedure TForm1.MyDBGrid1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
var GC : TGridCoord;
begin
GC := (Sender as TMyDBGrid).MouseCoord(X,Y);
Accept := Source is TMyDBGrid and (GC.X > 0) and (GC.Y > 0);
end;
procedure TForm1.MyDBGrid1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
DG : TMyDBGrid;
GC : TGridCoord;
CurRow : Integer;
begin
DG := Sender as TMyDBGrid;
GC := DG.MouseCoord(X,Y);
with DG.DataSource.DataSet do begin
with (Source as TMyDBGrid).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.
Форма GridU1object Form1: 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
object MyDBGrid1: 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
object MyDBGrid2: 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
object Table1: TTableActive = True
DatabaseName = 'DBDEMOS'
TableName = 'ORDERS'
Left = 104
Top = 48
end
object DataSource1: TDataSource
DataSet = Table1
Left = 136
Top = 48
end
object Table2: TTable
Active = True
DatabaseName = 'DBDEMOS'
TableName = 'CUSTOMER'
Left = 104
Top = 240
end
object DataSource2: TDataSource
DataSet = Table2
Left = 136
Top = 240
end
end
Как заставить DBGrid сортировать данные по щелчку на заголовке столбца?
Nomadic советует:
Кyсочек кода, чтобы повесить на clickable столбец RxGrid, показывающий RxQuery с определенным макросом %Order. Работать не бyдет (без модyлей), но в качестве идеи может быть полезен.
unit vgRXutil;
interface
uses SysUtils, Classes, DB, DBTables, rxLookup, RxQuery;
{ TrxDBLookup }
procedure RefreshRXLookup(Lookup: TrxLookupControl);
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
{ TRxQuery }
{ Applicatable to SQL's without SELECT * syntax }
{ Inserts FieldName into first position in '%Order' macro and refreshes query }
procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
{ Sets '%Order' macro, if defined, and refreshes query }
procedure InsertOrderBy(Query: TRxQuery; NewOrder: String);
{ Converts list of order fields if defined and refreshes query }
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
implementation
uses vgUtils, vgDBUtl, vgBDEUtl;
{ TrxDBLookup refresh }
type TRXLookupControlHack = class(TrxLookupControl)
property DataSource;
property LookupSource;
property Value;
property EmptyValue;
end;
procedure RefreshRXLookup(Lookup: TrxLookupControl);
var SaveField: String;
begin
with TRXLookupControlHack(Lookup) do begin
SaveField := DataField;
DataField := '';
DataField := SaveField;
end;
end;
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
var SaveField: String;
begin
with TRXLookupControlHack(Lookup) do begin
SaveField := LookupDisplay;
LookupDisplay := '';
LookupDisplay := SaveField;
end;
end;
function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
begin
with TRXLookupControlHack(Lookup) do try
if Value <> EmptyValue then Result := StrToInt(Value)
else Result := 0;
except
Result := 0;
end;
end;
procedure InsertOrderBy(Query: TRxQuery; NewOrder: String);
var
Param: TParam;
OldActive: Boolean;
OldOrder: String;
Bmk: TPKBookMark;
begin
Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) then Exit;
OldOrder := Param.AsString;
if OldOrder <> NewOrder then begin
OldActive := Query.Active;
if OldActive then Bmk := GetPKBookmark(Query, '');
try
Query.Close;
Param.AsString := NewOrder;
try
Query.Prepare;
except
Param.AsString := OldOrder;
end;
Query.Active := OldActive;
if OldActive then SetToPKBookMark(Query, Bmk);
finally
if OldActive then FreePKBookmark(Bmk);
end;
end;
end;
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
var NewOrderFields: TStrings;
procedure AddOrderField(S: String);
begin
if NewOrderFields.IndexOf(S) < 0 then NewOrderFields.Add(S);
end;
var
I, J: Integer;
Field: TField;
FieldDef: TFieldDef;
S: String;
begin
NewOrderFields := TStringList.Create;
with Query do try
for I := 0 to OrderFields.Count - 1 do begin
S := OrderFields[I];
Field := FindField(S);
if Assigned(Field) and (Field.FieldNo > 0) then AddOrderField(IntToStr(Field.FieldNo))
else try
J := StrToInt(S);
if J < FieldDefs.Count then AddOrderField(IntToStr(J));
except
end;
end;
OrderFields.Assign(NewOrderFields);
finally
NewOrderFields.Free;
end;
end;
procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
var
Param: TParam;
Tmp, OldOrder, NewOrder: String;
I: Integer;
C: Char;
TmpField: TField;
OrderFields: TStrings;
begin
Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) or Field.Calculated or Field.Lookup then Exit;
