Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2015年07月26日] [更新 2020年02月10日] Delphi サンプルプログラム集
071_TDBGrid のスクロールバーの表示制御
動作確認等 Windows 7 U64(SP1) + Delphi XE5(UP2) Pro VCL-32
BDE 5.2 + Paradox 7.0
071_TDBGrid_ScrollBar.zip [8,371 KB] 2020年02月10日版 (EXE 同梱)







TDBGrid のスクロールバーの表示制御


TDBGrid のスクロールバーの設定関係のサンプルです.

TDBGrid の published 部には,TStringGrid や TRichEdit のような,ScrollBars プロパティはありません.protected 部にはありますが,このプロパティでは,TStringGrid と同じようなスクロールバーの表示制御はできないようです.
TDBGrid に表示するデータがない場合は,スクロールバーは表示されません.クライアント領域の幅に列方向のデータが表示できなくなると,水平スクロールバーが現れます.垂直スクロールバーは,筆者の環境では,表示レコード数が 2 つ以上あると現れます.

本ページのサンプルは,TDBGrid の継承クラスを作成し,これらのスクロールバーを強制的に表示したり,非表示にします.
本ページのサンプルでは,継承クラスをコンポーネントとして登録 (インストール) しないで,主に [派生元のコンポーネントと交換する方法] で説明しているユニットを使用しています.



[備考]
本ページのサンプルでは,BDE と Paradox のサンプルデータを使用しています.
Delphi XE7 以降には BDE は実装されていません.必要であれば,BDE を別途入手するか,他のデータベースを利用してテストしてください.





01_TDBGrid のスクロールバーの表示と非表示を切り換え


TDBGrid の継承クラスを作成して,水平,垂直スクロールバーを常に表示または常に非表示するようにしたサンプルです.
Button1 のクリックで表示と非表示を切り換えるようにしています.

TDBGrid が生成または再生成されると RecreateWnd が実行されます.RecreateWnd は WM_NCCALCSIZE メッセージを発行します.このメッセージ処理内で表示スタイルを設定しています.
本サンプルでは,TDBGrid の継承クラスに HideScrollBars というプロパティを実装して,このプロパティの値を Button1 で切り換えるようにしています.




図1
設計時の画面
図2
実行開始画面
  • 水平スクロールバー,垂直スクロールバーが共に表示されている
図3
Button1 をクリック
  • スクロールバーが非表示となる

リスト1
TDBGrid のスクロールバーの表示と非表示を切り換え
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.Grids, Vcl.DBGrids, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TplDBGrid = class(TDBGrid)
  private
    FHideScrollBars : Boolean;
    procedure SetHideScrollBars(const Value: Boolean);
  protected
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
  public
    property HideScrollBars : Boolean read FHideScrollBars write SetHideScrollBars;
  end;

  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Panel1: TPanel;
    Query1: TQuery;
    Button1: TButton;
    DBGrid1: TDBGrid;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    plDBGrid1 : TplDBGrid;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  plChgCompo;

{$R *.DFM}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //フォーム作成時にコンポーネントの入れ替え
  plDBGrid1 := TplDBGrid(ChangeComponent(DBGrid1, TplDBGrid));

  Query1.Close;
  DataSource1.DataSet  := Query1;
  plDBGrid1.DataSource := DataSource1;

  // データベースからデータを取得して表示
  Query1.DatabaseName := 'DBDEMOS';
  Query1.SQL.Clear;
  Query1.SQL.Add('select CustNo, Company, City from customer.db where CustNo<=2000');
  Query1.Open;

  ActiveControl := plDBGrid1;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Query1.Close;
end;

//=============================================================================
//  TDBGridの継承クラスに実装したHideScrollBarsプロパティをトグル操作
//  HideScrollBarsがTrueだと水平,垂直スクロールバーは共に非表示(Hide)になる
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  plDBGrid1.HideScrollBars := not plDBGrid1.HideScrollBars;
end;

{ TplDBGrid }

//-----------------------------------------------------------------------------
//  TDBGridの継承クラスに実装したHideScrollBarsプロパティの設定メソッド
//  変更したらRecreateWndを実行する
//  RecreateWndを実行するとWM_NCCALCSIZEメッセージが発生する
//-----------------------------------------------------------------------------
procedure TplDBGrid.SetHideScrollBars(const Value: Boolean);
begin
  if FHideScrollBars <> Value then begin
    FHideScrollBars := Value;
    RecreateWnd;
  end;
end;

//=============================================================================
//  WM_NCCALCSIZEメッセージ処理
//  スクロールバー表示のフラグを強制的に変更
//=============================================================================
procedure TplDBGrid.WMNCCalcSize(var Message: TWMNCCalcSize);
var
  LStyle : Integer;
begin
  LStyle := GetWindowLong(Handle, GWL_STYLE);
  if FHideScrollBars then begin
    LStyle := LStyle and not WS_HSCROLL and not WS_VSCROLL;
  end else begin
    LStyle := LStyle or WS_HSCROLL or WS_VSCROLL;
  end;
  SetWindowLong(Handle, GWL_STYLE, LStyle);

  inherited;
end;

end.




02_TDBGrid のスクロールバーを常に表示して無効化機能を追加


TDBGrid の継承クラスを作成して,WM_NCCALCSIZE メッセージ処理内で強制的にスタイルを変更して,スクロールバーを常に表示するようにしたサンプルです.
データが TDBGrid のクライアント領域に全て表示されている場合は,スクロールバーの表示を無効化状態にするコードを追加しています.

このサンプルには,スクロールのページサイズ (スクロールバーのボックス・つまみ) のサイズを設定する機能を追加していました.その機能にはかなり無理があるため,現在は削除しています.その変わりに,スクロールの制御に TScrollBar コンポーネントを実装した TDBGrid コンポーネントを提供しています.




図4
実行開始画面
  • 列方向 (水平・横) スクロールバーが無効化の状態になっている

リスト2
TDBGrid のスクロールバーを常に表示して無効化機能を追加
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.Grids, Vcl.DBGrids, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TplDBGrid = class(TDBGrid)
  protected
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure Resize; override;
    procedure ColWidthsChanged; override;
    procedure RowHeightsChanged; override;
    procedure SizeChanged(OldColCount: Integer; OldRowCount: Integer); override;
  public
    procedure Available_Disable_ScrollBars;
  end;

  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Panel1: TPanel;
    Query1: TQuery;
    Button1: TButton;
    DBGrid1: TDBGrid;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    plDBGrid1 : TplDBGrid;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  plChgCompo;

{$R *.DFM}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //フォーム作成時にコンポーネントの入れ替え
  plDBGrid1 := TplDBGrid(ChangeComponent(DBGrid1, TplDBGrid));

  Query1.Close;
  DataSource1.DataSet  := Query1;
  plDBGrid1.DataSource := DataSource1;

  // データベースからデータを取得して表示
  Query1.DatabaseName := 'DBDEMOS';
  Query1.SQL.Clear;
  Query1.SQL.Add('select CustNo, Company, City from customer.db where CustNo<=3000');
  Query1.Open;

  ActiveControl := plDBGrid1;
  plDBGrid1.Resize;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Query1.Close;
end;

//=============================================================================
//  表示データ数が少なくなった場合の確認用
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  Query1.Close;
  Query1.DatabaseName := 'DBDEMOS';
  Query1.SQL.Clear;
  Query1.SQL.Add('select CustNo, Company, City from customer.db where CustNo<=1500');
  Query1.Open;
end;

{ TplDBGrid }

