DBGridの境界線クリックについて。 (ID:42470)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

ソースの必要のない部分の削除しました。
バグもありましたので、修正しました。
Mr.XRAY様のサブクラスを使わさせていただいていますが、
コピーして、作成しただけで、
内容は、よく理解していません。
間違っている箇所がありましたら、
お手数ですが、ご指摘をお願いいたします。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DB, DBTables, Grids, DBGrids,SubClassUnit,ExtCtrls,StdCtrls;

type
  TForm1 = class(TForm)
    DBGrid1: TDBGrid;
    Table1: TTable;
    DataSource1: TDataSource;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure DBGrid1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure DBGrid1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure DBGrid1TitleClick(Column: TColumn);
  private
    { Private 宣言 }
    RowHeight: Integer;
    SubClass2: TSubClass;
    procedure SubClass2MessageAfter(Sender: TObject;      var message: TMessage);
    function ColumMatchWidth(AFieldName: String): Integer;
  public
    { 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';
  Table1.Open;
  // 常に編集モード
  DBGrid1.Options := DBGrid1.Options + [dgAlwaysShowEditor];
  // サブクラスの設定 - MouseDownの取得だけ
  SubClass2:= TSubClass.Create(Self);
  SubClass2.TargetControl := DBGrid1;
  SubClass2.OnMessageAfter := SubClass2MessageAfter;
  // 行の高さ
  RowHeight := TDummyDBGrid(DBGrid1).DefaultRowHeight;

end;

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

var
  AX: Integer =0;
  IsBoundaryLine: Boolean = False;
  IsColumnMoving: Boolean = False;

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

procedure TForm1.DBGrid1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  IsColumnMoving := False;
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
          IsBoundaryLine:=True;
        end;
      end;
  end;
end;

procedure TForm1.DBGrid1TitleClick(Column: TColumn);
var
  Pos : TPoint;
  ACOl,ARow: Integer;
  dwPos: DWORD;
begin
  if IsBoundaryLine then
  begin
    //Column.FieldNameをつかうと境界線の右のFieldのときもある
    // イベントが発生したマウスカーソルの位置を取得
    dwPos := GetMessagePos;
    Pos := DBGrid1.ScreenToClient(Point(LoWORD(dwPos), HiWORD(dwPos)));
    // MouseToCell を使うために DBGrid を TDrawGrid にキャストします
    //少し左にずらす
    Pos.X := Pos.X -10;
    TDrawGrid(DBGrid1).MouseToCell(Pos.X, Pos.Y, ACol, ARow);
    //ShowMessage(Format('%d %d',[ACol,Arow]));
    DBGrid1.Columns[ACol-1].Width := ColumMatchWidth(DBGrid1.Columns[ACol-1].FieldName);
  end;
  IsBoundaryLine:=False;

end;

//最大長を求める
function TForm1.ColumMatchWidth(AFieldName: String): Integer;
var
  MaxWidth: Integer;
  AWidth: Integer;
begin
  with Table1 do
  begin
    try
      DisableControls;
      First;
      MaxWidth := 0;
      while not Eof do
      begin
        AWidth := Canvas.TextWidth(Trim(FieldByName(AFieldName).AsString));
        if MaxWidth < AWidth then
          MaxWidth := AWidth;
        Next;
      end;
      First;
    finally
      EnableControls;
    end;
  end;
  //少し短くなってしまうのでプラス
  Result := MaxWidth + 5;
end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る