DBGridを同期させる。: Delphi-fan

DBGridを同期させる。

この時期、なぜ、XE2の新機能やFireMonkeyの試行錯誤をやらないの？と突っ込まれそうですが、古いプログラムの修正用にいろいろ調べて直しているからです(^-^)

図のように上下に配置したDBGridのタイトルの幅変更、移動、セルの移動そして横スクロールを同期させます。Excelのように上段のDBGridは横スクロールバー無し、下段のDBGridはタイトル無しとします。若干、問題が残っていますが、とりあえずは良しとしましょう。

設計時

Design

実行時

Runtime

問題点

１．上段DBGridの縦スクロールバーがタイトルの幅を変えたり、移動させたりすると
　　消えてしまいます。マウスでスクロールさせると再び表示されるのですけど、
　　見た目に統一感がないですね。

２．タイトル幅の変更時のラインを下段のDBGridでも描画しています。しかしタイト
　　ル間のクリック位置によって微妙にラインがずれることがあります。

３．カラム移動のラインまでは対応していません(^-^)

DBGridのOnMouseDownでは、タイトル間のクリックが拾えません。そのため、下段のDBGridへのタイトル幅変更時のライン描画用フラグがややこしくなっています。又、サブクラスには、いつものようにMr.XRAYさんところのコンポーネントを利用させて頂きました。

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Data.DB, Bde.DBTables, Vcl.ExtCtrls,
  Vcl.Grids, Vcl.DBGrids, SubClassUnit, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    DBGrid1: TDBGrid;
    DBGrid2: TDBGrid;
    Splitter1: TSplitter;
    Table1: TTable;
    Table2: TTable;
    DataSource1: TDataSource;
    DataSource2: TDataSource;
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure DBGrid1ColEnter(Sender: TObject);
    procedure DBGrid2ColEnter(Sender: TObject);
    procedure DBGrid1ColumnMoved(Sender: TObject; FromIndex, ToIndex: Integer);
    procedure DBGrid1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure DBGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure DBGrid1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormDestroy(Sender: TObject);
  private
    RowHeight: Integer;
    SubClass1: TSubClass;
    SubClass2: TSubClass;
    procedure SubClass1MessageAfter(Sender: TObject;
      var message: TMessage);
    procedure SubClass2MessageAfter(Sender: TObject;
      var message: TMessage);
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

type
  TDummyDBGrid = class(TCustomDBGrid);

// 初期設定
procedure TForm1.FormCreate(Sender: TObject);
begin
  // Tableの設定
  Table1.DatabaseName := 'DBDEMOS';
  Table1.TableName := 'country.db';
  Table2.DatabaseName := 'DBDEMOS';
  Table2.TableName := 'country.db';

  Table1.Open;
  Table2.Open;

  // 常に編集モード
  DBGrid1.Options := DBGrid1.Options + [dgAlwaysShowEditor];
  DBGrid2.Options := DBGrid2.Options + [dgAlwaysShowEditor] - [dgTitles];

  // 縦スクロールバーのみ表示させます。
  TDummyDBGrid(DBGrid1).ScrollBars := ssVertical;

  // サブクラスの設定
  SubClass1:= TSubClass.Create(Self);
  SubClass1.TargetControl := DBGrid2;
  SubClass1.OnMessageAfter := SubClass1MessageAfter;

  // サブクラスの設定 - MouseDownの取得だけ
  SubClass2:= TSubClass.Create(Self);
  SubClass2.TargetControl := DBGrid1;
  SubClass2.OnMessageAfter := SubClass2MessageAfter;

  // 行の高さ
  RowHeight := TDummyDBGrid(DBGrid1).DefaultRowHeight;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Table1.Close;
  Table2.Close;
end;

// サイズ変更時の処理
procedure TForm1.FormResize(Sender: TObject);
begin
  DBGrid1ColEnter(Self);
end;