//-----------------------------------------------------------------------------
//  スクロールバーの無効化の設定
//  RecordCountが使用できない場合は制御できない
//-----------------------------------------------------------------------------
procedure TplDBGrid.Available_Disable_ScrollBars;
begin
  if Parent = nil then Exit;

  //Assignedとnilは違うので注意
  if not Assigned(DataSource) then exit;
  if DataSource.DataSet <> nil then begin
    if not DataSource.DataSet.Active then exit;
  end;

  //  垂直スクロールバー関係の設定
  if DataSource.DataSet.RecordCount = VisibleRowCount then begin
    EnableScrollBar(Handle, SB_VERT, ESB_DISABLE_BOTH);
  end else begin
    EnableScrollBar(Handle, SB_VERT, ESB_ENABLE_BOTH);
  end;

  //  水平スクロールバー関係の設定
  if (ColCount - FixedCols) = VisibleColCount then begin
    EnableScrollBar(Handle, SB_HORZ, ESB_DISABLE_BOTH);
  end else begin
    EnableScrollBar(Handle, SB_HORZ, ESB_ENABLE_BOTH);
  end;
end;

//=============================================================================
//  Resizeメソッド
//  コントロールがリサイズされると自動的に実行されるメソッド(OnResize相当)
//=============================================================================
procedure TplDBGrid.Resize;
begin
  inherited;
  Available_Disable_ScrollBars;
end;

//=============================================================================
//  行の高さを変更するメソッドのオーバライド
//=============================================================================
procedure TplDBGrid.RowHeightsChanged;
begin
  inherited;
  Available_Disable_ScrollBars;
end;

//=============================================================================
//  カラム(列)の幅を変更するメソッドのオーバライド
//=============================================================================
procedure TplDBGrid.ColWidthsChanged;
begin
  inherited;
  Available_Disable_ScrollBars;
end;

//=============================================================================
//  行または列の数が変更された時の処理
//  SizeChanged メソッドのオーバライド
//=============================================================================
procedure TplDBGrid.SizeChanged(OldColCount, OldRowCount: Integer);
begin
  inherited;
  Available_Disable_ScrollBars;
end;

//=============================================================================
//  WM_NCCALCSIZEメッセージ処理
//  スクロールバー表示のフラグを強制的に変更
//=============================================================================
procedure TplDBGrid.WMNCCalcSize(var Message: TWMNCCalcSize);
var
  LStyle : Integer;
begin
  //スクロールバーの表示を強制的に変更
  LStyle := GetWindowLong(Handle, GWL_STYLE);
  SetWindowLong(Handle, GWL_STYLE, LStyle or WS_HSCROLL or WS_VSCROLL);

  inherited;
end;

end.




03_TDBGrid のスクロールのトラッキング


スクロールのトラッキング (追従) 機能の設定サンプルです.Button1 クリックでトラッキングの ON, OFF を切り換えます.

スクロールバーのスクロールボックス (つまみ) をドラッグすると,スクロールボタン (つまみ) を放すまではスクロールしません.これが TDBGrid のデフォルトの仕様です.

スクロールボックス (つまみ) を操作した時のスクロールコードは SB_THUMBTRACK です.TDBGrid ではスクロールボックス (つまみ) を放すとスクロールコードが SB_THUMBPOSITION となり,実際のスクロールが行われます.
スクロールボックス (つまみ) をドラッグ中 (移動中) に強制的に SB_THUMBPOSITION にするようにしたのが本サンプルです.

スクロールバーを操作すると,WM_HSCROLL または WM_VSCROLL が発生します.このメッセージ内で処理を行います.Delphi では,このスクロールのメッセージの内容を TWMHScroll 型で受け取ることができます.MSDN の記事にあるような,一般的な WParam, LParam パラメータで受け取るには,引数の型を TMessage 型に変更します.
本サンプルでは,TDBGrid の継承クラスに ScrollTracking というプロパティを実装して,このプロパティの値を Button1 で切り換えるようにしています.
水平方向のスクロールは,列単位となるようです.

グリッドのスクロールそのものの動作仕様は 継承元の TDBGrid と同じです.カレントレコードの位置が一定の位置に移動するまでは,グリッドはスクロールしません.



[備考]
このスクロールのトラッキング (追従) を「滑らかなスクロール」と言うこともあります.本サンプルでは,水平方向は列単位でのスクロールです.滑らかと言えるかは疑問です.




図5
スクロールボックス (つまみ) をドラッグ
  • スクロールボックス (つまみ) を放すまでグリッドはスクロールしない
図6
Button1 をクリック
  • スクロールボックス (つまみ) のドラッグ (移動) と同時にグリッドもスクロールする
図7
水平スクロールの場合
  • 水平スクロールは列単位

リスト3
TDBGrid のスクロールボックスによるスクロールのトラッキングの制御
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.Grids, Vcl.DBGrids, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TplDBGrid = class(TDBGrid)
  private
    FScrollTracking : Boolean;
  protected
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  public
    property ScrollTracking : Boolean read FScrollTracking write FScrollTracking;
  end;

  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Panel1: TPanel;
    Query1: TQuery;
    Button1: TButton;
    DBGrid1: TDBGrid;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    plDBGrid1 : TplDBGrid;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  plChgCompo;

{$R *.DFM}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //フォーム作成時にコンポーネントの入れ替え
  plDBGrid1 := TplDBGrid(ChangeComponent(DBGrid1, TplDBGrid));

  Query1.Close;
  DataSource1.DataSet  := Query1;
  plDBGrid1.DataSource := DataSource1;

  Query1.DatabaseName := 'DBDEMOS';
  Query1.SQL.Clear;
  Query1.SQL.Add('select * from customer.db');
  Query1.Open;

  ActiveControl := plDBGrid1;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Query1.Close;
end;

//=============================================================================
//  TDBGridの継承クラスに実装したScrollTrackingプロパティをトグル操作
//  ScrollTrackingがTrueだとスクロールボックスのドラッグに追従してスクロール
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  plDBGrid1.ScrollTracking := not plDBGrid1.ScrollTracking;
end;

{ TplDBGrid }

//=============================================================================
//  TDBGridのWM_HSCROLLメッセージ処理
//=============================================================================
procedure TplDBGrid.WMHScroll(var Message: TWMHScroll);
begin
  if FScrollTracking then begin
    if Message.ScrollCode = SB_THUMBTRACK then begin
      Message.ScrollCode := SB_THUMBPOSITION;
    end;
  end;

  //inheritedは上の処理に後に実行する
  inherited;
end;

//=============================================================================
//  TDBGridのWM_VSCROLLメッセージ処理
//=============================================================================
procedure TplDBGrid.WMVScroll(var Message: TWMVScroll);
begin
  if FScrollTracking then begin
    if Message.ScrollCode = SB_THUMBTRACK then begin
      Message.ScrollCode := SB_THUMBPOSITION;
    end;
  end;

  //inheritedは上の処理に後に実行する
  inherited;
end;

end.




04_TDBGrid のスクロールバーのコンテキストメニュー


TDBGrid のスクロールバー上で,マウスの右ボタンをクリックすると,下図のようなコンテキストメニューが現れます.このコンテキストメニューを表示しないようにする方法です.

コンテキストメニューが表示する際,WM_CONTEXTMENU メッセージが発生します.このメッセージ処理内で何もしなければコンテキストメニューは現れません.何もしないと,TDBGrid で TPopupMenue コンポーネント等を使用していると,そのポップアップメニューも表示しなくなってしまいます.
そこで,マウスクリックの位置が,TDBGrid のクライアント領域の時は,WM_CONTEXTMENU メッセージ本来の処理を実行するようにしています.




図8
スクロールバーのコンテキストメニュー
  • このコンテキストメニューを表示しないようにする

