☆２つのListViewを同期させる(その２)

データを比較して、見やすく表示できないかという相談があり、以前、ListViewを同期させるプログラムを書いてるからすぐにできるよっと言ってしまったものの、私のプログラム Windows 7 pro 32bit, Delphi XE2 proの環境で全く役に立たないではないですか(>_<) 当時作ったプログラムは、問題なく動作していることからプログラム環境の問題なんでしょうね。 ということで、再び同期のプログラムにトライすることになりました。下記のコードで一応動いているようですが、あまり検証していないため変なところがあるかも知れません。でも全く役に立たないコードよりましだと思いますので、一応載せておきますね。

サブクラスには、Mr.XRAYさん（Halbowさん）のサブクラス化コンポーネントを使わせて頂いています。

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes,
  Vcl.Controls, Vcl.Forms, Vcl.ComCtrls, Vcl.ExtCtrls,
  Vcl.Buttons, Vcl.StdCtrls, SubClassUnit;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    ListView1: TListView;
    ListView2: TListView;
    SubClass1: TSubClass;
    SubClass2: TSubClass;
    procedure FormCreate(Sender: TObject);
    procedure ListView1Change(Sender: TObject; Item: TListItem;
      Change: TItemChange);
    procedure ListView2Change(Sender: TObject; Item: TListItem;
      Change: TItemChange);
    procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure SubClass1MessageAfter(Sender: TObject; var Message: TMessage);
    procedure SubClass2MessageAfter(Sender: TObject; var Message: TMessage);
  private
    LV1, LV2: TListView;
    function SetActiveListView: Boolean;
    procedure SyncScroll(Value: Integer = 0);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// 生成
procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  Self.KeyPreview := True;

  // vsReportでの同期
  ListView1.ViewStyle := vsReport;
  ListView2.ViewStyle := vsReport;

  // ListView1とListView2のHeightを同期させるために合わせる。
  ListView2.Height := ListView1.Height;

  // Sampleデータ
  for I := 0 to 1000 do
  begin
    ListView1.Items.Add.Caption := 'Left'+IntToStr(I);
    ListView2.Items.Add.Caption := 'Right'+IntToStr(I);
  end;
  ListView1.Items[0].Selected := True;
end;

// ListViewの設定をします。
function TForm1.SetActiveListView: Boolean;
begin
  Result := False;
  if (ActiveControl is TListView) and
   (((ActiveControl as TListView) = ListView1) or
    ((ActiveControl as TListView) = ListView2)) then
  begin
    if (ActiveControl as TListView) = ListView1 then
    begin
      LV1 := ListView1;
      LV2 := ListView2;
    end
    else
    begin
      LV2 := ListView1;
      LV1 := ListView2;
    end;
    Result := True;
  end;
end;

// スクロールさせます。
// Value: スクロール量（コントロールパネルのマウスで設定されているもの）
procedure TForm1.SyncScroll(Value: Integer = 0);
var
  R: TRect;
  I, J, K: Integer;
begin
  if SetActiveListView and Assigned(LV1.TopItem) and Assigned(LV2.TopItem) then
  begin
    I := LV1.TopItem.Index;
    J := LV2.TopItem.Index;
    R := LV2.Items[0].DisplayRect(drBounds);
    K := (I-J)+Value;
    LV2.Scroll(0, K * (R.Bottom - R.Top));
  end;
end;

// キーによる同期
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  // Keyを押し続けている時に、表示を更新するため
  FormKeyUp(Self, Key, Shift);
end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  SyncScroll;
end;

// マウススクロールによる同期
procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
var
  Value: Integer;
begin
  Value := Mouse.WheelScrollLines;
  SyncScroll(Value);
end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
var
  Value: Integer;
begin
  Value := Mouse.WheelScrollLines;
  SyncScroll(-Value);
end;

// サブクラス
procedure TForm1.SubClass1MessageAfter(Sender: TObject; var Message: TMessage);
begin
  if message.Msg = WM_VSCROLL then
  begin
    if ActiveControl <> ListView1 then
      ActiveControl := ListView1;
    SyncScroll;
  end;
end;

procedure TForm1.SubClass2MessageAfter(Sender: TObject; var Message: TMessage);
begin
  if message.Msg = WM_VSCROLL then
  begin
    if ActiveControl <> ListView2 then
      ActiveControl := ListView2;
    SyncScroll;
  end;
end;

// 選択項目を合わせます。
procedure TForm1.ListView1Change(Sender: TObject; Item: TListItem;
  Change: TItemChange);
begin
  ListView2.OnChange := nil;
  try
    if Assigned(ListView1.Selected) then
      ListView2.Items[ListView1.ItemIndex].Selected := True;
  finally
    ListView2.OnChange := ListView2Change;
  end;
end;

procedure TForm1.ListView2Change(Sender: TObject; Item: TListItem;
  Change: TItemChange);
begin
  ListView1.OnChange := nil;
  try
    if Assigned(ListView2.Selected) then
      ListView1.Items[ListView2.ItemIndex].Selected := True;
  finally
    ListView1.OnChange := ListView1Change;
  end;
end;

end.

サブクラス化コンポーネント
SubClassUnit
http://mrxray.on.coocan.jp/Halbow/Notes/N004.html