// 起動時に強引に縦スクロールを表示させます。
procedure TForm1.FormShow(Sender: TObject);
begin
  // 縦スクロールバーを表示させるための処理
  // これをしないとマウスでスクロールさせるまで
  // スクロールバーが表示されません。
  SendMessage(DBGrid1.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
  SendMessage(DBGrid1.Handle, WM_VSCROLL, SB_LINEUP, 0);
end;

// カラムの同期
procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
  if (TDummyDBGrid(DBGrid2).LeftCol<> TDummyDBGrid(DBGrid1).LeftCol) then
    TDummyDBGrid(DBGrid2).LeftCol := TDummyDBGrid(DBGrid1).LeftCol;
end;

procedure TForm1.DBGrid2ColEnter(Sender: TObject);
begin
  if (TDummyDBGrid(DBGrid1).LeftCol<> TDummyDBGrid(DBGrid2).LeftCol) then
    TDummyDBGrid(DBGrid1).LeftCol := TDummyDBGrid(DBGrid2).LeftCol;
end;

procedure TForm1.DBGrid1ColumnMoved(Sender: TObject; FromIndex,
  ToIndex: Integer);
begin
  TDummyDBGrid(DBGrid2).ColumnMoved(FromIndex+1, ToIndex+1);
  {
  DBGrid2.Columns.BeginUpdate;
  try
    DBGrid2.Columns.Assign(DBGrid1.Columns);
  finally
    DBGrid2.Columns.EndUpdate;
  end;
  }
end;

var
  AX: Integer =0;
  Drawing: Boolean = False;
  IsFirstDrawing: Boolean = False;
  IsColumnMoving: Boolean = False;

procedure TForm1.DBGrid1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  // タイトル間のクリックは、ここでは取得できません。
  // タイトルのクリックは、取得できます。
  IsColumnMoving := True;
end;

// タイトル幅変更時のライン描画
procedure TForm1.DBGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  OldPen: TPen;
begin
  if Drawing then
  begin
    OldPen := TPen.Create;
    try
      with DBGrid2.Canvas do
      begin
        OldPen.Assign(Pen);
        try
          Pen.Style := psDot;
          Pen.Mode := pmXor;
          Pen.Width := 1;

          if not IsFirstDrawing then
          begin
            // 一度目はこの処理をさせません。
            MoveTo(AX, 0);
            LineTo(AX, 0 + DBGrid2.Height);
          end
          else if IsFirstDrawing then
            IsFirstDrawing := False;

          MoveTo(X, 0);
          LineTo(X, 0 + DBGrid2.Height);
          AX := X;
        finally
          Pen := OldPen;
        end;
      end;
    finally
      OldPen.Free;
    end;
  end;
end;


// カラム幅の同期 - DBGrid1のカラム幅の変更をDBGrid2に反映させます。
procedure TForm1.DBGrid1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  I: Integer;
  Cell: TGridCoord;
begin
  IsColumnMoving := False; // MouseDownでなければ常にOK
  Drawing := False;
  IsFirstDrawing := False;

  // カラム幅の同期
  // カラムをクリックされた場合のみチェックします。
  // 本来、Cell.Yは０が返されるべきですが、時々１が返ってきます。
  // そのためCell.Y in [0,1]としています。
  Cell := DBGrid1.MouseCoord(X, Y);
  if Cell.Y in [0,1] then
  begin
    for I := 0 to DBGrid1.Columns.Count -1 do
    begin
      if DBGrid2.Columns[I].Width <> DBGrid1.Columns[I].Width then
        DBGrid2.Columns[I].Width := DBGrid1.Columns[I].Width;
    end;
  end;
end;

// 横スクロールバーの同期 - DBGrid2の変更をDBGrid1に反映します。
procedure TForm1.SubClass1MessageAfter(Sender: TObject; var message: TMessage);
begin
  case Message.Msg of
    WM_HSCROLL: DBGrid1.Perform(Message.Msg, Message.WParam, Message.LParam);
  end;
end;

// こちらは単純にDBGrid1のMouseDownを取得しているだけです。
// カラム間のクリックは、DBGridのOnMouseDownでは取得できなかった。
procedure TForm1.SubClass2MessageAfter(Sender: TObject; var message: TMessage);
begin
  case Message.Msg of
    WM_LBUTTONDOWN:
      begin
        if (Message.LParamHi < RowHeight) and (not IsColumnMoving)  then
        begin
          Drawing := True;
          IsFirstDrawing:=True;
        end;
    end;
  end;
end;

end.

サブクラス用コンポーネント
Delphi Library [Mr.XRAY]
SubClassUnit
http://homepage2.nifty.com/Mr_XRAY/Halbow/Notes/N004.html

20111005追記

DBGrid1のMouseUp、FormResizeの処理を下記に入れ替えると、そこそこ希望の動作になりました。スクロールバーは表示されるもののUpdateScrollBarを通していないので、レコード数が反映されたものではないですけどね。まあ、見た目的には問題ないです。

// カラム幅の同期 - DBGrid1のカラム幅の変更をDBGrid2に反映させます。
procedure TForm1.DBGrid1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  I: Integer;
  Cell: TGridCoord;
begin
  IsFirstDrawing := False;

  // カラム移動の終了
  if IsColumnMoving then
  begin
    ShowScrollBar(DBGrid1.Handle, SB_VERT, True);
    IsColumnMoving := False;
    DBGrid1ColEnter(Self); // DBGrid2の横スクロールバーが動くから
  end;

  // カラム幅の同期
  if Drawing then
  begin
    Drawing := False; // カラム幅を変更－終了
    DBGrid2.Columns.BeginUpdate;
    try
      for I := 0 to DBGrid1.Columns.Count -1 do
      begin
        if DBGrid2.Columns[I].Width <> DBGrid1.Columns[I].Width then
          DBGrid2.Columns[I].Width := DBGrid1.Columns[I].Width;
      end;
    finally
      DBGrid2.Columns.EndUpdate;
      DBGrid1ColEnter(Self); // DBGrid2の横スクロールバーが動くから
    end;
    ShowScrollBar(DBGrid1.Handle, SB_VERT, True);
  end;
end;

// サイズ変更時の処理
procedure TForm1.FormResize(Sender: TObject);
begin
  DBGrid2ColEnter(Self);
  ShowScrollBar(DBGrid1.Handle, SB_VERT, True);
end;

2011.09.22 TDBGrid, XE2 | 固定リンク
Tweet

バックナンバー

お気に入り

AFsoft World
AFSoftさんのブログです。ホームページの方では、CADに必要な数学の解説からDelphiによる具体的な実装まで、豊富なサンプルと共に詳しく解説されています。又、JWW用の便利なソフトをたくさん公開しておられます。
Delphi Library [Mr.XRAY]
Excelの操作を始め、Delphiでのいろいろな処理を丁寧にわかりやすくまとめられておられます。又、Halbow資料館として、メーリングリストでもご活躍されたHalbowさんによるホームページ(Win32 API by Object Pascal of Delphi)を公開されておられます。
Embarcadero Blogs - Team Japan
Embarcaderoの日本人スタッフによるブログです。
Embarcadero日本語トップページ
ＤＥＫＯのアヤシいお部屋。
Unicodeに関する詳細な解説を始め「Delphi によるテクニック＆アルゴリズム」には、様々な情報が見やすくまとめられています。

@niftyが提供する
無料ブログはココログ！

Delphi-fan

カテゴリー

DBGridを同期させる。

最近の記事

バックナンバー

お気に入り

Delphi-fan

SyntaxHighlighter.config.bloggerMode = true; SyntaxHighlighter.all();

カテゴリー

DBGridを同期させる。

最近の記事

バックナンバー

お気に入り