リスト4
TDBGrid のスクロールバーのコンテキストメニューを表示しないようにする
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.Grids, Vcl.DBGrids, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TplDBGrid = class(TDBGrid)
  protected
    procedure WMContextMenu(var Message: TWMContextMenu);
      message WM_CONTEXTMENU;
  end;

  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Panel1: TPanel;
    Query1: TQuery;
    Button1: TButton;
    DBGrid1: TDBGrid;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private 宣言 }
    plDBGrid1 : TplDBGrid;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation   

uses
  plChgCompo;

{$R *.DFM}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //フォーム作成時にコンポーネントの入れ替え
  plDBGrid1 := TplDBGrid(ChangeComponent(DBGrid1, TplDBGrid));

  Query1.Close;
  DataSource1.DataSet  := Query1;
  plDBGrid1.DataSource := DataSource1;

  // データベースからデータを取得して表示
  Query1.DatabaseName := 'DBDEMOS';
  Query1.SQL.Clear;
  Query1.SQL.Add('select * from customer.db where CustNo<=3000');
  Query1.Open;

  ActiveControl := plDBGrid1;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Query1.Close;
end;

{ TplDBGrid }

//=============================================================================
//  WM_CONTEXTMENUメッセージ処理
//  スクロールバーのコンテキストメニューを表示しないようにする
//=============================================================================
procedure TplDBGrid.WMContextMenu(var Message: TWMContextMenu);
var
  LPos : TPoint;
begin
  LPos := ScreenToClient(Point(Message.XPos, Message.YPos));
  if PtInRect(ClientRect, LPos) then begin
    inherited;
  end else begin
    Message.Result := 0;
  end;
end;

end.




05_スクロール制御用に TScrollBar を実装した TDBGrid


TDBGrid の垂直スクロールバーのボックスのサイズは実際のページサイズではありません.ページサイズとは,SQL 文で取得したレコード数に対する表示中のレコード数の割合のことです.SetScrollInfo 関数使用すればページサイズ等を設定できますが,スクロールすると元の TDBGrid の設定に戻されてしまいます.水平スクロールバーのボックスサイズは,列数に関係なく固定サイズです.

マウスホイールや [Page Up], [Page Down] キーによるスクロールは,選択レコードは移動しますが,選択レコードが上端または下端になるまでは表示内容はスクロールを開始しません.

それらの現象を回避するために,スクロール制御用に TScrollBar を実装した TDBGrid コンポーネントを作成してみました.スクロールバーの背景色のプロパティも実装しています.
TDBGrid のスクロールは行単位,列単位です.ピクセル単位ではありません.
このコンポーネントは TDataSet.RecordCount でレコード数を取得しています.TDataSet.RecordCount の値が取得できない環境では利用できません.



[備考]
垂直スクロールバーのページサイズ,つまり,スクロールバーのボックス (つまみ) のサイズと位置は,行の高さが全て同じと仮定して計算しています.水平スクロールバーは,列の幅が全て同じと仮定した時のクライアント領域の表示幅に相当する列数をボックスのサイズとしています.この設定によって,全列幅のどの程度の範囲が表示されているかを確認できます.
スクロールは,トラッキングが ON の状態となります.そのため,大量のデータのスクロールでは問題が発生するかも知れません.




図9
テストプログラムの実行

TStringGrid は,全てのデータをグリッドのセルに代入して表示します.一方,TDBGrid は,SQL で取得したデータの全てをグリッドのセルに代入するわけではありません.レコード番号を指定すると,そのレコード番号の前後のレコードをセルに代入して表示します.TStringGrid のような行番号や列番号を指定したセルの選択ではなく,レコード番号で表示位置を指定します.TStringGrid では,td-date の値を設定することで縦方向にスクロールして,そのデータを表示できます.
TDBGrid の td-date の値は常に 0 です.Row の値は td-date からの相対値になり,表示中の行数を越えることはありません.



リスト5
スクロール制御用に TScrollBar を実装した TDBGrid コンポーネントのテスト用プログラム
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.Grids, Vcl.DBGrids, Vcl.StdCtrls, Vcl.ExtCtrls, plDBGrid;

type
  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Panel1: TPanel;
    Query1: TQuery;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private 宣言 }
    plDBGrid1 : TplDBGrid;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

//=============================================================================
//  フォーム生成時の処理
//  コンポーネントは実行時生成
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  plDBGrid1 := TplDBGrid.Create(Self);
  plDBGrid1.Parent := Self;
  plDBGrid1.Align  := alClient;
  plDBGrid1.Options := plDBGrid1.Options - [dgMultiSelect, dgEditing];

  Query1.Close;
  DataSource1.DataSet  := Query1;
  plDBGrid1.DataSource := DataSource1;

  Query1.Close;
  DataSource1.DataSet  := Query1;
  plDBGrid1.DataSource := DataSource1;

  Query1.DatabaseName := 'DBDEMOS';
  Query1.SQL.Clear;
  Query1.SQL.Add('select * from customer.db');
  Query1.Open;

  plDBGrid1.VScrollBarColor := clLime;
  plDBGrid1.HScrollBarColor := clLime;

  ActiveControl := plDBGrid1;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Query1.Close;
end;

end.


リスト6
スクロール制御用に TScrollBar を実装した TDBGrid コンポーネントのソースコード
unit plDBGrid;

interface

uses
  Winapi.Windows, Winapi.Messages, System.Classes, Vcl.Controls, Vcl.Forms, 
  Vcl.StdCtrls, System.UITypes, Vcl.Graphics, Vcl.Dialogs, System.SysUtils,
  Data.DB, Vcl.Grids, Vcl.DBGrids;

type
  TplDBGrid = class;

  TplDBGridBar = class(TScrollBar)
  private
    FDBGrid   : TplDBGrid;
  protected
    procedure Scroll(ScrollCode: TScrollCode; var ScrollPos: Integer); override;
    procedure CNCtlcolorscrollbar(var Message: TMessage);
      message CN_CTLCOLORSCROLLBAR;
  public
    constructor Create(AOwner: TComponent); override;
    property Color;
  end;

  TplDBGrid = class(TDBGrid)
  private
    FVScrollBarColor : TColor;
    FHScrollBarColor : TColor;
    FVScrollBar      : TplDBGridBar;
    FHScrollBar      : TplDBGridBar;
    FVPageSize       : Integer;
    FHPageSize       : Integer;
    FVScrollMax      : Integer;
    FHScrollMax      : Integer;
    FVCurrentPos     : Integer;
    FBottomMargin    : Integer;
    FRightMargin     : Integer;
    FScrollBars    : System.UITypes.TScrollStyle;
    procedure SetScrollBars(Value: TScrollStyle);
    procedure ScrollBarsSetSizePos(ALeft, ATop, AWidth, AHeight: Integer);
    function CalcHorzPageSize: Integer;
    function IsDataSetActive: Boolean;
    procedure SetHScrollBarColor(const Value: TColor);
    procedure SetVScrollBarColor(const Value: TColor);
  protected
    procedure SetParent(AParent: TWinControl); override;
    procedure Resize; override;
    procedure SizeChanged(OldColCount: Integer; OldRowCount: Integer); override;
    procedure ColWidthsChanged; override;
    procedure RowHeightsChanged; override;
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure CMVisiblechanged(var Message: TMessage);
      message CM_VISIBLECHANGED;
    procedure CMEnabledchanged(var Message: TMessage);
      message CM_ENABLEDCHANGED;
    procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
    procedure TopLeftChanged; override;
    procedure Scroll(Distance: Integer); override;
    procedure SelectionMoved(const OldSel: TGridRect); override;
  public
    procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer;
      AHeight: Integer); override;
    constructor Create(AOwner: TComponent); override;
    property VScrollBarColor : TColor read FVScrollBarColor write SetVScrollBarColor;
    property HScrollBarColor : TColor read FHScrollBarColor write SetHScrollBarColor;
  published
    property ScrollBars : TScrollStyle read FScrollBars write SetScrollBars;
  end;

