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

• Название: Советы по Delphi. Версия 1.4.3 от 1.1.2001
• Автор: Валентин Озеров
• Жанр: Программирование

…начиная с 1001. Смотрите другие файлы…

---

 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.

Форма GridU1

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