procedure Register;

implementation

{ TplDBGrid }

//=============================================================================
//  コンポーネントのコンストラクタ (生成時) 処理
//=============================================================================
constructor TplDBGrid.Create(AOwner: TComponent);
begin
  inherited;

  ScrollBars  := ssNone;
  FScrollBars := ssBoth;
end;

//=============================================================================
//  SetParent メソッドの処理
//  TScrollBar の継承コンポーネントを生成
//
//    VScrollBar : 縦スクロールバー
//    HScrollBar : 横スクロールバー
//=============================================================================
procedure TplDBGrid.SetParent(AParent: TWinControl);
begin
  inherited;

  if not Assigned(FVScrollBar) then begin
    FVScrollBar := TplDBGridBar.Create(self);
    FVScrollBar.Parent := Parent;
    FVScrollBar.Kind   := sbVertical;

    FHScrollBar := TplDBGridBar.Create(Self);
    FHScrollBar.Parent := Parent;
    FHScrollBar.Kind   := sbHorizontal;

    FRightMargin  := FVScrollBar.Width;
    FBottomMargin := FHScrollBar.Height;

    ScrollBarsSetSizePos(Left, Top, Width, Height);

    FVScrollBar.Enabled := False;
    FHScrollBar.Enabled := False;
  end;
end;

//-----------------------------------------------------------------------------
//  ScrollBars プロパティの設定用メソッド
//  ssNone 以外は常に表示となる
//  ex. ssVertical にすると縦スクロールバーだけが常に表示となる
//-----------------------------------------------------------------------------
procedure TplDBGrid.SetScrollBars(Value: TScrollStyle);
begin
  if not Assigned(FVScrollBar) then Exit;

  if Value <> FScrollBars then begin
    FScrollBars := Value;
    FVScrollBar.Visible := (Value = ssBoth) or (Value = ssVertical);
    FHScrollBar.Visible := (Value = ssBoth) or (Value = ssHorizontal);

    RecreateWnd;
    ScrollBarsSetSizePos(Left, Top, Width, Height);
  end;
end;

//-----------------------------------------------------------------------------
//  垂直スクロールバーの背景色プロパティの設定用メソッド
//-----------------------------------------------------------------------------
procedure TplDBGrid.SetVScrollBarColor(const Value: TColor);
begin
  if not Assigned(FVScrollBar) then Exit;

  if FVScrollBarColor <> Value then begin
    FVScrollBarColor := Value;
    FVScrollBar.Color := FVScrollBarColor;
  end;
end;

//-----------------------------------------------------------------------------
//  水平スクロールバーの背景色プロパティの設定用メソッド
//-----------------------------------------------------------------------------
procedure TplDBGrid.SetHScrollBarColor(const Value: TColor);
begin
  if not Assigned(FHScrollBar) then Exit;

  if FHScrollBarColor <> Value then begin
    FHScrollBarColor := Value;
    FHScrollBar.Color := FHScrollBarColor;
  end;
end;

//-----------------------------------------------------------------------------
//  データセットがアクティブかをチェック
//-----------------------------------------------------------------------------
function TplDBGrid.IsDataSetActive: Boolean;
begin
  Result := False;

  if not Assigned(FVScrollBar) then Exit;
  if not (Assigned(DataLink) and DataLink.Active) then Exit;

  Result := True;
end;

//-----------------------------------------------------------------------------
//  スクロールバーの位置を設定
//-----------------------------------------------------------------------------
procedure TplDBGrid.ScrollBarsSetSizePos(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if Assigned(FVScrollBar) then begin
    FVScrollBar.Top    := ATop;
    FVScrollBar.Left   := ALeft + AWidth - FRightMargin;
    if FHScrollBar.Visible then begin
      FVScrollBar.Height := AHeight - FBottomMargin + 2;
    end else begin
      FVScrollBar.Height := AHeight;
    end;

    FHScrollBar.Top   := ATop + AHeight - FBottomMargin;
    FHScrollBar.Left  := ALeft;
    if FVScrollBar.Visible then begin
      FHScrollBar.Width := AWidth - FRightMargin + 2;
    end else begin
      FHScrollBar.Width := AWidth;
    end;
  end;
end;

//=============================================================================
//  このコンポの位置やサイズが変更された時の処理
//  スクロールバーの位置とサイズを設定し直す必要がある
//
//  SetBounds はコントロールの位置やサイズが変更された時に自動的に実行される
//  この後に自動的に Resize メソッドが実行される
//=============================================================================
procedure TplDBGrid.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited;
  ScrollBarsSetSizePos(ALeft, ATop, AWidth, AHeight);
end;

//-----------------------------------------------------------------------------
//  列方向のスクロールのページサイズの計算
//  全ての列幅が同じと仮定した時に(ClientWidth - 固定列の合計ピクセル数)
//  に表示可能な列数をページサイズとする
//-----------------------------------------------------------------------------
function TplDBGrid.CalcHorzPageSize: Integer;
var
  LColWidth : Integer;
  LFixedW   : Integer;
  LWidth    : Integer;
  LIndex    : Integer;
begin
  LColWidth := 0;
  for LIndex := FixedCols to ColCount - 1 do begin
    if ColWidths[LIndex] > 0 then begin
      LColWidth := LColWidth + ColWidths[LIndex];
    end;
  end;
  LFixedW := 0;
  for LIndex := 0 to FixedCols - 1 do begin
    if ColWidths[LIndex] > 0 then begin
      LFixedW := LFixedW + ColWidths[LIndex];
    end;
  end;
  if ClientWidth > (LColWidth + LFixedW) then begin
    LWidth := LColWidth;
  end else begin
    LWidth := ClientWidth - LFixedW;
  end;

  Result := Round((ColCount - FixedCols) * LWidth / LColWidth);
  if Result < 1 then Result := 1;
end;

//=============================================================================
//  このコントロールのサイズが変更された時の処理
//  スクロールバーのスクロールボックス(つまみ)のサイズとその位置を設定し直す
//  スクロールバーの位置とサイズの設定は SetBounds メソッドで自動実行する
//  コンポのサイズ変更時は最初に SetBounds メソッドが実行される
//=============================================================================
procedure TplDBGrid.Resize;
var
  LVisibleRows : Integer;
  LOldVPos     : Integer;
  LOldHPos     : Integer;
begin
  inherited;

  if not IsDataSetActive then Exit;

  LOldVPos := FVScrollBar.Position;
  LOldHPos := FHScrollBar.Position;

  //-----------------------------------
  //  垂直スクロールバー関係の設定
  //-----------------------------------
  FVScrollMax := DataSource.DataSet.RecordCount;

  // クライアント領域の高さ未満のレコード数の時は VisibleRowCount の値が大きくなる
  // (実際の値ではない)
  // その対策コード
  if FVScrollMax <= VisibleRowCount then begin
    LVisibleRows := FVScrollMax;
  end else begin
    LVisibleRows := VisibleRowCount;
  end;

  if (LVisibleRows = FVScrollMax) or (FVScrollMax <= 1) then begin
    // レコード数が少ない場合
    FVScrollBar.Enabled  := False;
    FVScrollBar.Position := 0;
  end else begin
    FVScrollBar.Enabled := True;

    // PageSizeを先に設定する
    FVPageSize := LVisibleRows;
   ;
    // 0 ベースとしての設定
    FVScrollBar.PageSize := FVPageSize;
    if (FVScrollMax < 3) or (FVPageSize < 2) then begin
      FVScrollBar.LargeChange := 1
    end else begin
      FVScrollBar.LargeChange := FVPageSize - 1;
    end;
    FVScrollBar.SmallChange := 1;
    FVScrollBar.Min         := 0;
    FVScrollBar.Max         := FVScrollMax - 1;

    FVScrollBar.Position := LOldVPos;
  end;

  //-----------------------------------
  //  水平スクロールバー関係の設定
  //-----------------------------------
  FHScrollMax := ColCount - FixedCols;

  if (VisibleColCount = FHScrollMax) or (FHScrollMax <= 1) then begin
    // 列数が少ない場合
    FHScrollBar.Enabled  := False;
    FHScrollBar.Position := 0;
  end else begin
    FHScrollBar.Enabled := True;

    // PageSizeを先に設定する
    FHPageSize := CalcHorzPageSize;

    // 列の生成中はこの条件を満たさないことがある
    // すると列数の範囲の例外が発生する
    if FHPageSize < FHScrollMax then begin
      // 0 ベースとしての設定
      FHScrollBar.PageSize := FHPageSize;
      if (FHScrollMax < 3) or (FHPageSize < 2) then begin
        FHScrollBar.LargeChange := 1;
      end else begin
        FHScrollBar.LargeChange := FHPageSize - 1;
      end;
      FHScrollBar.SmallChange := 1;
      FHScrollBar.Min         := 0;
      FHScrollBar.Max         := FHScrollMax - 1;

      FHScrollBar.Position := LOldHPos;
    end;
  end;
end;

//=============================================================================
//  行または列の数が変更された時の処理
//  スクロールバーのスクロールボックス(つまみ)のサイズとその位置を設定し直す
//=============================================================================
procedure TplDBGrid.SizeChanged(OldColCount, OldRowCount: Integer);
begin
  inherited;
  Resize;
end;

//=============================================================================
//  行の高さが変更された時の処理
//  スクロールバーのスクロールボックス(つまみ)のサイズとその位置を設定し直す
//=============================================================================
procedure TplDBGrid.RowHeightsChanged;
begin
  inherited;
  Resize;
end;

//=============================================================================
//  列の幅が変更された時の処理
//  スクロールバーのスクロールボックス(つまみ)のサイズとその位置を設定し直す
//=============================================================================
procedure TplDBGrid.ColWidthsChanged;
begin
  inherited;
  Resize;
end;

//=============================================================================
//  Visible プロパティが変更された時の処理                  
//=============================================================================
procedure TplDBGrid.CMVisiblechanged(var Message: TMessage);
begin
  inherited;

  if Assigned(FVScrollBar) then begin
    FVScrollBar.Visible := Visible;
    FHScrollBar.Visible := Visible;
  end;
end;

//=============================================================================
//  Enabled プロパティが変更された時の処理
//=============================================================================
procedure TplDBGrid.CMEnabledchanged(var Message: TMessage);
begin
  inherited;

  if Assigned(FVScrollBar) then begin
    FVScrollBar.Enabled := Enabled;
    FHScrollBar.Enabled := Enabled;
  end;
end;

//=============================================================================
//  SelectionMoved メソッドの処理
//  アンドキュメントなメソッド
//
//  外部から TDataSet.RecNo を設定した時はこのメソッドでないと反応しない
//  外部から RecNo を指定した場合はアクティブなレコード番号の指定を意味する
//  このメソッドではマウススクロールとキー操作では反応しない
//=============================================================================
procedure TplDBGrid.SelectionMoved(const OldSel: TGridRect);
begin
  inherited;

  if DataLink.Active then begin
    Scroll(0);
  end;
end;

//=============================================================================
//  Scroll メソッドの処理
//  スクロールによってレコード位置が変更されると発生するメソッド
//  スクロールバーの Position の値はその時に決定できる
//
//  このメソッドは外部から TDataSet.RecNo を設定しても実行されない
//  このコード内の TDataSet.RecNo は現在アクティブなレコード番号
//  Draw 系メソッド内では DataLink,AcriveRecord で取得できる
//  Draw 系メソッド内の RecNo はレコードの一連番号
//=============================================================================
procedure TplDBGrid.Scroll(Distance: Integer);
begin
  if Distance <> 0 then begin
    inherited;
  end;
  FVScrollBar.Position := DataSource.DataSet.RecNo - (Row - FixedRows + 1);
  FVCurrentPos := FVScrollBar.Position;
end;

//=============================================================================
//  TopLeftChanged メソッドの処理
//  セルの上端または左端が変更になった時に実行されるメソッド
//  TDBGrid では td-date の値は常に 0
//=============================================================================
procedure TplDBGrid.TopLeftChanged;
begin
  inherited;
  FHScrollBar.Position := LeftCol - FixedCols;
end;

//=============================================================================
//  KeyDown メソッドの処理 (OnKeyDown イベントに相当)
//=============================================================================
procedure TplDBGrid.KeyDown(var Key: Word; Shift: TShiftState);
var
  LIndex : Integer;
begin
  if Key = VK_NEXT then begin
    for LIndex := 0 to FVScrollBar.LargeChange - 1 do begin
      Perform(WM_VSCROLL, MakeWParam(SB_LINEDOWN, 0), 0);
    end;
    Key := 0;
    Exit;
  end else
  if Key = VK_PRIOR then begin
    for LIndex := 0 to FVScrollBar.LargeChange - 1 do begin
      Perform(WM_VSCROLL, MakeWParam(SB_LINEUP, 0), 0);
    end;
    Key := 0;
    Exit;
  end;

  inherited;
end;

//=============================================================================
//  DoMouseWheel メソッド (OnMouseWheel イベント相当) の処理
//
//  元の TDBGrid と仕様を変更している
//  元の TDBGrid ではキー操作によるスクロールと同じ
//  クライアント領域内ではスクロールしない
//  本コンポでは直ちにスクロールする
//  スクロール量はシステムの設定値を使用する
//=============================================================================
function TplDBGrid.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  MousePos: TPoint): Boolean;
var
  LDelta : Integer;
  LIndex : Integer;
begin
  SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @LDelta, 0);

  if WheelDelta < 0 then begin
    for LIndex := 0 to LDelta - 1 do begin
      Perform(WM_VSCROLL, MakeWord(SB_LINEDOWN, 0), 0);
    end;
    Result := True;
  end else begin
    for LIndex := 0 to LDelta - 1 do begin
      Perform(WM_VSCROLL, MakeWord(SB_LINEUP, 0), 0);
    end;
    Result := True;
  end;
end;

//-----------------------------------------------------------------------------
//  TDBGird の WM_NCCALCSIZE メッセージ処理
//  スクロールバー表示のスタイルを強制的に変更
//  以下のコードを実行すると元の ScrollBarsによる設定は無効になる
//  本コンポでは ScrollBars プロパティを独自仕様にしている
//-----------------------------------------------------------------------------
procedure TplDBGrid.WMNCCalcSize(var Message: TWMNCCalcSize);
var
  LStyle   : Integer;
  LBMargin : Integer;
  LRMargin : Integer;
  LRect    : TRect;
  LResRect : TRect;
begin
  if Visible then begin
    LStyle := GetWindowLong(Handle, GWL_STYLE);
    LStyle := LStyle and not WS_VSCROLL and not WS_HSCROLL;
    SetWindowLong(Handle, GWL_STYLE, LStyle);
  end;

  inherited;

  // クライアント領域の設定
  // スクロールバーを配置する非クライアント領域の設定
  // スクロールバーの位置とサイズは ScrollBars プロパティ設定メソッド内で実行
  if Assigned(FVScrollBar) then begin
    if Message.CalcValidRects then begin
      LRMargin := FRightMargin;
      LBMargin := FBottomMargin;
      if not FVScrollBar.Visible then LRMargin := 0;

      if not FHScrollBar.Visible then LBMargin := 0;

      // rgrc[0] : 移動またはサイズ変更後のウィンドウ値
      // rgrc[1] : 移動またはサイズ変更前のウィンドウ値
      // rgrc[2] : 移動またはサイズ変更前のクライアント領域の値
      // と MS Windows Dev Center にはあるのだが...
      LRect := message.CalcSize_Params.rgrc[0];
      LResRect := Rect(Left, Top, LRect.Right - LRMargin, LRect.Bottom - LBMargin);
      message.CalcSize_Params.rgrc[0] := LResRect;

      Message.Result := 0
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  WM_NCPAINT メッセージ処理
//  非クライアント領域の再描画が必要になった時に発生するメッセージ
//-----------------------------------------------------------------------------
procedure TplDBGrid.WMNCPaint(var Message: TWMNCPaint);
var
  LhHDC   : HDC;
  LCanvas : TCanvas;
begin
  inherited;

  LCanvas := TCanvas.Create;
  LhHDC   := GetWindowDC(Handle);
  try
    LCanvas.Handle := LhHDC;
    // ClipRect で非クライアント領域を塗り潰してクライアント領域を再描画
    LCanvas.FillRect(LCanvas.ClipRect);
    Invalidate;
  finally
    ReleaseDC(Handle, LhHDC);
    FreeAndNil(LCanvas);
  end;
  Message.Result := 0;
end;

{ TplDBGridBar }

//=============================================================================
//  TScrollBox コンポーネントの派生クラスのコンストラクタ (生成時) 処理
//=============================================================================
constructor TplDBGridBar.Create(AOwner: TComponent);
begin
  inherited;
  FDBGrid := TplDBGrid(AOwner);
end;

//-----------------------------------------------------------------------------
//  CN_CTLCOLORSCROLLBAR メッセージ処理
//  Color プロパティの実装用
//-----------------------------------------------------------------------------
procedure TplDBGridBar.CNCtlcolorscrollbar(var Message: TMessage);
begin
  DefaultHandler(Message)
end;

//=============================================================================
//  スクロール時の処理
//  このメソッド(イベント) では TScrollBar 操作によるスクロールだけを処理
//  Position プロパティによる設定は処理しない
//  トラッキングが ON と同じスクロールなので大量のデータで難があるかも知れない
//
//  TScrollBar は下端または右端まで移動して操を続けると Position の値が増加する
//  Position の値の増加が不要になったら引数の ScrollPos に戻す値を渡す
//=============================================================================
procedure TplDBGridBar.Scroll(ScrollCode: TScrollCode;
  var ScrollPos: Integer);
var
  LScrollPos : Integer;
  LSBCode    : DWORD;
  LScrollCnt : Integer;
  LTrackTop  : Integer;
  LCellPos   : Integer;
  LLastCol   : Integer;
  LIndex     : Integer;
begin
  inherited;
  if not FDBGrid.IsDataSetActive then Exit;
  if ScrollCode = scPosition then Exit;

  LScrollPos := ScrollPos;

  // 垂直(縦・行方向)スクロールバー
  if Self.Kind = sbVertical then begin
    LTrackTop  := FDBGrid.FVScrollMax - FDBGrid.FVPageSize + 1;
    LScrollCnt := LScrollPos - FDBGrid.FVCurrentPos;

    if LScrollCnt >= 0 then begin
      LSBCode := SB_LINEDOWN;
    end else begin
      LScrollCnt := -LScrollCnt;
      LSBCode := SB_LINEUP;
      if FDBGrid.FVCurrentPos = 0 then begin
        LScrollCnt := 0;
      end;
    end;

    for LIndex := 0 to LScrollCnt - 1 do begin
      FDBGrid.Perform(WM_VSCROLL, MakeWParam(LSBCode, 0), 0);
    end;

    if LScrollPos <= 0 then begin
      // 変更した値を引数に返す
      ScrollPos := 0;
      Position := 0;
    end else
    if LScrollPos >= LTrackTop then begin
      // 変更した値を引数に返す
      ScrollPos := LTrackTop;
      Position  := LTrackTop;
    end else begin
      Position := LScrollPos;
    end;
    FDBGrid.FVCurrentPos := Position;
  end;


  // 水平(横・列方向)スクロールバー
  if Self.Kind = sbHorizontal then begin
    LCellPos := LScrollPos + FDBGrid.FixedCols;
    LLastCol := LCellPos + FDBGrid.VisibleColCount - FDBGrid.FixedCols;
    if LLastCol > (FDBGrid.ColCount - FDBGrid.FixedCols) then begin
      LCellPos := FDBGrid.ColCount - FDBGrid.VisibleColCount - FDBGrid.FixedCols;
      Position := LCellPos;
      // 変更した値を引数に返す
      ScrollPos := Position;
    end else begin
      if LCellPos <= FDBGrid.FixedCols then begin
        FDBGrid.LeftCol := FDBGrid.FixedCols;
      end else begin
        FDBGrid.LeftCol := LCellPos;
      end;
    end;
  end;
end;

//=============================================================================
//  コンポーネント登録情報
//  コンポーネントパレットの[plXRAY]というタブに登録
//  指定したタブがない場合は,自動的に作成される
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplDBGrid]);
end;

end.




06_固定列の設定機能付き TDBGrid コンポーネント


TDBGrid の protected 部に固定列の列数を設定する FixedCols プロパティがありますが,この値を設定しても固定列の数は変化しません.そこで,以下の記事を参考にしてテーマに対応したコンポーネントを作成してみました.
TDBGrid のインジケータは固定列です.したがつて,固定列の列数は,このインジケータを含めた値で指定します.このテストプログラムでは SQL 文で取得した最初の項目を固定列として追加します.

固定列に設定した列のセルは選択できません.水平方向 (列方向) のスクロールでスクロールしません.常に左端に表示された状態となります.




図10
固定列の設定結果
  • マウスカーソルが示す列が固定列

下図はインジケータを非表示にした結果です.TDBGrid では,1 つ以上の固定列と 1 つ以上の固定行が必要です.FixedCols プロパティの値を 0 にすることはできません.
以下のように,Options で dgIndicator, dgTitles を除外すれば,インジケータの列と固定列であるタイトル行を非表示にすることは可能です.


  DBGrid1.Options := DBGrid1.Options - [dgIndicator, dgTitles];



図11
インジケータを非表示

リスト7
固定列の設定が可能な TDBGrid コンポーネントのテスト用プログラム
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.Grids, Vcl.DBGrids, Vcl.StdCtrls, Vcl.ExtCtrls, plFixDBGrid;

type
  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Panel1: TPanel;
    Query1: TQuery;
    Button1: TButton;
    DBGrid1: TDBGrid;
    plFixDBGrid1: TplFixDBGrid;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

//=============================================================================
//  フォーム生成時の処理
//  TplFixDBGrid をフォームに配置してテスト
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LItemList : string;
begin
  // TDBGrid のオプションの設定
  plFixDBGrid1.Options := plFixDBGrid1.Options - [dgMultiSelect];
  plFixDBGrid1.Options := plFixDBGrid1.Options - [dgEditing];

  Query1.Close;
  // データベース関係コントロールの設定
  DataSource1.DataSet  := Query1;
  plFixDBGrid1.DataSource := DataSource1;

  // データベースからデータを取得して表示
  Query1.DatabaseName := 'DBDEMOS';
  Query1.SQL.Clear;
  LItemList := 'Company, CustNo, Addr1, State, City, Zip, Phone';
  Query1.SQL.Add('select ' + LItemList + ' from customer.db');
  Query1.Open;

  // 固定列の設定
  //  Company のフィールドが固定列となる
  // インジケータは固定列なので固定列は 2 とする
  // 本サンプルではオブジェクト・インスペクタで設定済み
  // plFixDBGrid1.FixedCols := 2;
  plFixDBGrid1.Columns[0].Title.Caption := '店舗名';

  ActiveControl := plFixDBGrid1;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Query1.Close;
end;

//=============================================================================
  // インジケータの表示・非表示の切り換え
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if dgIndicator in plFixDBGrid1.Options then begin
    plFixDBGrid1.Options := plFixDBGrid1.Options - [dgIndicator];
    plFixDBGrid1.FixedCols := 1;
  end else begin
    plFixDBGrid1.Options := plFixDBGrid1.Options + [dgIndicator];
    plFixDBGrid1.FixedCols := 2;
  end;
  ActiveControl := plFixDBGrid1;
end;

end.


リスト8
TDBGri.FixedCols プロパティの設定を有効にするコンポーネントのソースコード
unit plFixDBGrid;

interface

uses
  Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls,
  Vcl.Dialogs, Data.DB, Vcl.Grids, Vcl.DBGrids;

type
  TplFixDBGrid = class(TDBGrid)
  private
    { Private 宣言 }
    FFixedCols : Integer;
    procedure SetFixedCols(const Value: Integer);
  protected
    procedure LayoutChanged; override;
    procedure LinkActive(Value: Boolean); override;
    function SelectCell(ACol: Integer; ARow: Integer): Boolean; override;
    procedure DrawCell(ACol: Integer; ARow: Integer; ARect: TRect;
      AState: TGridDrawState); override;
    procedure DrawColumnCell(const Rect: TRect; DataCol: Integer;
      Column: TColumn; State: TGridDrawState); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property FixedCols : Integer Read FFixedCols Write SetFixedCols Default 1;
  end;

procedure Register;

implementation

uses
  Themes;

{ TplFixDBGrid }

//=============================================================================
//  コンポーネント (クラス) の生成処理
//  固定列の設定が可能な TDBGrid
//=============================================================================
constructor TplFixDBGrid.Create(AOwner: TComponent);
begin
  Inherited Create(AOwner);
  FFixedCols := 1;
end;

//-----------------------------------------------------------------------------
//  FixedCols プロパティの設定用メソッド
//  固定カラムの数がカラム数より大きい時の処理は省略
//-----------------------------------------------------------------------------
procedure TplFixDBGrid.SetFixedCols(const Value: Integer);
begin
  If FFixedCols <> Value then begin
    FFixedCols := Value;
    if FFixedCols <= 0 then FFixedCols := 1;
    if Assigned(DataLink) and DataLink.Active then begin
      Inherited FixedCols := FFixedCols;
    end;
  end;
end;

//=============================================================================
//  LayoutChanged メソッドの処理
//  列のレイアウトに影響する変更があったときに自動的に呼び出されるメソッド 
//=============================================================================
procedure TplFixDBGrid.LayoutChanged;
var
  LSave :  Integer;
  LIndex : Integer;
begin
  Inherited;
  if (csLoading in ComponentState) then Exit;

  LSave := FixedCols;
  FixedCols := 1;
  FixedCols := LSave;
  if Assigned(DataLink) and DataLink.Active then begin
    // スクロールはしない
    // フォーカスは固定列以外の列に
    Scroll(0);
    // 固定列の右側に移動 (Col の値は 0 ベース)
    Col := FFixedCols;

    // TabStops [TAB] キーによる選択セル移動機能 ) の設定
    // 状態が変化する LayoutChanged メソッド内で設定しないと有効にならない
    for LIndex := 0 To FFixedCols - 1 do begin
      TabStops[LIndex] := False;
    end;
    for LIndex := FFixedCols to ColCount - 1 do begin
      TabStops[LIndex] := True;
    end;
  end;
end;

//=============================================================================
//  LinkActive メソッドの処理
//
//  データセットを開いた時や閉じる時にとき自動的実行されるメソッド
//  この時に Columns プロパティの再計算が行われる
//=============================================================================
procedure TplFixDBGrid.LinkActive(Value: Boolean);
begin
  Inherited;

  if Value then begin
    Inherited FixedCols := FFixedCols;
  end else begin
    if dgIndicator in Options then begin
      Inherited FixedCols := 1;
    end;
  end;
  Invalidate;
end;

//=============================================================================
//  SelectCell メソッドの処理
//  固定列のセル選択不可にする
//=============================================================================
function TplFixDBGrid.SelectCell(ACol, ARow: Integer): Boolean;
begin
  Result := Inherited SelectCell(ACol, ARow);

  if ACol < FFixedCols then begin
    Result := False;
  end;
end;

//=============================================================================
//  KeyDownl メソッドの処理
//  固定列のセルには移動しないようにする
//  矢印キーの操作では固定列に伊藤しない
//=============================================================================
procedure TplFixDBGrid.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if not (ssCtrl In Shift) then begin
    if Key = VK_HOME then begin
      If Col > FFixedCols then  Begin
        Col := FixedCols;
        Exit;
      end;
    end;
  end;

  Inherited;
end;

//=============================================================================
//  DrawCell メソッド処理
//
//  固定列のキャプションは自動では描画してくれない
//  DrawColumnCell. DrawDataCell では固定列のタイトルは描画できない
//  DrawCell に対応する外部イベントはない
//
//  TDBGrid.DrawingStyle が gdsGradient の時の処理は省略 (手抜き)
//=============================================================================
procedure TplFixDBGrid.DrawCell(ACol, ARow: Integer; ARect: TRect;
  AState: TGridDrawState);
var
  LFixCol   : Integer;
  LColumn   : TColumn;
  LDrawFlag : Integer;
  LColText  : string;
  LStyle    : TCustomStyleServices;
  LDetails  : TThemedElementDetails;
  LFormat   : TTextFormat;
begin
  if dgIndicator in Options then begin
    LFixCol := ACol - 1;
  end else begin
    LFixCol := ACol;
  end;
  if LFixCol >= 0 then begin
    LColumn := Columns[LFixCol];
  end;

  inherited;
  // Options に dgIndicator がある時は ACol = 0 はインジケータの列
  if LFixCol < 0 then Exit;


  if (dgTitles in Options) and (ARow = 0) and (ACol < FFixedCols) then begin

    // 背景を描画
    if (ThemeServices.Enabled) and (DrawingStyle = gdsThemed) then begin
      // テーマが有効な場合
      // 状態によって種類を変更
      LStyle := StyleServices;
      if gdPressed in AState then begin
        LDetails := LStyle.GetElementDetails(tgFixedCellPressed);
      end else
      if gdHotTrack in AState then begin
        LDetails := LStyle.GetElementDetails(tgFixedCellHot);
      end else begin
        LDetails := LStyle.GetElementDetails(tgFixedtd-normal);
      end;

      InflateRect(ARect, 1, 1);
      LStyle.DrawElement(Canvas.Handle, LDetails, ARect, nil);
      InflateRect(ARect, -1, -1);
    end else begin
       // クラシックスタイルの場合
      Canvas.Brush.Color := LColumn.Title.Color;
      Canvas.FillRect(ARect);
    end;


    // カラムのタイトルを取得
    Canvas.Font := LColumn.Title.Font;
    LColText := LColumn.Title.Caption;

    // テキスト描画ノアライメントを取得
    case LColumn.Title.Alignment of
      taLeftJustify  : LFormat := [tfLeft];
      taRightJustify : LFormat := [tfRight];
    else
      LFormat := [tfCenter];
    end;
    LFormat := LFormat + [tfVerticalCenter, tfSingleLine];
    InflateRect(ARect, -2, -2);


    if (ThemeServices.Enabled) and (DrawingStyle = gdsThemed) then begin
      // テーマが有効な場合
      LDetails := StyleServices.GetElementDetails(tgFixedtd-normal);
      LStyle.DrawText(Canvas.Handle, LDetails, LColText, ARect, LFormat);
    end else begin
       // クラシックスタイルの場合
      Canvas.TextRect(ARect, LColText, LFormat);
      if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then begin
        InflateRect(ARect, 2, 2);
        DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMRIGHT);
        DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPLEFT);
      end;
    end;
  end;
end;

//=============================================================================
//  DrawColumnCell メソッドの処理
//  セルの描画が必要になったときに実行されるメソッド
//  固定行のデータを描画
//
//  固定列のデータは,テーマが有効な時は再描画をしない
//  そのままだと重ね描画になってしまう (描画が乱れるという言い方もある)
//  この処理は DrawDataCell メソッドでも可能
//  DrawCell メソッドではデータが正常に取得できないのでこの処理は不可
//
//  TDBGrid.DrawingStyle が gdsGradient の時の処理は省略 (手抜き)
//=============================================================================
procedure TplFixDBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer;
  Column: TColumn; State: TGridDrawState);
var
  LStyle   : TCustomStyleServices;
  LDetails : TThemedElementDetails;
  LRect    : TRect;
begin
  inherited;

  if gdFixed in State then begin

// 領域を塗り潰す
    // 塗り潰さないと前の描画内容が残されたままとなり重ね描画となる
    LRect := Rect;
    if (ThemeServices.Enabled) and (DrawingStyle = gdsThemed) then begin
      InflateRect(LRect, 1, 1);
      LStyle := StyleServices;
      LDetails := LStyle.GetElementDetails(tgFixedtd-normal);
      LStyle.DrawElement(Canvas.Handle, LDetails, LRect, nil);
    end else begin
      InflateRect(LRect, 1, 1);
      Canvas.Brush.Color := FixedColor;
    end;

    // データを描画
    DefaultDrawColumnCell(Rect, DataCol, Column, State);
  end;
end;

//=============================================================================
//  コンポーネント登録情報
//  コンポーネントパレットの[plXRAY]というタブに登録
//  指定したタブがない場合は,自動的に作成される
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplFixDBGrid]);
end;

end.




07_TDBGrid の固定列を使用したレコード番号の表示


作成した TplFixDBGrid コンポーネントを利用して,TDBGrid の固定列にレコード番号を表示する例です.計算項目を追加してもいいのですが,本サンプルでは,項目の別名を作成してそこにレコード番号を表示するようにしています.そのために,plFixDBGrid.pas 内の DrawColumnCell メソッドのコードを書き換えてテストしています.
TplFixDBGrid では固定列を選択も編集できないようになっています.編集できなければインプレイスエディタが起動して元のデータを表示することはありません.計算項目でなくても,元のデータとは別の値をセルに描画したままにできます.

下図は,TplFixDBGrid の継承元を TDBGrid ではなく,上の方の記事に掲載している TplDBGrid として実行した結果です.
このサンプルは EXE だけを添付しています.


  TplFixDBGrid = class(TplDBGrid)


レコード番号は,SQL 文の実行によって取得したデータ (レコード) の一連番号です.データベースに格納されているデータの番号ではありません.データベースにはレコードを一意に識別する値はありません.データベースのデータには,データの番号やレコード番号の概念はありません.
レコード番号の最初の値は常に 1 です.




図12
固定列にレコード場号を表示

リスト9
TDBGrid の固定列にレコード番号を表示するテストプログラム
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.Grids, Vcl.DBGrids, Vcl.StdCtrls, Vcl.ExtCtrls, plFixDBGrid;

type
  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Panel1: TPanel;
    Query1: TQuery;
    Button1: TButton;
    DBGrid1: TDBGrid;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
    plFixDBGrid1 : TplFixDBGrid;
  end;

var
  Form1: TForm1;

implementation

uses
  plChgCompo;

{$R *.DFM}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LItemList : string;
begin
  // フ ォーム作成時にコンポーネントの入れ替え
  plFixDBGrid1 := TplFixDBGrid(ChangeComponent(DBGrid1, TplFixDBGrid));

//   TDBGrid のオプションの設定
  plFixDBGrid1.Options := plFixDBGrid1.Options - [dgMultiSelect];
  plFixDBGrid1.Options := plFixDBGrid1.Options - [dgEditing];

  Query1.Close;
  // データベース関係コントロールの設定
  DataSource1.DataSet  := Query1;
  plFixDBGrid1.DataSource := DataSource1;

  // データベースからデータを取得して表示
  // フィールド CustNo の別名を追加
  // ここにレコード番号を表示する 
  Query1.DatabaseName := 'DBDEMOS';
  Query1.SQL.Clear;
  LItemList := 'CustNo as RecNo, CustNo, Company, Addr1, State, City, Zip, Phone';
  Query1.SQL.Add('select ' + LItemList + ' from customer.db');
  Query1.Open;

  // 固定列の設定
  plFixDBGrid1.FixedCols := 2;
  plFixDBGrid1.Columns[0].Title.Caption := '番号';
  plFixDBGrid1.Columns[0].Width := 40;

  plFixDBGrid1.VScrollBarColor := $00208FFF;
  plFixDBGrid1.HScrollBarColor := $00208FFF;

  ActiveControl := plFixDBGrid1;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Query1.Close;
end;

end.


TDBGrid の固定列にレコード番号を表示するために,plFixDBGrid.pas 内の DrawColumnCell メソッドのコードを,今回は以下のように変更しています.コードを変更しても,実行時に動作を確認するだけであれば,コンポーネントを登録したパッケージの再構築 (ビルド) は必要ありません. 

レコード番号を取得する SQL の関数,ROWNUM や ROW_NUMBER が使用可能であれば,DrawColumnCell メソッドのコードを以下のように変更する必要はありません.
BDE + Paradox では,それらの SQL の関数は使用できません.



//=============================================================================
//  DrawColumnCell メソッドの処理
//  固定行のデータを描画
//  最初の固定列 (インジケータを除く) にレコード番号を描画する例
//=============================================================================
procedure TplFixDBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer;
  Column: TColumn; State: TGridDrawState);
var
  LRect     : TRect;
  LDrawText : string;
  LFormat   : TTextFormat;
begin
  inherited;

  if (gdFixed in State) and (DataCol =  0) then begin

    // 領域を塗り潰す
    // 塗り潰さないと前の描画内容が残されたままとなり重ね描画となる
    LRect := Rect;
    InflateRect(LRect, 2, 2);
    Canvas.Brush.Color := clSkyBlue;
    Canvas.FillRect(LRect);

    // データを描画
    LRect.Right := LRect.Right - 5;
    Canvas.Font := Column.Font;
    LDrawText := IntToStr(DataSource.DataSet.RecNo);
    LFormat   := [tfRight, tfVerticalCenter, tfSingleLine];
    Canvas.TextRect(LRect, LDrawText, LFormat);
  end;
end;