« 2011年4月 | トップページ | 2011年10月 »

Ribbon Controls と VCL Styles

私は、Ribbon Control として以前から TMS Software の TMS Advanced Toolbars & Menus を使っているのですが、現バージョンは、XE2対応部分で少し問題があり、現在、修正してもらっています。まあ、この製品は VCL Style に対応することはないと思っているのですが、では、標準の Ribbon Controls は、対応してるのかなと思い、試してみました。

じゃじゃーん!

Ribbon_vcl_style


見事なまでに自分のスタイルを貫いておられます(^-^) やっぱり、対応しているわけないというか、これだけデザインされたものを変えるのは難しそうですしね。(Microsoftとの関係もある??)この件については、日本語のリリースノートには記述されていませんが、英語の方には、ちゃんと書いてありました。

VCL Styles Introduced for VCL Applications
To add a custom style to your VCL application, go to the Project > Options > Application > Appearance dialog box. The XE2 release does not support Styles for Ribbon Controls.


XE2 のリリース ノート
http://docwiki.embarcadero.com/RADStudio/XE2/ja/XE2_のリリース_ノート

Release Notes for XE2
http://docwiki.embarcadero.com/RADStudio/XE2/en/Release_Notes_for_XE2

TMS Software
TMS Advanced Toolbars & Menus
http://www.tmssoftware.com/site/advtoolbar.asp

|

Delphi XE2 Update 1

「更新プログラムの確認」からは表示されませんが、Delphi XE2 Update 1がアップされています。早速試してみましたが、アップデートと言うものの、正確には再インストールです。セットアップを実行するとXE2のアンインストールから始まり、シリアルの入力も要求されて・・・ネットワークの状態も良くなかったのですが、終了まで40分程かかりました。(CORE i5-2400)
自作コンポーネントの設定も先日終えたばかりなのに、もう一度やり直し・・・(T_T)



EMBARCADERO DEVELOPER NETWORK

Update1について(ダウンロードのリンク先もこちらから)
Update 1 for Delphi XE2, C++Builder XE2 and RAD Studio XE2

インストールの注意事項
Installation Notes for Delphi XE2 and C++Builder XE2

Bug Fix List
Delphi XE2 and C++Builder XE2 Update 1 Bug Fix List

|

RAD Studio XE2の概要(YouTube)

第20回 エンバカデロ・デベロッパーキャンプでのビデオがアップされています。David Intersimone氏による説明は英語ですが、字幕が用意されているので安心してご覧下さい(^-^)
ちなみに彼の発音は、「デルフィー」ではなく「デルファイ」ですね。

「RAD Studio XE2の概要」 1/5

「RAD Studio XE2の概要」 2/5

「RAD Studio XE2の概要」 3/5

「RAD Studio XE2の概要」 4/5

「RAD Studio XE2の概要」 5/5


YouTube
Embarcadero Japan
http://www.youtube.com/user/EmbarcaderoTechJapan

|

MyBaseを試してみる。(グループ化 on FireMonkey)

VCLで試したMyBaseのグループ化をFireMonkeyでも試してみました。FireMonkeyでもVCLと同じようにMyBaseが使えそうですね。

1.メニューから新規作成->FireMonkey HD アプリケーションを選択します。

各コンポーネントを配置し、オブジェクトインスペクタで次の設定をします。
2.TPanelを配置します。
  Panel1.Align := alTop;
3.TStringGridを配置します。
  StringGrid.Align := alClient;
4.TEditとTLabelを2つずつ配置します。
  Label1.Text := 'カウント数';
  Label2.Text := '合計金額';
5.TClientDataSetを配置します。
6.TDataSourceを配置します。
  DataSet := ClientDataSet1;
7.TBindScopeDB1を配置します。
  DataSource := DataSource1;
8.TBindingListを配置します。


Design1


9.BindDBGridLink1を選択し、オブジェクトインスペクタで次の設定をします。
  DataSource := BindScopeDB1;
  GridControl := StringGrid1;

下図のようにBindingsListを右クリックして、TBindDBGridLinkを追加します。 (バインディングコンポーネントをクリックします)

Design2

Design3

Design4

Design5


図のようにBindDBGridLink1の設定をします。(DataSource&GridControl)

Design6


10.TBindDBEditLinkを2回追加し、オブジェクトインスペクタで次の設定をします。
  DataSource := BindScopeDB1;
  EditControl := Edit1;

  DataSource := BindScopeDB1;
  EditControl := Edit2;

Design7

Design8

Design9


unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, Data.Bind.EngExt,
  Fmx.Bind.DBEngExt, Fmx.Bind.Editors, Data.Bind.Components, Data.Bind.DBScope,
  Data.Bind.DBLinks, Fmx.Bind.DBLinks, FMX.Layouts, FMX.Grid, Data.DB,
  Datasnap.DBClient, FMX.Edit;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    StringGrid1: TStringGrid;
    Edit1: TEdit;
    Edit2: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    ClientDataSet1: TClientDataSet;
    DataSource1: TDataSource;
    BindingsList1: TBindingsList;
    BindScopeDB1: TBindScopeDB;
    BindDBGridLink1: TBindDBGridLink;
    BindDBEditLink1: TBindDBEditLink;
    BindDBEditLink2: TBindDBEditLink;
    procedure FormCreate(Sender: TObject);
  private
    procedure KINDGetText(Sender: TField; var Text: string;
      DisplayText: Boolean);
    procedure ITEMGetText(Sender: TField; var Text: string;
      DisplayText: Boolean);
  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

// サンプルデータを追加します。
procedure MakeSample(CDS: TClientDataSet);
var
  F: Boolean;
begin
  F := CDS.Active;
  if not F then
    CDS.Open;
  try
    // サンプルデータの追加
    with CDS do
    begin
      Appendrecord(['Delphi', 'ESD','Starter',18000]);
      Appendrecord(['Delphi', 'ESD','Professional',94000]);
      Appendrecord(['Delphi', 'ESD','Enterprise',236000]);
      Appendrecord(['Delphi', 'ESD','Ultimate',356000]);
      Appendrecord(['Delphi', 'ESD','Architect',416000]);
      Appendrecord(['RAD Studio', 'ESD','Professional',148000]);
      Appendrecord(['RAD Studio', 'ESD','Enterprise',336000]);
      Appendrecord(['RAD Studio', 'ESD','Ultimate',456000]);
      Appendrecord(['RAD Studio', 'ESD','Architect',516000]);
      Appendrecord(['Delphi', 'Package','Professional',98000]);
      Appendrecord(['Delphi', 'Package','Enterprise',240000]);
      Appendrecord(['Delphi', 'Package','Architect',420000]);
      Appendrecord(['RAD Studio', 'Package','Professional',152000]);
      Appendrecord(['RAD Studio', 'Package','Enterprise',340000]);
      Appendrecord(['RAD Studio', 'Package','Architect',520000]);
      CheckBrowseMode;
    end;
  finally
    if not F then
      CDS.Close;
  end;
end;

   // データベースの作成
procedure CreateDB(CDS: TClientDataSet);
var
  I: Integer;
begin
  // データベースの作成
  CDS.Close;
  CDS.FieldDefs.Add('ITEM',ftWideString,20);
  CDS.FieldDefs.Add('KIND',ftWideString,20);
  CDS.FieldDefs.Add('DETAIL',ftWideString,20);
  CDS.FieldDefs.Add('PRICE',ftCurrency);

  with CDS.IndexDefs.AddIndexDef do
  begin
    Name := 'IDX';
    Fields := 'ITEM;KIND';
    GroupingLevel := 2;
  end;
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'COUNT';
    GroupingLevel := 2;
    IndexName := 'IDX';
    Expression := 'COUNT(PRICE)';
    Active := True;
    DataSet := CDS;
  end;

  with TAggregateField.Create(CDS) do
  begin
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_PRICE';
    GroupingLevel := 2;
    IndexName := 'IDX';
    Expression := 'SUM(PRICE)';
    Active := True;
    DataSet := CDS;
  end;
  CDS.AggregatesActive := True;

  // インデックスの設定
  CDS.IndexName := 'IDX';

  // 表示用にフィールド幅を設定 ※無視された(^-^)
  CDS.FieldByName('ITEM').DisplayWidth := 10;
  CDS.FieldByName('KIND').DisplayWidth := 10;
  CDS.FieldByName('DETAIL').DisplayWidth := 15;
  CDS.FieldByName('PRICE').DisplayWidth := 8;

  // グループ化されたフィールドの表示設定
  CDS.FieldByName('ITEM').OnGetText := Form1.ITEMGetText;
  CDS.FieldByName('KIND').OnGetText := Form1.KINDGetText;

  // CDS.AggregatesActive := True;
  // DBEditの設定
  Form1.BindDBEditLink1.FieldName := 'COUNT';
  Form1.BindDBEditLink2.FieldName := 'TOTAL_PRICE';
  CDS.Open;

  // サンプルデータの作成
  MakeSample(CDS);
end;

// ITEM表示用
procedure TForm1.ITEMGetText(Sender: TField; var Text: string;
  DisplayText: Boolean);
begin
  // 同じITEMの場合、一番最初のみ表示
  if (gbFirst in ClientDataSet1.GetGroupState(1)) then
    Text := Sender.AsString
  else
    Text := '';
end;

procedure TForm1.KINDGetText(Sender: TField; var Text: string;
  DisplayText: Boolean);
begin
  // 同じKINDの場合、一番最初のみ表示
  if (gbFirst in ClientDataSet1.GetGroupState(2)) then
    Text := Sender.AsString
  else
    Text := '';
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CreateDB(ClientDataSet1);
end;

end.

実行します。

Runtime


StringGrid1のオブジェクトインスペクタでAlternatingRowBackgroundをTrueにするとこんな感じになります。

Runtime1

|

MyBaseを試してみる。(BLOBフィールドで画像の読み書き)

とりあえずDB.TBlobFieldのヘルプを読んでみると・・・
TBlobField は,BLOB 項目の間でのデータのストリームをサポートするメソッドや,
BLOB 項目とバイナリファイルとの間でのバイナリデータのコピーをサポートする
メソッドを新しく導入します。また,データセットの CreateBlobStream
 メソッドによって返されるストリームを使用して,BLOB 項目によって管理される
データを読み書きすることもできます。 

ということで、次のようなコードを書いてみました。
// データベースの作成
procedure CreateDB(CDS: TClientDataSet);
begin
  CDS.Close;
  CDS.FieldDefs.Add('FileName', ftWideString, 100);
  CDS.FieldDefs.Add('IMG', ftBlob, 100);
  CDS.CreateDataSet;
  CDS.Close;
end;

// Jpegの追加
procedure cdsAddJPEGImage(CDS: TClientDataSet; FieldName: String;
  Jpeg: String);
var
  JPG:  TJPEGImage;
  Stream: TStream;
begin
  JPG := TJPEGImage.Create;
  try
    JPG.LoadFromFile(Jpeg);
    CDS.Append;
    Stream := CDS.CreateBlobStream(CDS.FieldByName(FieldName), bmReadWrite);
    try
      JPG.SaveToStream(Stream);
    finally
      Stream.Free;
    end;
  finally
    JPG.Free;
  end;
end;

// Jpegの取り出し
procedure cdsGetJPEGImage(CDS: TClientDataSet; FieldName: String;
  Jpeg: String);
var
  Stream: TStream;
  JPG:  TJPEGImage;
begin
  JPG := TJPEGImage.Create;
  try
    Stream := CDS.CreateBlobStream(CDS.FieldByName(FieldName), bmRead);
    try
      Stream.Position := 0;
      JPG.LoadFromStream(Stream);
      JPG.SaveToFile(Jpeg);
    finally
      Stream.Free;
    end;
  finally
    JPG.Free;
  end;
end;

これらを使って次のような処理で、読み書きは確かにできます。
// Save
procedure TForm1.Button1Click(Sender: TObject);
begin
  CreateDB(ClientDataSet1);
  ClientDataSet1.Open;
  cdsAddJPEGImage(ClientDataSet1,'IMG','D:\aaa.jpg');
  ClientDataSet1.SaveToFile('D:\Test.CDS');
end;

// Load
procedure TForm1.Button2Click(Sender: TObject);
begin
  ClientDataSet1.LoadFromFile('D:\Test.CDS');
  ClientDataSet1.Open;
  cdsGetJPEGImage(ClientDataSet1,'IMG','D:\Test\aaa.jpg');
end;

しかし、たくさんの画像形式があるときに、いちいちBitmap用とかPNG用とか作るのは大変ですよね。TPicture.Graphicに入れて、変換させると楽かなとか思いましたが、更にヘルプを調べてみますとTBlobField にはLoadFromFile, SaveToFile等という関数がありました。これは使えると思い、早速試してみたところ、ファイル形式に関係なくとても簡単に扱えるようになりました。
// Save
procedure TForm1.Button3Click(Sender: TObject);
begin
  CreateDB(ClientDataSet1);
  ClientDataSet1.Open;
  ClientDataSet1.Append;
  (ClientDataset1.FieldByName('IMG') as TBlobField).LoadFromFile('D:\aaa.jpg');
  ClientDataSet1.Append;
  (ClientDataset1.FieldByName('IMG') as TBlobField).LoadFromFile('D:\aaa.png');
  ClientDataSet1.Append;
  (ClientDataset1.FieldByName('IMG') as TBlobField).LoadFromFile('D:\aaa.bmp');
  ClientDataSet1.Append;
  (ClientDataset1.FieldByName('IMG') as TBlobField).LoadFromFile('D:\aaa.xlsx');
  ClientDataSet1.CheckBrowseMode;
  ClientDataSet1.SaveToFile('D:\Test.CDS');
end;

// Load
procedure TForm1.Button4Click(Sender: TObject);
var
  MS: TMemoryStream;
begin
  MS:= TMemoryStream.Create;
  try
    ClientDataSet1.LoadFromFile('D:\Test.CDS');
    ClientDataSet1.Open;

    (ClientDataset1.FieldByName('IMG') as TBlobField).SaveToFile('D:\Test\aaa.jpg');
    ClientDataSet1.Next;

    (ClientDataset1.FieldByName('IMG') as TBlobField).SaveToFile('D:\Test\aaa.png');
    ClientDataSet1.Next;

    (ClientDataset1.FieldByName('IMG') as TBlobField).SaveToFile('D:\Test\aaa.bmp');

    // ファイルに保存ではなくTImageに表示したい場合
    (ClientDataset1.FieldByName('IMG') as TBlobField).SaveToStream(MS);
    MS.Position := 0;
    Image1.Picture.Bitmap.LoadFromStream(MS);

    ClientDataSet1.Next;
    (ClientDataset1.FieldByName('IMG') as TBlobField).SaveToFile('D:\Test\aaa.xlsx');
  finally
    MS.Free;
  end;
end;

|

DBGridを同期させる。

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

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

設計時

Design

実行時

Runtime


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

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

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

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は0が返されるべきですが、時々1が返ってきます。
  // そのため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;

|

MyBaseを試してみる。(インデックスを使わずに、行の追加、挿入、削除編) REVENGE(^o^)

前回、MyBaseを試してみる。(インデックスを使わずに、行の追加、挿入、削除編) の処理では、フィルターが使えなかったのですが、次の処理をフィルター前、挿入処理前に入れることにより、フィルターも可能になりました。でも、全く論理的ではない処理のため、使っている間に不具合が出るかも知れませんけどね(^-^)
// 挿入時、レコード位置を保持するための処理
procedure cdsUpdate(CDS: TClientDataSet);
var
  I: Integer;
  Data: OleVariant;
begin
  SaveUndoPoint(CDS);
  I := CDS.RecNo;
  Data := CDS.Data;
  CDS.Data := Data;
  CDS.RecNo := I;
end;

前回の処理では、一度レコードを挿入してから、フィルター処理・解除をすると、それ以降挿入したレコードは、最後に追加されてしまいました。例えスクリーン上で、正しく表示されていたとしても、正しくファイルに書き込むことができませんでした。今回の処理では、二度目以降のフィルター処理後も正しく表示されています。FilterプロパティでもOnFilterRecordでも問題ないようです。

とりあえずレコードを挿入します。

1


フィルター処理します。

2


フィルターを解除して、再びレコードを挿入します。

3


フィルター処理します。

4


フィルターを解除しても、レコードの並びは保持されています。(^o^)/

5


var
  RecNoList: TList<Integer> // Undoに使用
  SP: Integer = -1;          // Undoの処理に使用
  SN: Integer = 0;

// サンプルデータ
procedure MakeSample(DataSet: TDataSet);
var
  F: Boolean;
begin
  F := DataSet.Active;
  if not F then
    DataSet.Open;
  try
    // サンプルデータの追加
    with DataSet do
    begin
      Appendrecord(['iPod Touch']);
      Appendrecord(['Zaurus C-860']);
      Appendrecord(['Delphi 2009 Handbook']);
      Appendrecord(['GEORGIA BLACK']);
      CheckBrowseMode;
    end;
  finally
    if not F then
      DataSet.Close;
  end;
end;

// データベースの作成
procedure CreateDB(CDS: TClientDataSet; UsingIndex: Boolean);
var
  I: Integer;
begin
  CDS.Close;
  CDS.FieldDefs.Add('ITEM',ftWideString,20);
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  CDS.Open;
  MakeSample(CDS);
end;

// DataSetの有効/無効
procedure DataSetEnabled(DataSet: TDataSet; Value: Boolean);
begin
  if Value then
    DataSet.EnableControls
  else
    DataSet.DisableControls;
end;

// SaveToFile
procedure cdsSaveToFile(CDS: TClientDataSet;
  const FileName: String);
begin
  if CDS.ChangeCount > 0 then
    CDS.MergeChangeLog;
  CDS.SaveToFile(FileName, dfXMLUTF8);
end;

// LoadFromFile
procedure cdsLoadFromFile(CDS: TClientDataSet;
  const FileName: String);
begin
  CDS.LoadFromFile(FileName);
end;

// 通し番号を返します。別に要らない処理です。
function GetSN: String;
begin
  Inc(SN);
  Result := IntToStr(SN);
end;

// 現在の状態を保存
procedure SaveUndoPoint(CDS: TClientDataSet);
begin
  // 変更があれば更新させます。
  if CDS.ChangeCount > 0 then
    CDS.MergeChangeLog;
  SP := (CDS as TClientDataSet).SavePoint;
end;

// SavePointから元に戻す処理
procedure Undo(CDS: TClientDataSet);
begin
  if SP > -1 then
    CDS.SavePoint := SP;
  SP := -1;
end;

// 削除されたレコードを元に戻す処理 ※コテコテ(^-^)
procedure UndoDelete(CDS: TClientDataSet);
var
  I, RC, RecNo: Integer;
  Delta: TClientDataSet;
begin
  if (RecNoList.Count <> 0) and (CDS.ChangeCount > 0) then
  begin
    Delta := TClientDataSet.Create(nil);
    try
      Delta.Data := CDS.Delta;
      Delta.Open;
      Delta.Last;
      I := -1;
      RC := CDS.RecordCount;

      // Insertで戻す場合、最後に追加されることをあるため、この処理を行う。
      cdsUpdate(CDS);  //20110922 追記 procedure cdsUpdateを前に持ってきてね。

      // Deltaから順番に戻していきます。
      while not Delta.Bof do
      begin
        Inc(I);
        if I < RecNoList.Count then
        begin
          RecNo := RecNoList[I];
          if RecNo > RC then
          begin
            CDS.Append;
            Inc(RC);
          end
          else
          begin
            CDS.RecNo := RecNo;
            CDS.Insert;
            Inc(RC);
          end;
          CDS.FieldByName('Item').AsString :=
            Delta.FieldByName('Item').AsString;
        end;
        Delta.Prior;
      end;
      CDS.CheckBrowseMode;
      CDS.MergeChangeLog;
      RecNoList.Clear;
    finally
      Delta.Free;
    end;
  end;
end;

// Undo
procedure cdsUndoNoIndex(CDS: TClientDataSet);
begin
    if RecNoList.Count > 0 then
    UndoDelete(CDS)            // 削除
  else if (SP > -1)  then
    Undo(CDS)                  // 追加/挿入-SavePoint
  else if CDS.ChangeCount > 0 then
    CDS.UndoLastChange(True);  // 上記以外
end;

// 追加
procedure cdsAppendNoIndex(CDS: TClientDataSet;
  Count: Integer = 1);
var
  I: Integer;
begin
  SaveUndoPoint(CDS);
  DataSetEnabled(CDS, False);
  try
    // Count分空白行を追加します。
    for I := 0 to Count - 1 do
    begin
      // 追加します。
      CDS.Append;
      CDS.FieldByName('ITEM').AsString := '追加'+ GetSN;
    end;
    CDS.CheckBrowseMode;
    // 今回追加した空白行の先頭レコードに移動させます。
    CDS.MoveBy(1-Count);
  finally
    DataSetEnabled(CDS, True);
  end;
end;

// 挿入時、レコード位置を保持するための処理
procedure cdsUpdate(CDS: TClientDataSet);
var
  I: Integer;
  Data: OleVariant;
begin
  SaveUndoPoint(CDS);
  I := CDS.RecNo;
  Data := CDS.Data;
  CDS.Data := Data;
  CDS.RecNo := I;
end;

// 挿入
procedure cdsInsertNoIndex(CDS: TClientDataSet;
  Count: Integer = 1);
var
  I: Integer;
  Data: OleVariant;
begin
  DataSetEnabled(CDS, False);
  try
    cdsUpdate(CDS);
    for I := 0 to Count -1 do
    begin
      // 挿入します。
      CDS.Insert;
      CDS.FieldByName('ITEM').AsString := '挿入'+ GetSN;
    end;
      CDS.CheckBrowseMode;
  finally
    DataSetEnabled(CDS, True);
  end;
end;

// 削除
procedure cdsDeleteNoIndex(CDS: TClientDataSet;
  BMList: TBookmarkList = nil);
type
  TIntegerComparer = TComparer<Integer>;
var
  I: Integer;
begin
  if not Assigned(BMList) then Exit;

  RecNoList.Clear;
  SaveUndoPoint(CDS);
  DataSetEnabled(CDS, False);
  try
    if Assigned(BMList) and (BMList.Count > 0) then
    begin
     for I := BMList.Count -1 downto 0 do
      begin
        CDS.GotoBookmark(BMList[I]);
        RecNoList.Add(CDS.RecNo);
        CDS.Delete;
      end;
      BMList.Clear;
    end;

    // RecNoListのソート
    RecNoList.Sort(TComparer<Integer>.Default);
  finally
    DataSetEnabled(CDS, True);
  end;
end;

// Filter
procedure cdsFiltered(CDS: TClientDataSet);
begin
  cdsUpdate(CDS);
  CDS.Filtered := not CDS.Filtered;
end;

// OnFilterRecord - ClientDataSet1で作成しておきます。
procedure TForm1.ClientDataSet1FilterRecord(DataSet: TDataSet;
  var Accept: Boolean);
begin
  Accept :=
    AnsiPos(Edit2.Text, DataSet.FieldByName('ITEM').AsString) > 0;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Undo用
  RecNoList:= TList<Integer>.Create;
  // データベースの作成
  CreateDB(ClientDataSet1, False);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(RecNoList);
end;

// SaveToFile
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  FileName: String;
begin
  FileName := ExtractFilePath(Application.ExeName) + 'MyBase.cds';
  cdsSaveToFile(ClientDataSet1,FileName);
end;

// LoadFromFile
procedure TForm1.SpeedButton2Click(Sender: TObject);
var
  FileName: String;
begin
  FileName := ExtractFilePath(Application.ExeName) + 'MyBase.cds';
  if FileExists(FileName) then
    cdsLoadFromFile(ClientDataSet1, FileName);
end;

// 追加
procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
  cdsAppendNoIndex(ClientDataSet1, StrToIntDef(Edit1.Text,1));
end;

// 挿入
procedure TForm1.SpeedButton4Click(Sender: TObject);
begin
  cdsInsertNoIndex(ClientDataSet1, StrToIntDef(Edit1.Text,1));
end;

// 削除
procedure TForm1.SpeedButton5Click(Sender: TObject);
begin
  cdsDeleteNoIndex(ClientDataSet1, DBGrid1.SelectedRows);
end;

// Undo
procedure TForm1.SpeedButton6Click(Sender: TObject);
begin
  cdsUndoNoIndex(ClientDataSet1);
end;

// Filter
procedure TForm1.SpeedButton7Click(Sender: TObject);
begin
  cdsUpdate(ClientDataset1);
  if not ClientDataset1.Filtered then
  begin
    case RadioGroup1.ItemIndex of
      0: begin
           ClientDataset1.Filter := '';
           ClientDataSet1.OnFilterRecord := ClientDataSet1FilterRecord;
         end;
      1 : begin
            ClientDataSet1.OnFilterRecord := nil;
            ClientDataset1.filter := 'ITEM LIKE '+QuotedStr('%' +  Edit2.Text+'%');
         end;
    end;
  end;
  cdsFiltered(ClientDataSet1);
end;

|

MyBaseを試してみる。(グループ化)

TClientDataSetのグループ化については、Helpに解説がありますが、これが私にとって大変難解な文章です。図を見ていると、できることはわかるのですけど、では実際どうしたらいいのかがさっぱり理解できません。

Embarcadero Product Documentation Wikis
インデックスを使ってデータをグループ化する

とりあえず試してみました。まずグループ化を使わずに普通にプログラムするとこんな感じです。
// サンプルデータを追加します。
procedure MakeSample(CDS: TClientDataSet);
var
  F: Boolean;
begin
  F := CDS.Active;
  if not F then
    CDS.Open;
  try
    // サンプルデータの追加
    with CDS do
    begin
      Appendrecord(['Delphi', 'ESD','Starter',18000]);
      Appendrecord(['Delphi', 'ESD','Professional',94000]);
      Appendrecord(['Delphi', 'ESD','Enterprise',236000]);
      Appendrecord(['Delphi', 'ESD','Ultimate',356000]);
      Appendrecord(['Delphi', 'ESD','Architect',416000]);
      Appendrecord(['RAD Studio', 'ESD','Professional',148000]);
      Appendrecord(['RAD Studio', 'ESD','Enterprise',336000]);
      Appendrecord(['RAD Studio', 'ESD','Ultimate',456000]);
      Appendrecord(['RAD Studio', 'ESD','Architect',516000]);
      Appendrecord(['Delphi', 'Package','Professional',98000]);
      Appendrecord(['Delphi', 'Package','Enterprise',240000]);
      Appendrecord(['Delphi', 'Package','Architect',420000]);
      Appendrecord(['RAD Studio', 'Package','Professional',152000]);
      Appendrecord(['RAD Studio', 'Package','Enterprise',340000]);
      Appendrecord(['RAD Studio', 'Package','Architect',520000]);
      CheckBrowseMode;
    end;
  finally
    if not F then
      CDS.Close;
  end;
end;

// データベースの作成
procedure CreateDB(CDS: TClientDataSet);
var
  I: Integer;
begin
  // データベースの作成
  CDS.Close;
  CDS.FieldDefs.Add('ITEM',ftWideString,20);
  CDS.FieldDefs.Add('KIND',ftWideString,20);
  CDS.FieldDefs.Add('DETAIL',ftWideString,20);
  CDS.FieldDefs.Add('PRICE',ftCurrency);

  with CDS.IndexDefs.AddIndexDef do
  begin
    Name := 'IDX';
    Fields := 'ITEM;KIND';
  end;
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'COUNT';
    IndexName := 'IDX';
    Expression := 'COUNT(PRICE)';
    Active := True;
    DataSet := CDS;
  end;

  with TAggregateField.Create(CDS) do
  begin
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_PRICE';
    IndexName := 'IDX';
    Expression := 'SUM(PRICE)';
    Active := True;
    DataSet := CDS;
  end;
  CDS.AggregatesActive := True;

  // インデックスの設定
  CDS.IndexName := 'IDX';

  // 表示用にフィールド幅を設定
  CDS.FieldByName('ITEM').DisplayWidth := 10;
  CDS.FieldByName('KIND').DisplayWidth := 10;
  CDS.FieldByName('DETAIL').DisplayWidth := 15;
  CDS.FieldByName('PRICE').DisplayWidth := 8;

  // CDS.AggregatesActive := True;
  // DBEditの設定
  Form1.DBEdit1.DataField := 'COUNT';
  Form1.DBEdit2.DataField := 'TOTAL_PRICE';
  CDS.Open;

  // サンプルデータの作成
  MakeSample(CDS);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CreateDB(ClientDataSet1);
end;

同じデータがある場合、普通に表示するとDBGridでは、次のように表示されます。

Nogrouping



グループ化すると同じデータは、一度だけ描画されるだけになり、見やすくなるということで、次のように修正しました。
// データベースの作成
procedure CreateDB(CDS: TClientDataSet);
var
  I: Integer;
begin
  // データベースの作成
  CDS.Close;
  CDS.FieldDefs.Add('ITEM',ftWideString,20);
  CDS.FieldDefs.Add('KIND',ftWideString,20);
  CDS.FieldDefs.Add('DETAIL',ftWideString,20);
  CDS.FieldDefs.Add('PRICE',ftCurrency);

  with CDS.IndexDefs.AddIndexDef do
  begin
    Name := 'IDX';
    Fields := 'ITEM;KIND';
    GroupingLevel := 1;
  end;
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'COUNT';
    GroupingLevel := 1;
    IndexName := 'IDX';
    Expression := 'COUNT(PRICE)';
    Active := True;
    DataSet := CDS;
  end;

  with TAggregateField.Create(CDS) do
  begin
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_PRICE';
    GroupingLevel := 1;
    IndexName := 'IDX';
    Expression := 'SUM(PRICE)';
    Active := True;
    DataSet := CDS;
  end;
  CDS.AggregatesActive := True;

  // インデックスの設定
  CDS.IndexName := 'IDX';

  // 表示用にフィールド幅を設定
  CDS.FieldByName('ITEM').DisplayWidth := 10;
  CDS.FieldByName('KIND').DisplayWidth := 10;
  CDS.FieldByName('DETAIL').DisplayWidth := 15;
  CDS.FieldByName('PRICE').DisplayWidth := 8;

  // グループ化されたフィールドの表示設定
  CDS.FieldByName('ITEM').OnGetText := Form1.ITEMGetText;

  // DBEditの設定
  Form1.DBEdit1.DataField := 'COUNT';
  Form1.DBEdit2.DataField := 'TOTAL_PRICE';
  CDS.Open;

  // サンプルデータの作成
  MakeSample(CDS);
end;

// ITEM表示用
procedure TForm1.ITEMGetText(Sender: TField; var Text: string;
  DisplayText: Boolean);
begin
  // GetGroupStateについて Helpより引用
  //
  // "AggregatesActive が false の場合,または現在の
  //  インデックスがグループ化をサポートしていない場合,
  //  GetGroupState は空のセットを返します。"

  // 同じITEMの場合、一番最初のみ表示
  if (gbFirst in ClientDataSet1.GetGroupState(1)) then
    Text := Sender.AsString
  else
    Text := '';
end;

各レコード毎に表示されていたITEMがすっきりとしています。 又、Delphiを選んだ場合、Rad Studioを選んだ場合と異なったアイテム数、合計金額が表示されます。このことから、同じITEMに対して処理がされていることがわかります。

Grouping1_1


Grouping1_2



KINDフィールドも同じものが並んでいるので、こちらもグループ化させるために次のようにプログラムを修正しました。
// データベースの作成
procedure CreateDB(CDS: TClientDataSet);
var
  I: Integer;
begin
  // データベースの作成
  CDS.Close;
  CDS.FieldDefs.Add('ITEM',ftWideString,20);
  CDS.FieldDefs.Add('KIND',ftWideString,20);
  CDS.FieldDefs.Add('DETAIL',ftWideString,20);
  CDS.FieldDefs.Add('PRICE',ftCurrency);

  with CDS.IndexDefs.AddIndexDef do
  begin
    Name := 'IDX';
    Fields := 'ITEM;KIND';
    GroupingLevel := 2;
  end;
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'COUNT';
    GroupingLevel := 2;
    IndexName := 'IDX';
    Expression := 'COUNT(PRICE)';
    Active := True;
    DataSet := CDS;
  end;

  with TAggregateField.Create(CDS) do
  begin
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_PRICE';
    GroupingLevel := 2;
    IndexName := 'IDX';
    Expression := 'SUM(PRICE)';
    Active := True;
    DataSet := CDS;
  end;
  CDS.AggregatesActive := True;

  // インデックスの設定
  CDS.IndexName := 'IDX';

  // 表示用にフィールド幅を設定
  CDS.FieldByName('ITEM').DisplayWidth := 10;
  CDS.FieldByName('KIND').DisplayWidth := 10;
  CDS.FieldByName('DETAIL').DisplayWidth := 15;
  CDS.FieldByName('PRICE').DisplayWidth := 8;

  // グループ化されたフィールドの表示設定
  CDS.FieldByName('ITEM').OnGetText := Form1.ITEMGetText;
  CDS.FieldByName('KIND').OnGetText := Form1.KINDGetText;

  // CDS.AggregatesActive := True;
  // DBEditの設定
  Form1.DBEdit1.DataField := 'COUNT';
  Form1.DBEdit2.DataField := 'TOTAL_PRICE';
  CDS.Open;

  // サンプルデータの作成
  MakeSample(CDS);
end;

procedure TForm1.KINDGetText(Sender: TField; var Text: string;
  DisplayText: Boolean);
begin
  // 同じKINDの場合、一番最初のみ表示
  if (gbFirst in ClientDataSet1.GetGroupState(2)) then
    Text := Sender.AsString
  else
    Text := '';
end;

これでKINDもグループ化された表示になりました。集合フィールドで設定したGroupingLevelによって、 ITEM数、合計金額についてもKINDに対して処理がされています。ここでようやくヘルプの「グループ化レベルは,インデックス内の項目順序に対応しています。 」の意味が理解できました(^-^)

Grouping2_1

Grouping2_2

|

MyBaseを試してみる。(PreviewHandlerで表示)

と書いていますが、今回は、MyBaseとは直接関係ないです(^-^)
以前、PreviewHandlerで自分のデータをExplorerで表示したいなと思って、下記サイトのサンプルをダウンロードし、試したことがありました。しかしながらDelphi2009のShlObjにはIPreviewHandlerが定義されておらず、コンパイルできませんでした。

今回、XE2を使ってMyBaseのデータをListViewで表示させてみました。サンプルのMyPreviewHandlerというユニットを次のものに入れ替えます。(MyBaseのファイルは、mbsという拡張子で保存しています。)

The Art of Delphi Programming
Windows 7 Previews – the Delphi Way

こんな感じで、表示することができます。

Mypreviewhandler


ただ項目部分をクリックすると次のようなエラーが表示されます。サンプルのまま、検証もせずに使っているので、今回は、OKとしておきますけど(^-^)

Error

unit MyPreviewHandler;

interface

uses
  PreviewHandler, System.Classes, Vcl.Controls, Vcl.StdCtrls,
  Vcl.ComCtrls, MidasLib, Datasnap.DBClient;

const
  CLASS_MyPreviewHandler: TGUID = '{9E4BFFE4-BA9C-449C-A6B5-4FF82B15FA91}';

type
  TMyPreviewHandler = class(TFilePreviewHandler)
  private
    FListView: TListView;
    FCDS: TClientDataSet;
  protected
  public
    constructor Create(AParent: TWinControl); override;
    procedure Unload; override;
    procedure DoPreview(const FilePath: string); override;
  end;

implementation

uses
  SysUtils;

constructor TMyPreviewHandler.Create(AParent: TWinControl);
var
  Col: TListColumn;
begin
  inherited;
   FCDS := TClientDataSet.Create(AParent);
   FListView:= TListView.Create(AParent);
   FListView.Parent := AParent;
   FListView.Align := alClient;
   FListView.Viewstyle:=vsReport;
   FListView.ReadOnly := True;

   Col := FListView.Columns.Add;
   Col.Caption := 'ORD';
   Col.Width := 40;

   Col := FListView.Columns.Add;
   Col.Caption := 'ITEM';
   Col.Width := 200;

   Col := FListView.Columns.Add;
   Col.Caption := 'QTY';
   Col.Alignment := taRightJustify;
   Col.Width := 80;

   Col := FListView.Columns.Add;
   Col.Caption := 'UNIT';
   Col.Alignment := taCenter;
   Col.Width := 50;

   Col := FListView.Columns.Add;
   Col.Caption := 'PRICE';
   Col.Alignment := taRightJustify;
   Col.Width := 80;

   Col := FListView.Columns.Add;
   Col.Caption := 'AMOUNT';
   Col.Alignment := taRightJustify;
   Col.Width := 80;

end;

procedure TMyPreviewHandler.DoPreview(const FilePath: string);
var
  LI: TListItem;
begin
  FCDS.FileName := FilePath;
  FCDS.Open;
  try
    FCDS.First;
    while not FCDS.EOF do
    begin
      LI := FListView.Items.add;
      LI.Caption := FCDS.FieldByName('ORD').AsString;
      LI.SubItems.Add(FCDS.FieldByName('ITEM').AsString);
      LI.SubItems.Add(FCDS.FieldByName('QTY').AsString);
      LI.SubItems.Add(FCDS.FieldByName('UNIT').AsString);
      LI.SubItems.Add(FormatCurr('#,',FCDS.FieldByName('PRICE').AsCurrency));
      LI.SubItems.Add(FormatCurr('#,',FCDS.FieldByName('QTY').AsFloat*
        FCDS.FieldByName('PRICE').AsCurrency));
      FCDS.Next;
    end;
  finally
   FCDS.Close;
  end;
end;

procedure TMyPreviewHandler.Unload;
begin
  FListView.Items.Clear;
  inherited;
end;

initialization
  TMyPreviewHandler.Register(CLASS_MyPreviewHandler, 'mbs', 'MyBase Preview Handler', '.mbs');
end.
 

コンパイルしてできたDLLをregsvr32を使って登録します。
regsvr32 d:\MyPreviewHandlerLib.dll

「ファイル名を指定して実行...」の場合

Resister2

「コマンドプロンプト」の場合

Regist

Regsvr32

削除する場合は、/u を使います。
regsvr32 /u d:\MyPreviewHandlerLib.dll

「ファイル名を指定して実行...」の場合

Unregister2

「コマンドプロンプト」の場合

Unregist



(参考)
MSDNマガジン

マネージ プレビュー ハンドラ フレームワークで独自の方法でデータを表示する

|

MyBaseを試してみる。(インデックスを使って、行の追加、挿入、削除編)

レコードの順番にインデックスを使って、行の編集をするバージョンです。言うまでもなく、インデックスは検索や目的に合ったレコードの並び替えをするために、取り扱うデータを分析し、その内容によっては、新規にカテゴリを作ってそのIDを割り当てたり、個別にコードを割り当てたりして作成されるべきものです。
しかしここでは、各レコードの順番を登録するフィールド(ここではORD)を用意し、そのインデックス(ここではORD_IDX)を利用してレコードの順番を保持します。そのため、場合によっては、一度に全レコードのORDフィールドを書き換えるという禁断の処理です(^-^)プロの方々から「データベースの使い方を知ってるのか?」と怒られそうですが、「レコードの並びは、ユーザーが決める」「レコード数はせいぜい数千から1万件程度」を前提条件としています。もちろん、このような場合、リスト+仮想ListView(or StringGrid)が最適なのは、知っていますが、UIとしてDBGridを使うための処理です(^-^)

Usingindex




// COMMON

// サンプルデータを追加します。
procedure MakeSample(CDS: TClientDataSet);
var
  No: Integer;
  F: Boolean;
begin
  F := CDS.Active;
  if not F then
    CDS.Open;
  try
    // サンプルデータの追加
    No := 0;
    with CDS do
    begin
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Starter ESD',10,'本',18000]);
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Professional ESD',5,'本',94000]);
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Enterprise ESD',10,'本',236000]);
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Ultimate ESD',3,'本',356000]);
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Architect ESD',1,'本',416000]);
      CheckBrowseMode;
    end;
  finally
    if not F then
      CDS.Close;
  end;
end;

// データベースの作成
procedure CreateDB(CDS: TClientDataSet);
var
  I: Integer;
begin
  // データベースの作成
  CDS.Close;
  CDS.FieldDefs.Add('ORD',ftInteger);
  CDS.FieldDefs.Add('ITEM',ftWideString,30);
  CDS.FieldDefs.Add('QTY',ftFloat);
  CDS.FieldDefs.Add('UNIT',ftWideString,4);
  CDS.FieldDefs.Add('PRICE',ftCurrency);
  CDS.IndexDefs.Add('ORD_IDX','ORD', [ixPrimary]);
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  // 計算フィールド
  with TCurrencyField.Create(CDS) do
  begin
    FieldName := 'AMOUNT';
    Visible:=True;
    FieldKind := fkInternalCalc;
    DataSet := CDS;
  end;

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    DisplayLabel := '合計';
    DisplayWidth := 10;
    DisplayFormat := '#,###,###,###';
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_F';
    ReadOnly := True;
    Expression := 'SUM(AMOUNT)';
    Active := True;
    DataSet := CDS;
  end;
  CDS.AggregatesActive := True;

  // インデックスの設定
  CDS.IndexName := 'ORD_IDX';

  // 表示用にフィールド幅を設定
  CDS.FieldByName('ORD').DisplayWidth := 3;
  CDS.FieldByName('ITEM').DisplayWidth := 25;
  CDS.FieldByName('QTY').DisplayWidth := 3;
  CDS.FieldByName('UNIT').DisplayWidth := 4;
  CDS.FieldByName('PRICE').DisplayWidth := 8;
  CDS.FieldByName('AMOUNT').DisplayWidth := 10;

  // 計算フィールドの設定
  CDS.OnCalcFields := Form1.CalcFields;

  // DBEditの設定
  Form1.DBEdit1.DataField := 'TOTAL_F';
  CDS.Open;

  // サンプルデータの作成
  MakeSample(CDS);
end;

// DataSetの有効/無効
procedure DataSetEnabled(DataSet: TDataSet; Value: Boolean);
begin
  if Value then
    DataSet.EnableControls
  else
    DataSet.DisableControls;
end;

// Filteredの設定
procedure cdsSetFiltered(CDS: TClientDataSet; F: Boolean);
begin
  if F and (not CDS.Filtered) then
    CDS.Filtered := F
  else if (not F) and CDS.Filtered then
    CDS.Filtered := F;
end;

// Indexの設定
procedure cdsSetIndexFieldNames(CDS: TClientDataSet; S: String);
begin
  if (S <> '') then
    CDS.IndexFieldNames := S
  else
    CDS.IndexName := 'ORD_IDX';
end;

// 追加/挿入項目用の通し番号を返します。
var
  SN: Integer = 0;

function GetSN: String;
begin
  Inc(SN);
  Result := IntToStr(SN);
end;

// UNDO

var
  SP: Integer = -1;

// 現在の状態を保存
procedure SaveUndoPoint(CDS: TClientDataSet);
begin
  // 変更があれば更新させます。
  if CDS.ChangeCount > 0 then
    CDS.MergeChangeLog;
  SP := CDS.SavePoint;
end;

// Undo
procedure Undo(CDS: TClientDataSet);
begin
  if (SP > -1) then
    CDS.SavePoint := SP;
  SP := -1;
end;

// 追加/挿入/削除

// 追加
procedure cdsAppendUsingIndex(CDS: TClientDataSet; Count: Integer = 1);
var
  I, No: Integer;
begin
  //フィルター中と他のインデックスの場合は処理させません。
  if CDS.Filtered or (CDS.IndexName <> 'ORD_IDX') then Exit;

  SaveUndoPoint(CDS);
  DataSetEnabled(CDS, False);
  try
    No := CDS.RecordCount;
    for I := 0 to Count - 1 do
    begin
      Inc(No);

      // 追加します。
      CDS.Insert; // 10000回以下だとAppendより速かったから(^-^)

      // 空白のままだとレコードが追加されません。
      // CDS.FieldByName('ITEM').AsString := '' ←これはOK
      CDS.FieldByName('ITEM').AsString := '追加'+GetSN;
      CDS.FieldByName('ORD').AsInteger := No;
    end;
    CDS.CheckBrowseMode;

    // 今回追加した空白行の先頭レコードに移動させます。
    CDS.MoveBy(1-Count);
  finally
    DataSetEnabled(CDS, True);
  end;
end;

// 挿入
procedure cdsInsertUsingIndex(CDS: TClientDataSet; Count: Integer = 1);
var
  I: Integer;
  NowRec: Integer;
begin
  //フィルター中と他のインデックスの場合は処理させません。
  if CDS.Filtered or (CDS.IndexName <> 'ORD_IDX') then Exit;

  SaveUndoPoint(CDS);
  DataSetEnabled(CDS, False);
  try
    // 挿入位置以後のレコードのORDをCount分増やして更新させます。
    NowRec := CDS.RecNo;
    CDS.RecNo := NowRec;
    CDS.Last;
    while (not CDS.BOF) and (CDS.RecNo >= NowRec) do
    begin
      CDS.Edit;
      CDS.FieldByName('ORD').AsInteger :=
        CDS.FieldByName('ORD').AsInteger + Count;
      CDS.Prior;
    end;
    CDS.CheckBrowseMode;

    // 挿入
    CDS.RecNo := NowRec;
    for I := 0 to Count -1 do
    begin
      CDS.Insert;
      CDS.FieldByName('ITEM').AsString := '挿入'+GetSN;
      CDS.FieldByName('ORD').AsInteger := NowRec;
      Inc(NowRec);
    end;
    CDS.CheckBrowseMode;

    // カーソルを挿入位置に戻します。
    CDS.MoveBy(1-Count);
    //Form1.DBGrid1.SelectedRows.Clear;
  finally
    DataSetEnabled(CDS, True);
  end;
end;

// 削除
procedure cdsDeleteUsingIndex(CDS: TClientDataSet; BMList: TBookmarkList = nil);
var
  I: Integer;
  F: Boolean;
  S: String;
  J: Integer;
begin
  if CDS.RecordCount = 0 then Exit;

  SaveUndoPoint(CDS);
  DataSetEnabled(CDS, False);

  // 取り扱うデータ量によっては、高速化のため計算部分の処理をさせない。
  CDS.AggregatesActive := False;
  CDS.AutoCalcFields := False;
  try
    // 削除対象を削除します。
    // フィルターやインデックスに関係なく選択されたものを削除します。
    if (BMList = nil) or (BMList.Count = 0) then
    begin
      CDS.Delete;
      // レコードの位置
      if CDS.Eof then
        J := CDS.RecordCount
      else
        J := CDS.RecNo;
    end
    else if (BMList.Count = 1) and (not CDS.BookmarkValid(BMList[0])) then
    begin
      // 挿入した後、そのまま削除ボタンを押した時、
      //「レコードが見つかりません」というエラーが表示される時が
      // あるため、その対応です。
      // cdsInsertUsingIndex中でForm1.DBGrid1.SelectedRows.Clear;
      // をすれば、このエラーは発生しない。
      Exit;
    end
    else
    begin
      J := 0;
      for I := BMList.Count -1 downto 0 do
      begin

        CDS.GotoBookmark(BMList[I]);
        if I = BMList.Count -1 then
          J := CDS.FieldByName('ORD').AsInteger;
        CDS.Delete;
      end;
      // レコードの位置
      J := J - BMList.Count+1;
    end;

    // 選択されたままになるのでクリアしておきます。
    BMList.Clear;

    // ORDを通し番号に修正します。

    // フィルターは解除しておきます。
    F := CDS.Filtered;
    cdsSetFiltered(CDS, False);

    // ORD以外のインデックスの場合は、一度ORDに設定します。
    // 基本的に順番用インデックスの入れ替えはしないつもりだけど・・・
    S := CDS.IndexFieldNames;
    cdsSetIndexFieldNames(CDS, '');

    // 番号を揃えます。
    // 本当はBMList[0]のレコードまでを処理するのがいいかな。
    try
      CDS.First;
      while (not CDS.Eof) do
      begin
        if CDS.FieldByName('ORD').AsInteger <> CDS.RecNo then
        begin
          CDS.Edit;
          CDS.FieldByName('ORD').AsInteger := CDS.RecNo;
        end;
        CDS.Next;
      end;
      CDS.CheckBrowseMode;

      // レコード位置を移動させます。
      if J < CDS.RecordCount then
        CDS.RecNo := J
      else
        CDS.Last;
    finally
      cdsSetFiltered(CDS, F);
      cdsSetIndexFieldNames(CDS, S);
    end;
  finally
    CDS.AutoCalcFields := True;
    CDS.AggregatesActive := True;
    DataSetEnabled(CDS, True);
  end;
end;

// TForm1

procedure TForm1.FormCreate(Sender: TObject);
begin
  CreateDB(ClientDataSet1);
  SaveUndoPoint(ClientDataSet1);
end;

// 計算フィールド
procedure TForm1.CalcFields(DataSet: TDataSet);
begin
  DataSet.FieldByName('AMOUNT').AsCurrency :=
    DataSet.FieldByName('QTY').AsFloat *
    DataSet.FieldByName('Price').AsCurrency;
end;

// 追加
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  cdsAppendUsingIndex(ClientDataSet1, StrToIntDef(Edit1.Text,1));
end;

// 挿入
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
  cdsInsertUsingIndex(ClientDataSet1, StrToIntDef(Edit1.Text,1));
end;

// 削除
procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
  cdsDeleteUsingIndex(ClientDataSet1, DBGrid1.SelectedRows);
  ClientDataSet1.AggregatesActive := True;;
end;

// Undo
procedure TForm1.SpeedButton4Click(Sender: TObject);
begin
 if (SP > -1)  then
    Undo(ClientDataSet1)
  else if ClientDataSet1.ChangeCount > 0 then
    ClientDataSet1.UndoLastChange(True);
end;
レコードの順番を登録するフィールド(ここではORD)の番号を、10000毎にするとか、浮動小数点フィールドとかにして、挿入時には、その間の番号を設定すると、番号の打ち直しが減って、処理がより早くなるかも知れないですね。

|

MyBaseを試してみる。(Index、FilterでAggregateが変!?)

Index、Filterを設定するとAggregateの値がおかしくなります。どこか使い方が間違ってるのかな?よくわからないけど、Aggregateを使うときには、このことに注意が必要です。

起動時画面

Incorrect_total1

★Filterプロパティを使った場合
その1
1.[ITEMでソート]を押すと、ITEMでソートされて、合計金額は表示されません。
  ITEMでの並び替えは、合計金額の計算に影響はないでしょうって言いたく
  なりますが、表示されないなら別にいいけどー(^-^)

Incorrect_total11

2.[ORD_IDXでソート]を押すと、再度、合計金額が表示されます。

Incorrect_total12

3.フィルター[ON]を押すと、フィルター処理された合計金額が表示されます。

Incorrect_total13

4.ここで[ITEMでソート]を押すと、なんと合計金額は2倍になりました。

Incorrect_total14

5.驚いて[ORD_IDXでソート]を押すと、合計金額は3倍になりました。

Incorrect_total15

6.これはいけないと思い、フィルター[OFF]を押すと元に戻りました。

Incorrect_total16



その2
1.フィルター[ON]を押して、フィルター処理後の合計金額が正しいことを確認します。

Incorrect_total21

2.フィルター[OFF]を押して、合計金額が正しいことを確認します。

Incorrect_total22

3.[ITEMでソート]を押すと、なんと合計金額は2倍になりました。

Incorrect_total23

4.驚いて[ORD_IDXでソート]を押すと、合計金額は3倍になりました。

Incorrect_total24

5.再び[ITEMでソート]を押すと、なんと合計金額は、4倍になりました。

Incorrect_total25

6.もう一度[ORD_IDXでソート]を押すと、なんと合計金額は、5倍になりました。

Incorrect_total26

[ITEMでソート]、[ORD_IDXでソート]を交互に押すと、合計金額はとどまるところを
知らないようです。(^-^)


★OnFilterRecordを使った場合
その1
1.[ITEMでソート]を押すと・・・ITEMでソートされて、合計金額は表示されません。
2.[ORD_IDXでソート]を押すと・・・再度、合計金額が表示されます。
3.フィルター[ON]を押すと・・・合計金額が表示されません。

Incorrect_total331_2

  しかしここで、次のレコードに移動させるとフィルター処理前の合計金額が
  表示されています。

Incorrect_total332_2

4.ここで[ITEMでソート]を押すと・・・合計金額は表示されません。
5.驚いて[ORD_IDX]を押すと・・・合計金額は表示されません。
6.これはいけないと思い、フィルター[OFF]を押すと・・・合計金額は表示されません。


その2
1.フィルター[ON]を押すと・・・合計金額が表示されません。
  しかしここで、次のレコードに移動させるとフィルター処理前の合計金額が
  表示されました。
2.フィルター[OFF]を押して、合計金額が正しいことを確認します。
  合計金額は正しく表示されました。

Incorrect_total421

  と思ったけど、フィルター処理されたレコードに移動させると、
  合計金額が消えてしまいました。

Incorrect_total422

3.[ITEMでソート]を押すと・・・合計金額は表示されません。
4.驚いて[ORD_IDX]を押すと・・・合計金額は表示されません。
5.[ITEMでソート]を押すと・・・合計金額は表示されません。
6.[ORD_IDXでソート]を押すと・・・合計金額は表示されません。
7.[ITEMでソート]、[ORD_IDXでソート]を交互に押すと・・・
  合計金額は表示されません。


いろいろ試した結果、インデックスを入れ替えず、Filterプロパティでフィルター処理すれば正常な動作をしているようです。フィルター時には、フィルター処理後の合計金額が表示されますし、解除後は、正しい合計金額が表示されました。しかしOnFilterRecordでフィルター処理した場合は、正しく表示されませんでした。
// COMMON

// サンプルデータを追加します。
procedure MakeSample(CDS: TClientDataSet);
var
  No: Integer;
  F: Boolean;
begin
  F := CDS.Active;
  if not F then
    CDS.Open;
  try
    // サンプルデータの追加
    No := 0;
    with CDS do
    begin
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Starter ESD',10,'本',18000]);
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Professional ESD',5,'本',94000]);
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Enterprise ESD',10,'本',236000]);
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Ultimate ESD',3,'本',356000]);
      Inc(No);
      Appendrecord([No, 'Delphi XE2 Architect ESD',1,'本',416000]);
      CheckBrowseMode;
    end;
  finally
    if not F then
      CDS.Close;
  end;
end;

// データベースの作成
procedure CreateDB(CDS: TClientDataSet);
var
  I: Integer;
begin
  // データベースの作成
  CDS.Close;
  CDS.FieldDefs.Add('ORD',ftInteger);
  CDS.FieldDefs.Add('ITEM',ftWideString,30);
  CDS.FieldDefs.Add('QTY',ftFloat);
  CDS.FieldDefs.Add('UNIT',ftWideString,4);
  CDS.FieldDefs.Add('PRICE',ftCurrency);
  CDS.IndexDefs.Add('ORD_IDX','ORD', [ixPrimary]);
  //CDS.IndexDefs.Add('ITEM_IDX','ITEM', []);
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  // 計算フィールド
  with TCurrencyField.Create(CDS) do
  begin
    FieldName := 'AMOUNT';
    Visible:=True;
    FieldKind := fkInternalCalc;
    DataSet := CDS;
  end;

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    DisplayLabel := '合計';
    DisplayWidth := 10;
    DisplayFormat := '#,###,###,###';
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_F';
    ReadOnly := True;
    Expression := 'SUM(AMOUNT)';
    Active := True;
    DataSet := CDS;
  end;
  CDS.AggregatesActive := True;

  // インデックスの設定
  CDS.IndexName := 'ORD_IDX';

  // 表示用にフィールド幅を設定
  CDS.FieldByName('ORD').DisplayWidth := 3;
  CDS.FieldByName('ITEM').DisplayWidth := 25;
  CDS.FieldByName('QTY').DisplayWidth := 3;
  CDS.FieldByName('UNIT').DisplayWidth := 4;
  CDS.FieldByName('PRICE').DisplayWidth := 8;
  CDS.FieldByName('AMOUNT').DisplayWidth := 10;

  // 計算フィールドの設定
  CDS.OnCalcFields := Form1.CalcFields;

  // DBEditの設定
  Form1.DBEdit1.DataField := 'TOTAL_F';
  CDS.Open;

  // サンプルデータの作成
  MakeSample(CDS);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CreateDB(ClientDataSet1);
end;

procedure TForm1.ClientDataSet1FilterRecord(DataSet: TDataSet;
  var Accept: Boolean);
begin
  Accept := AnsiPos(Edit1.Text, DataSet.FieldByName('ITEM').AsString) > 0;
end;


// 計算フィールド
procedure TForm1.CalcFields(DataSet: TDataSet);
begin
  DataSet.FieldByName('AMOUNT').AsCurrency :=
    DataSet.FieldByName('QTY').AsFloat *
    DataSet.FieldByName('Price').AsCurrency;
end;

// フィルターON
procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
  //ClientDataSet1.Filter := 'ITEM LIKE '+QuotedStr('%'+ Edit1.Text+'%');
  ClientDataSet1.Filtered := True;
end;

// フィルターOFF
procedure TForm1.SpeedButton4Click(Sender: TObject);
begin
  ClientDataSet1.Filtered := False;
  ClientDataSet1.Filter := '';
end;

// インデックス ITEM
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
  ClientDataSet1.IndexFieldNames := 'ITEM';
  // ClientDataSet1.IndexName := 'ITEM_IDX';
end;

// インデックス ORD_IDX
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  ClientDataSet1.IndexName := 'ORD_IDX';
end;

// Helpより
// メモ:  IndexFieldNames プロパティと
// IndexName プロパティは相互に排他的です。
// 一方を設定するともう一方はクリアされます。

|

MyBaseを試してみる。(インデックスを使わずに、行の追加、挿入、削除編)

前にも書きましたが、私がBDE(TTable)+Paradoxを使っていて一番便利だと思っていたところはインデックスを設定しなくてもAppendとInsertを使い分けることによって、レコードの順番が保持されるところでした。「データベースなんだからインデックスは、ちゃんと作ろうよ」と言われそうですが、本当なら、リスト構造+TStringGrid(or TListView)のところをDBGridを使うためだけのParadoxだったので、そんな点をメリットに感じていました。まあDBGridも複数行のDrag&Drop、Cut&Pasteを実装したりして、データベースというより表計算のようなソフトになっていましたけど。

だから私はMyBaseにもそんな仕様?を求めていました。同じように動作するならTTable(BDE)との置き換えが簡単かも知れないと期待しながら、そしてメモリ内なんだからインデックスはあったら便利だけど、無くても動くよね~なんて気軽に考えていました。しかしこれがなかなか難しく、結論としてインデックスがない場合のフィルターには対応できませんでした。
(フィルターについては、前回紹介したCloneCursor+2段DBGridで妥協しました)

インデックスを使わないMyBaseで困ったところ等を挙げます。
その1
ClientDataSetは、Append、Insertメソッドを持っており、単純に追加、挿入の処理が
できます。しかし、DBGrid上で、追加、挿入の処理が正しくできているように見えて
も、そのままファイルに保存して、再度読み込むと挿入も追加扱いになっています。
MergeChangeLogメソッドを呼び出した後、ファイルに保存すると正しいレコードの
順番で書き込まれます。

その2
ClientDataSetは、Deltaというプロパティを持っており、そこに変更されたデータを
保存しています。そのため、元に戻す処理も簡単にできるようになっています。
しかしながら、Insertで挿入したレコードやDeleteで削除したレコードは、最終行に
戻されるだけです。

その3
フィルター処理し解除した場合、挿入したレコードは、追加扱いになっています。
MergeChangeLogメソッドを呼び出して、ファイルに保存すれば正しく動作すること
から、フィルター前にいろんなことを試してみましたが、一度目は成功してもなぜか
二度目以降は正しく動作しませんでした。
(この記事の最後にどのような処理をしたか、書き残しておきますね)

その4
複数行の処理を元に戻すためにSavePointを利用しています。一度に処理した内
容は、一度に元に戻したいからです。
そのため、元に戻す処理は1度しか使えない仕様でプログラムしています。
デザイン画面

Design_3



var
  RecNoList: TList<Integer>; // Undoに使用
  SP: Integer = -1;          // Undoの処理に使用
  SN: Integer = 0;

// サンプルデータ
procedure MakeSample(DataSet: TDataSet);
var
  F: Boolean;
begin
  F := DataSet.Active;
  if not F then
    DataSet.Open;
  try
    // サンプルデータの追加
    with DataSet do
    begin
      Appendrecord(['iPod Touch']);
      Appendrecord(['Zaurus C-860']);
      Appendrecord(['Delphi 2009 Handbook']);
      Appendrecord(['GEORGIA BLACK']);
      CheckBrowseMode;
    end;
  finally
    if not F then
      DataSet.Close;
  end;
end;

// データベースの作成
procedure CreateDB(CDS: TClientDataSet; UsingIndex: Boolean);
var
  I: Integer;
begin
  CDS.Close;
  CDS.FieldDefs.Add('ITEM',ftWideString,20);
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  CDS.Open;
  MakeSample(CDS);
end;

// DataSetの有効/無効
procedure DataSetEnabled(DataSet: TDataSet; Value: Boolean);
begin
  if Value then
    DataSet.EnableControls
  else
    DataSet.DisableControls;
end;

// SaveToFile
procedure cdsSaveToFile(CDS: TClientDataSet;
  const FileName: String);
begin
  if CDS.ChangeCount > 0 then
    CDS.MergeChangeLog;
  CDS.SaveToFile(FileName);
end;

// LoadFromFile
procedure cdsLoadFromFile(CDS: TClientDataSet;
  const FileName: String);
begin
  CDS.LoadFromFile(FileName);
end;

// 通し番号を返します。別に要らない処理です。
function GetSN: String;
begin
  Inc(SN);
  Result := IntToStr(SN);
end;

// 現在の状態を保存
procedure SaveUndoPoint(CDS: TClientDataSet);
begin
  // 変更があれば更新させます。
  if CDS.ChangeCount > 0 then
    CDS.MergeChangeLog;
  SP := (CDS as TClientDataSet).SavePoint;
end;

// SavePointから元に戻す処理
procedure Undo(CDS: TClientDataSet);
begin
  if SP > -1 then
    CDS.SavePoint := SP;
  SP := -1;
end;

// 削除されたレコードを元に戻す処理 ※コテコテ(^-^)
procedure UndoDelete(CDS: TClientDataSet);
var
  I, RC, RecNo: Integer;
  Delta: TClientDataSet;
begin
  if (RecNoList.Count <> 0) and (CDS.ChangeCount > 0) then
  begin
    Delta := TClientDataSet.Create(nil);
    try
      Delta.Data := CDS.Delta;
      Delta.Open;
      Delta.Last;
      I := -1;
      RC := CDS.RecordCount;

      // Deltaから順番に戻していきます。
      while not Delta.Bof do
      begin
        Inc(I);
        if I < RecNoList.Count then
        begin
          RecNo := RecNoList[I];
          if RecNo > RC then
          begin
            CDS.Append;
            Inc(RC);
          end
          else
          begin
            CDS.RecNo := RecNo;
            CDS.Insert;
            Inc(RC);
          end;
          CDS.FieldByName('Item').AsString :=
            Delta.FieldByName('Item').AsString;
        end;
        Delta.Prior;
      end;
      CDS.CheckBrowseMode;
      CDS.MergeChangeLog;
      RecNoList.Clear;
    finally
      Delta.Free;
    end;
  end;
end;

// Undo
procedure cdsUndoNoIndex(CDS: TClientDataSet);
begin
    if RecNoList.Count > 0 then
    UndoDelete(CDS)            // 削除
  else if (SP > -1)  then
    Undo(CDS)                  // 追加/挿入-SavePoint
  else if CDS.ChangeCount > 0 then
    CDS.UndoLastChange(True);  // 上記以外
end;

// 追加
procedure cdsAppendNoIndex(CDS: TClientDataSet;
  Count: Integer = 1);
var
  I: Integer;
begin
  SaveUndoPoint(CDS);
  DataSetEnabled(CDS, False);
  try
    // Count分空白行を追加します。
    for I := 0 to Count - 1 do
    begin
      // 追加します。
      CDS.Append;
      CDS.FieldByName('ITEM').AsString := '追加'+ GetSN;
    end;
    CDS.CheckBrowseMode;
    // 今回追加した空白行の先頭レコードに移動させます。
    CDS.MoveBy(1-Count);
  finally
    DataSetEnabled(CDS, True);
  end;
end;

// 挿入
procedure cdsInsertNoIndex(CDS: TClientDataSet;
  Count: Integer = 1);
var
  I: Integer;
begin
  SaveUndoPoint(CDS);
  DataSetEnabled(CDS, False);
  try
    for I := 0 to Count -1 do
    begin
      // 挿入します。
      CDS.Insert;
      CDS.FieldByName('ITEM').AsString := '挿入'+ GetSN;
    end;
      CDS.CheckBrowseMode;
  finally
    DataSetEnabled(CDS, True);
  end;
end;

// 削除
procedure cdsDeleteNoIndex(CDS: TClientDataSet;
  BMList: TBookmarkList = nil);
type
  TIntegerComparer = TComparer<Integer>>;
var
  I: Integer;
begin
  // セル編集時は、BMList.Countは0です。
  // その場合の処理は含まれていないです。
  if not Assigned(BMList) then Exit;

  RecNoList.Clear;
  SaveUndoPoint(CDS);
  DataSetEnabled(CDS, False);
  try
    if Assigned(BMList) and (BMList.Count > 0) then
    begin
     for I := BMList.Count -1 downto 0 do
      begin
        CDS.GotoBookmark(BMList[I]);
        RecNoList.Add(CDS.RecNo);
        CDS.Delete;
      end;
      BMList.Clear;
    end;

    // RecNoListのソート
    RecNoList.Sort(TComparer<Integer>.Default);
  finally
    DataSetEnabled(CDS, True);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Undo用
  RecNoList:= TList<Integer>.Create;
  // データベースの作成
  CreateDB(ClientDataSet1, False);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(RecNoList);
end;

procedure TForm1.ClientDataSet2FilterRecord(DataSet: TDataSet;
  var Accept: Boolean);
begin
  Accept :=
    AnsiPos(Edit2.Text, DataSet.FieldByName('ITEM').AsString) > 0
end;

// SaveToFile
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  FileName: String;
begin
  FileName := ExtractFilePath(Application.ExeName) + 'MyBase.cds';
  cdsSaveToFile(ClientDataSet1,FileName);
end;

// LoadFromFile
procedure TForm1.SpeedButton2Click(Sender: TObject);
var
  FileName: String;
begin
  FileName := ExtractFilePath(Application.ExeName) + 'MyBase.cds';
  if FileExists(FileName) then
    cdsLoadFromFile(ClientDataSet1, FileName);
end;

// 追加
procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
  cdsAppendNoIndex(ClientDataSet1, StrToIntDef(Edit1.Text,1));
end;

// 挿入
procedure TForm1.SpeedButton4Click(Sender: TObject);
begin
  cdsInsertNoIndex(ClientDataSet1, StrToIntDef(Edit1.Text,1));
end;

// 削除
procedure TForm1.SpeedButton5Click(Sender: TObject);
begin
  cdsDeleteNoIndex(ClientDataSet1, DBGrid1.SelectedRows);
end;

// Undo
procedure TForm1.SpeedButton6Click(Sender: TObject);
begin
  cdsUndoNoIndex(ClientDataSet1);
end;

// Filter
procedure TForm1.SpeedButton7Click(Sender: TObject);
begin
  ClientDataSet2.Filtered := not ClientDataSet2.Filtered;
  if ClientDataSet2.Filtered then
  begin
    ClientDataSet2.CloneCursor(ClientDataSet1, TRUE, False);
    ClientDataSet2.OnFilterRecord := ClientDataSet2FilterRecord;
    ClientDataSet2.Filtered := True;
  end
  else
    ClientDataSet2.Close;
end;

実行時画面

Runtime



フィルター処理の前に試したこと(^-^)
// 次のcdsUpdate0~cdsUpdate3までいずれも役に
// 立ちませんでした。
// いずれもClientDataSet1.Filtered := Trueの前に
// 入れてテストしたものです。

// ファイルの読み書きが正しくできるなら
// 採用するかどうかは別として
// この処理で動作すると考えた。
// 2度目以降使えない(T_T)
procedure cdsUpdate0(CDS: TClientDataSet);
begin
  Form1.SpeedButton1Click(nil);
  Form1.SpeedButton2Click(nil);
end;

procedure cdsUpdate1(CDS: TClientDataSet);
var
  Data: OleVariant;
begin
  // 2度目以降使えない(T_T)
  if CDS.ChangeCount > 0 then
    CDS.MergeChangeLog;
  Data := CDS.Data;
  CDS.Data := Data;
end;

procedure cdsUpdate2(CDS: TClientDataSet);
var
   MS: TMemoryStream;
begin
  // 2度目以降使えない(T_T)
  if CDS.ChangeCount > 0 then
    CDS.MergeChangeLog;
  MS := TMemoryStream.Create;
  try
    CDS.SaveToStream(MS, dfBinary);
    MS.Position := 0;
    CDS.LoadFromStream(MS);
  finally
   MS.Free;
  end;
end;

procedure cdsUpdate3(CDS: TClientDataSet);
var
   SL1, SL2: TStringList;
   I, J: Integer;
   FieldName, Value: String;
begin
  // こんなコテコテの処理をしたところで、
  // フィルターで編集されたデータは、
  // 一番最後に移動してしまいます。
  if CDS.ChangeCount > 0 then
    CDS.MergeChangeLog;
  SL1 := TStringList.Create;
  SL2 := TStringList.Create;
  try
    SL1.StrictDelimiter := True;
    SL1.Delimiter := ',';
    CDS.DisableControls;
    try
      CDS.First;
      while not CDS.EOF do
      begin
        SL1.Clear;
        for I := 0 to CDS.Fields.Count -1 do
          if (CDS.Fields[I].FieldKind = fkData) then
          SL1.Add(CDS.Fields[I].FieldName +'='+  CDS.Fields[I].AsString);

        SL2.Add(SL1.CommaText);
        CDS.Next;
      end;
      
      // 次の処理はEmptyDataSetを使う方が簡単
      CDS.Last;
      while not CDS.BOF do
        CDS.Delete;

      for I := 0 to SL2.Count-1 do
      begin
        SL1.CommaText := SL2[I];
        CDS.Append;
        for J := 0 to SL1.Count-1 do
        begin
          FieldName := SL1.Names[J];
          Value := SL1.Values[FieldName];
          CDS.FieldByName(FieldName).AsString := Value;
        end;
      end;
      CDS.CheckBrowseMode;

    finally
      CDS.EnableControls;
    end;

  finally
    SL2.Free;
    SL1.Free;
  end;
end;


MyBaseを試してみる。(インデックスを使わずに、行の追加、挿入、削除編) REVENGE(^o^)もご覧下さい。

|

MyBaseを試してみる。(CloneCursorでOnFilterRecord)

次のようにDBGridを2段配置して、下段にフィルター処理されたレコードを表示させてみました。期待する動作は、 CloneCursorでClientDataSet2を設定し、更にClientDataSet2.OnFilterRecordを設定して、それによりフィルター処理されることです。

Design_2


// サンプルデータ
procedure MakeSample(DataSet: TDataSet);
var
  No: Integer;
  F: Boolean;
begin
  F := DataSet.Active;
  if not F then
    DataSet.Open;
  try
    // サンプルデータの追加
    No := 0;
    with DataSet do
    begin
      Appendrecord(['iPod Touch']);
      Appendrecord(['Zaurus C-860']);
      Appendrecord(['Delphi 2009 Handbook']);
      Appendrecord(['GEORGIA BLACK']);
      CheckBrowseMode;
    end;
  finally
    if not F then
      DataSet.Close;
  end;
end;

// データベースの作成
procedure CreateDB(CDS: TClientDataSet; UsingIndex: Boolean);
var
  I, No: Integer;
begin
  CDS.Close;
  CDS.FieldDefs.Add('ITEM',ftWideString,20);
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  CDS.Open;
  MakeSample(CDS);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // データベースの作成
  CreateDB(ClientDataSet1, False);
end;

procedure TForm1.ClientDataSet1FilterRecord(DataSet: TDataSet;
  var Accept: Boolean);
begin
  Accept := AnsiPos(Edit1.Text,DataSet.FieldByName('ITEM').AsString) > 0
end;

procedure TForm1.ClientDataSet2FilterRecord(DataSet: TDataSet;
  var Accept: Boolean);
begin
  Accept := AnsiPos(Edit2.Text, DataSet.FieldByName('ITEM').AsString) > 0
end;


// Filter
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  ClientDataSet2.Filtered := not ClientDataSet2.Filtered;
  if ClientDataSet2.Filtered then
  begin
    ClientDataSet2.CloneCursor(ClientDataSet1, False, False);
    ClientDataSet2.Filtered := True;
  end;
end;


しかしながら、いざ実行してみると正しくフィルターできませんでした。というかClientDataSet1のOnFilterRecordのデータが表示されています。

Tryfilter_2


CloneCursorのヘルプを読んでみると、第2のパラメーターの設定によることがわかりました。
procedure CloneCursor(Source: TCustomClientDataSet;
  Reset: Boolean;  KeepSettings: Boolean = False); virtual;

Online Help for Delphi® XE2 and C++Builder® XE2 DBClient.TCustomClientDataSet.CloneCursor
日本語ページを見つけられなかったので、ヘルプを読んでね(^-^)


CloneCursor側のOnFilterRecordを使う場合には、次のようにすると動作しました。
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  ClientDataSet2.Filtered := not ClientDataSet2.Filtered;
  if ClientDataSet2.Filtered then
  begin
    ClientDataSet2.CloneCursor(ClientDataSet1, TRUE, False);
    ClientDataSet2.OnFilterRecord := ClientDataSet2FilterRecord;
    ClientDataSet2.Filtered := True;
  end;
end;

Correct_2

|

MyBaseを試してみる。(AppendとInsert)

インデックスで順番を処理するなら AppendInsert も同じ使い方ができますよね。そこで、ふと疑問に思ったのですが、AppendInsert、この二つの処理はどちらが早いのでしょうか。

ClientDataSet1->DataSource1->DBGrid1と接続し、下記のプログラムで100, 300, 500, 1000, 3000, 5000, 10000, 30000, 50000レコードを AppendInsert を使って追加し、計測してみました。(基本的に3回ずつ)

// サンプルデータを追加します。
procedure MakeSample(CDS: TClientDataSet);
var
  No: Integer;
  F: Boolean;
begin
  F := CDS.Active;
  if not F then
    CDS.Open;
  try
    // サンプルデータの追加
    No := 0;
    with CDS do
    begin
      Inc(No);
      Appendrecord([No, 'iPod Touch','mobile']);
      Inc(No);
      Appendrecord([No, 'Zaurus C-860','mobile']);
      Inc(No);
      Appendrecord([No, 'Delphi 2009 Handbook','book']);
      Inc(No);
      Appendrecord([No, 'GEORGIA BLACK','Coffee']);
      CheckBrowseMode;
    end;
  finally
    if not F then
      CDS.Close;
  end;
end;

// データベースの作成
procedure CreateDB(CDS: TClientDataSet);
var
  I: Integer;
begin
  CDS.Close;
  CDS.FieldDefs.Add('ORD',ftInteger);
  CDS.FieldDefs.Add('ITEM',ftWideString,20);
  CDS.FieldDefs.Add('ITEM2',ftWideString,20);
  CDS.IndexDefs.Add('OrderNo','ORD', [ixPrimary]);
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  // インデックスの設定
  CDS.IndexName := 'OrderNo';
  CDS.Open;
  MakeSample(CDS);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CreateDB(ClientDataSet1);
end;

const
  K = 20000; // 回数
// Append
procedure TForm1.Button1Click(Sender: TObject);
var
  T: Cardinal;
  I: Integer;
begin
  T := GetTickCount;
  ClientDataset1.DisableControls;
  try
    for I := 0 to K-1 do
    begin
      ClientDataSet1.Append;
      ClientDataSet1.FieldByName('ITEM').AsString := 'Test';
      ClientDataSet1.FieldByName('ORD').AsInteger :=
        ClientDataSet1.RecordCount+1;
    end;
    ClientDataset1.CheckBrowseMode;
  finally
    ClientDataset1.EnableControls;
  end;
  Memo1.Lines.Add('Append:'+IntToStr(K)+
    FormatFloat(' #,##0 msec',GetTickCount-T));
end;

// Insert
procedure TForm1.Button2Click(Sender: TObject);
var
  T: Cardinal;
  I: Integer;
begin
  T := GetTickCount;
  ClientDataset1.DisableControls;
  try
    for I := 0 to K-1 do
    begin
      ClientDataSet1.Insert;
      ClientDataSet1.FieldByName('ITEM').AsString := 'Test';
      ClientDataSet1.FieldByName('ORD').AsInteger :=
        ClientDataSet1.RecordCount+1;
    end;
    ClientDataset1.CheckBrowseMode;
  finally
    ClientDataset1.EnableControls;
  end;
  Memo1.Lines.Add('Insert:'+IntToStr(K)+
    FormatFloat(' #,##0 msec',GetTickCount-T));
end;

[100回]
Append:100 0 msec
-------------------
Insert:100 0 msec

[300回]
Append:300 15 msec
Append:300 0 msec
Append:300 16 msec
-------------------
Insert:300 0 msec
Insert:300 16 msec
Insert:300 0 msec

[500回]
Append:500 16 msec
Append:500 15 msec
Append:500 16 msec
-------------------
Insert:500 0 msec
Insert:500 0 msec
Insert:500 0 msec

[1000回]
Append:1000 15 msec
Append:1000 15 msec
Append:1000 16 msec
-------------------
Insert:1000 15 msec
Insert:1000 15 msec
Insert:1000 16 msec

[3000回]
Append:3000 47 msec
Append:3000 46 msec
Append:3000 46 msec
-------------------
Insert:3000 31 msec
Insert:3000 31 msec
Insert:3000 31 msec

[5000回]
Append:5000 63 msec
Append:5000 62 msec
Append:5000 62 msec
-------------------
Insert:5000 47 msec
Insert:5000 47 msec
Insert:5000 47 msec

[10000回]
Append:10000 109 msec
Append:10000 109 msec
Append:10000 109 msec
---------------------
Insert:10000 109 msec
Insert:10000 109 msec
Insert:10000 110 msec

[20000回]
Append:20000 218 msec
Append:20000 218 msec
Append:20000 203 msec
---------------------
Insert:20000 265 msec
Insert:20000 281 msec
Insert:20000 281 msec

[30000回]
Append:30000 312 msec
Append:30000 312 msec
Append:30000 343 msec
---------------------
Insert:30000 499 msec
Insert:30000 484 msec
Insert:30000 483 msec

[50000回]
Append:50000 530 msec
Append:50000 546 msec
Append:50000 531 msec
-----------------------
Insert:50000 1,108 msec
Insert:50000 1,123 msec
Insert:50000 1,123 msec

[PC]
CPU: Intel Core i5-2400
Mem: 4GB
Delphi XE2 pro
※F9で実行させて、計測して終了させて、また実行させて計測して・・・(^-^) 

これらからおよそ10000回までの追加については、Insert、それ以上の場合には、Appendを使うといいかも知れません。テストのフィールドが単純なので、あくまでも参考データですけどね。

今回はGetTickCountで計測していますが、処理にかかった時間をより厳密に計算するには、timeGetTime を使います。

totonicaさんのサイト
Watercolor City
経過時間を計測する

|

TDBGridの描画が変!?(MyBase接続時)

TCustomDBGridから派生した自作コンポーネントの修正をしていたのですが、時々描画がおかしくなるときがあり、いろいろ調べてみるとTDBGrid自体の描画が変な時がありました。

その1
TDBGridは、標準機能としてMouseOverでColumnsが強調表示されます。標準のテーマではわかりにくかったので、VCL StyleのGolden Graphiteを使っています。

Dbgrid1


しかし次のように先頭レコードのインジゲーター部分も強調表示されています。(他のレコードでは表示されない)まあ、これは気にするほどのことではないです。

Dbgrid2



その2
編集時にマウスの移動によって、セルの描画がおかしくなります。文字部分は、InplaceEditorが扱っているので、問題ないですけど、場合によっては、インジゲーターのアイコンが表示されたりします。結果として、ADTを使わない場合、ClientDataSet1.ObjectViewをFalseにすると問題なく描画されるようになりました。ADTがある場合は、Falseに設定していたとしても自動的にTrueになるようで、解決できませんでした。

アンダーラインのようなもの?(カラムが描画されてるのかも)

Dbgrid_underline


フォーカス枠の残り?

Dbgrid_error2


描画のタイミングが悪い?

Dbgrid_error3


Delphi2007とDelphi2009でも試してみましたが、こちらでは全く問題なかったです。(まあグリッドの描画があれですけど)

Dbgrid_2009_2




試しにDefaultDrawingをFalseに設定して、試してみました。 マウスを動かすとカラムのタイトルやインジゲーターアイコンが表示されます。 上手くマウスを動かすとこんな描画になります(^-^)こんなものがDefaultDrawingを使わなくても描画されていたら、オーナードローでは解決できなさそうです。(InplaceEditor表示後に描画されているのが厄介です)

Dbgrid_error4


Dbgrid_nodefaultdraw



ならば、DrawCellを全く表示させないとどうなるかを試してみました。 やはりDrawCell以外の部分での描画が影響しているようですね。

Dbgrid_nodrawcell



  TDBGridTest = class(TDBGrid)
  protected
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
      AState: TGridDrawState); override;
  end;

procedure TDBGridTest.DrawCell(ACol, ARow: Integer; ARect: TRect;
  AState: TGridDrawState);
begin
  Exit;
  inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // TStyleManager.TrySetStyle('Golden Graphite');
  with ClientDataSet1 do
  begin
    FieldDefs.Add('ID',ftAutoInc);
    FieldDefs.Add('ITEM',ftWideString,10);
    FieldDefs.Add('QTY',ftFloat);
    FieldDefs.Add('UNIT',ftWideString,4);
    FieldDefs.Add('PRICE',ftCurrency);
    CreateDataSet;

    Append;
    FieldByName('ITEM').AsString := 'PEN';
    FieldByName('QTY').AsInteger := 10;
    FieldByName('UNIT').AsString := '本';
    FieldByName('PRICE').AsString := '1000';
    Append;
    FieldByName('ITEM').AsString := 'Fan';
    FieldByName('QTY').AsInteger := 3;
    FieldByName('UNIT').AsString := '台';
    FieldByName('PRICE').AsString := '30000';
    Append;
    FieldByName('ITEM').AsString := 'PC';
    FieldByName('QTY').AsInteger := 1;
    FieldByName('UNIT').AsString := '台';
    FieldByName('PRICE').AsString := '180000';
    CheckBrowseMode;
  end;

  TestDBGrid:= TDBGridTest.Create(Self);
  TestDBGrid.Parent := self;
  TestDBGrid.align := alClient;
  DataSource1.DataSet := ClientDataSet1;
  TestDBGrid.DataSource := DataSource1;
end;

|

MyBaseを試してみる。(フィールド作成編)

私が過去に作ったソフトの中には、DBGridを使うためだけに、BDE(TTable)+Paradoxを採用しているものがたくさんありました。TStringGridだとColumnsやPickListの実装が面倒ですし、TListViewも編集が伴う場合は、UIとしては今ひとつですしね。
特にParadoxではレコードを追加する場合 Insert、Append を使い分ければ、インデックスを設定することなくデータの順番も保持されるため、リスト構造を扱うような感覚で簡単にプログラムができました。Paradoxは、Windows7であっても下記のサイトを参考すれば、まだなんとか使えなくもない。しかしながら今後のことを考えるといつまでも甘えているわけにはいかない状況です。
というか、いまだに使ってるの?というレベルかも知れませんけど(^-^)

DEKOのアヤシいお部屋。
今更ながら BDE (Borland Database Engine)

教えて!goo
BDE初期化中にエラーが発生しました。$210D

データベースは必要ないものの、TDBGridで処理をしたい・・・そんな用途にはシンプルにMyBaseが便利かも知れません。ただ私は今までMyBaseを本格的に扱ったことがないので、いろいろ調べてみようと思います。今回は、実行時にフィールドを作成してみました。わざわざフィールドの定義・作成を取り上げたのは、ADT、計算項目、集合項目を使う場合の設定とかの情報があまりなさそうだったからです。あっ、ちなみに今回もいつものように試行錯誤の結果です(^-^)
各設定とそれを実行した場合のショットになっています。

procedure Test1(CDS: TClientDataSet);
var
  C: TCurrencyField;
  I: Integer;
begin
  InitCDS(CDS);
  CDS.FieldDefs.Add('ID',ftAutoInc);
  CDS.FieldDefs.Add('ITEM',ftWideString,10);
  CDS.FieldDefs.Add('QTY',ftFloat);
  CDS.FieldDefs.Add('UNIT',ftWideString,4);
  CDS.FieldDefs.Add('PRICE',ftCurrency);
  CDS.CreateDataSet;
end;

Test1



procedure Test2(CDS: TClientDataSet);
var
  I: Integer;
  Aggregate: TAggregate;
begin
  InitCDS(CDS);
  CDS.FieldDefs.Add('ID',ftAutoInc);
  CDS.FieldDefs.Add('ITEM',ftWideString,10);
  CDS.FieldDefs.Add('QTY',ftFloat);
  CDS.FieldDefs.Add('UNIT',ftWideString,4);
  CDS.FieldDefs.Add('PRICE',ftCurrency);
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  // 計算フィールド
  with TCurrencyField.Create(CDS) do
  begin
    FieldName := 'AMOUNT';
    Visible:=True;
    FieldKind := fkInternalCalc;
    DataSet := CDS;
  end;

  // 集合項目
  Aggregate := TAggregate.Create(CDS.Aggregates, CDS);
  Aggregate.AggregateName := 'TOTAL';
  Aggregate.Expression := 'SUM(AMOUNT)';
  Aggregate.GroupingLevel := 0;
  Aggregate.Active := True;

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    DisplayLabel := '合計';
    DisplayWidth := 10;
    DisplayFormat := '#,###,###,###';
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_F';
    ReadOnly := True;
    Expression := 'SUM(AMOUNT)';
    Active := True;
    DataSet := CDS;
  end;
  Form1.DBEdit1.DataField := 'TOTAL_F';
  CDS.AggregatesActive := True;
  CDS.Open;
end;

Test2



procedure Test3(CDS: TClientDataSet);
var
  I: Integer;
  Aggregate: TAggregate;
begin
  InitCDS(CDS);

  CDS.FieldDefs.Add('ID', ftAutoInc);
  with CDS.FieldDefs.AddFieldDef do
  begin
    Name := 'ITEM';
    DataType := ftADT;
    Size := 2;
    ChildDefs.Add('ITEM1', ftString, 10);
    ChildDefs.Add('ITEM2', ftString, 10);
  end;
  with CDS.FieldDefs.AddFieldDef do
  begin
    Name := 'ESTIMATE';
    DataType := ftADT;
    Size := 4;
    ChildDefs.Add('QTY'   , ftFloat);
    ChildDefs.Add('UNIT'  , ftString, 4);
    ChildDefs.Add('PRICE' , ftCurrency);
    ChildDefs.Add('AMOUNT' , ftCurrency);
  end;
  CDS.CreateDataSet;
  CDS.Close;

  for I := 0 to CDS.FieldDefs.Count - 1 do
    CDS.FieldDefs[I].CreateField(CDS);

  // 計算フィールド  fkInternalCalcではなぜか計算されない。
  // 内部計算項目(fkInternalCalc)でないと集合型で使えない。
  CDS.FieldByName('ESTIMATE.AMOUNT').FieldKind := fkCalculated;

  // 集合項目
  Aggregate := TAggregate.Create(CDS.Aggregates, CDS);
  Aggregate.AggregateName := 'TOTAL';
  Aggregate.Expression := 'SUM(ESTIMATE.QTY*ESTIMATE.PRICE)';
  Aggregate.Active := True;

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    DisplayLabel := '合計';
    DisplayWidth := 10;
    DisplayFormat := '#,###,###,###';
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_F';
    ReadOnly := True;
    Expression := 'SUM(ESTIMATE.QTY*ESTIMATE.PRICE)';
    GroupingLevel := 0;
    IndexName := 'ID';
    Active := True;
    DataSet := CDS;
  end;
  Form1.DBEdit1.DataField := 'TOTAL_F';
  CDS.AggregatesActive := True;
  CDS.Open;
end;

Test3



// DBGridのカラムの設定をしなくてもいいぐらい
// 細かく設定できます。
// オブジェクトインスペクタでも作成できますけど
// 今回のテーマは実行時に作成なので(^-^)
procedure Test4(CDS: TClientDataSet);
var
  Aggregate: TAggregate;
begin
  InitCDS(CDS);

  with TAutoIncField.Create(CDS) do
  begin
    DisplayLabel := 'ID';
    DisplayWidth := 5;
    AutoGenerateValue := arAutoInc;
    ReadOnly := True;
    FieldKind := fkData;
    FieldName := 'ID';
    DataSet := CDS;
  end;

  with TWideStringField.Create(CDS) do
  begin
    Alignment := taLeftJustify;
    DisplayLabel := '名称';
    DisplayWidth := 10;
    FieldKind := fkData;
    FieldName := 'ITEM';
    Size := 10;
    Name := 'CDS_ITEM';  // NAMEは省略しても動作します。
    // OnValidate := xxxx; イベントの割り当ても可
    DataSet := CDS;
  end;

  with TFloatField.Create(CDS) do
  begin
    Alignment := taRightJustify;
    DisplayLabel := '数量';
    DisplayWidth := 10;
    FieldKind := fkData;
    FieldName := 'QTY';
    Name :='CDS_QTY';
    DataSet := CDS;
  end;

  with TWideStringField.Create(CDS) do
  begin
    Alignment := taCenter;
    DisplayLabel := '単位';
    Alignment := taCenter;
    DisplayWidth := 4;
    FieldKind := fkData;
    FieldName := 'UNIT';
    Size := 4;
    Name := 'CDS_UNIT';
    DataSet := CDS;
  end;

  with TCurrencyField.Create(CDS) do
  begin
    Alignment := taRightJustify;
    DisplayFormat := '###,###,##0.##';
    DisplayLabel := '単価';
    DisplayWidth := 10;
    EditFormat := '########0.##';
    FieldKind := fkData;
    FieldName := 'PRICE';
    Name := 'CDS_PRICE';
    DataSet := CDS;
  end;

  with TCurrencyField.Create(CDS) do
  begin
    Alignment := taRightJustify;
    DisplayFormat := '#,###,###,##0.##';
    DisplayLabel := '金額';
    DisplayWidth := 11;
    EditFormat := '#########0.##';
    FieldKind := fkInternalCalc;
    FieldName := 'AMOUNT';
    //ReadOnly := True;
    Name := 'CDS_AMOUNT';
    DataSet := CDS;
  end;
  CDS.CreateDataSet;
  CDS.Close;

  // 集合項目
  Aggregate := TAggregate.Create(CDS.Aggregates, CDS);
  Aggregate.AggregateName := 'TOTAL';
  Aggregate.Expression := 'SUM(AMOUNT)';
  Aggregate.GroupingLevel := 0;
  Aggregate.Active := True;

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    DisplayLabel := '合計';
    DisplayWidth := 10;
    DisplayFormat := '#,###,###,###';
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_F';
    ReadOnly := True;
    Expression := 'SUM(AMOUNT)';
    Active := True;
    DataSet := CDS;
  end;
  Form1.DBEdit1.DataField := 'TOTAL_F';

  CDS.AggregatesActive := True;
  CDS.Open;
end;

Test4



procedure Test5(CDS: TClientDataSet);
var
  S: String;
  ADT: TADTField;
  Aggregate: TAggregate;
begin
  InitCDS(CDS);

  // ID
  with TAutoIncField.Create(CDS) do
  begin
    DisplayLabel := 'ID';
    DisplayWidth := 5;
    AutoGenerateValue := arAutoInc;
    ReadOnly := True;
    FieldKind := fkData;
    FieldName := 'ID';
    DataSet := CDS;
  end;

  // 項目
  ADT := TADTField.Create(CDS);
  ADT.DisplayLabel := '名称';
  ADT.FieldName := 'ITEM';
  ADT.OnGetText := Form1.GetText;

  // 項目1
  with TWideStringField.Create(ADT) do
  begin
    DisplayLabel := '項目1';
    FieldName := 'ITEM1';
    Size := 10;
    Visible:=True;
    ParentField:=ADT;
  end;

  // 項目2
  with TWideStringField.Create(ADT) do
  begin
    DisplayLabel := '項目2';
    FieldName := 'ITEM2';
    Size := 10;
    Visible:=True;
    ParentField:=ADT;
  end;
  ADT.DataSet := CDS;

  // 見積
  ADT := TADTField.Create(CDS);
  ADT.DisplayLabel := '見積';
  ADT.FieldName := 'ESTIMATE';
  ADT.OnGetText := Form1.GetText;

  // 数量
  with TFloatField.Create(ADT) do
  begin
    DisplayLabel := '数量';
    FieldName :=  'QTY';
    Visible:=True;
    ParentField:=ADT;
  end;

  // 単位
  with TWideStringField.Create(ADT) do
  begin
    DisplayLabel := '単位';
    Alignment := taCenter;
    FieldName := 'UNIT';
    Size := 4;
    Visible:=True;
    ParentField:=ADT;
  end;

  // 単価
  with TCurrencyField.Create(ADT) do
  begin
    DisplayLabel := '単価';
    FieldName := 'PRICE';
    Visible:=True;
    ParentField:=ADT;
  end;

  // 金額
  with TCurrencyField.Create(ADT) do
  begin
    DisplayLabel := '金額';
    FieldName := 'AMOUNT';
    Visible:=True;
    //なぜかfkInternalCalcでは計算されない;
    FieldKind := fkCalculated;  
    ParentField:=ADT;
  end;
  ADT.DataSet := CDS;
  CDS.CreateDataSet;
  CDS.Close;

  // 集合項目
  Aggregate := TAggregate.Create(CDS.Aggregates, CDS);
  Aggregate.AggregateName := 'TOTAL';
  Aggregate.Expression := 'SUM(ESTIMATE.QTY*ESTIMATE.PRICE)';
  Aggregate.GroupingLevel := 0;
  Aggregate.Active := True;

  // 集合フィールド
  with TAggregateField.Create(CDS) do
  begin
    DisplayLabel := '合計';
    DisplayWidth := 10;
    DisplayFormat := '#,###,###,###';
    AlignMent := taRightJustify;
    FieldKind := fkAggregate;
    FieldName := 'TOTAL_F';
    ReadOnly := True;
    Expression := 'SUM(ESTIMATE.QTY*ESTIMATE.PRICE)';
    Active := True;
    DataSet := CDS;
    Name := S + FieldName;
  end;
  Form1.DBEdit1.DataField := 'TOTAL_F';
 CDS.AggregatesActive := True;
 CDS.Open;
end;

Test5



ADTを折りたたむとこんな感じです。そう言えば、折りたたみのためのアイコン(三角マーク)が表示されていないですね。折りたたむには、名称と見積の各セルの右側部分をクリックします。
// ADT項目の表示
procedure TForm1.GetText(Sender: TField; var Text: String;
  DisplayText: Boolean);
begin
  if Sender.FieldName = 'ITEM' then
    Text := ClientDataSet1.FieldByName('ITEM.ITEM1').AsString
        +'(' +
      ClientDataSet1.FieldByName('ITEM.ITEM2').AsString+')'
  else  if Sender.FieldName = 'ESTIMATE' then
    Text := ClientDataSet1.FieldByName('ESTIMATE.QTY').AsString
        + ' x ' +
      ClientDataSet1.FieldByName('ESTIMATE.PRICE').AsString
        + ' = ' +
      ClientDataSet1.FieldByName('ESTIMATE.AMOUNT').AsString;
end;

Collapse



テスト以外のコード


// 初期化
procedure InitCDS(CDS: TClientDataSet);
begin
  CDS.Close;
  CDS.AggregatesActive := False;
  CDS.FieldDefs.Clear;
  CDS.AggFields.Clear;
  CDS.Fields.Clear;
  CDS.Aggregates.Clear;
  Form1.DBEdit1.DataField := '';
  Form1.Edit1.Text := '';
end;

// 合計の表示
procedure TForm1.ClientDataSet1AfterPost(DataSet: TDataSet);
var
  Total: TAggregate;
begin
  Total := TClientDataSet(DataSet).Aggregates.Find('TOTAL');
  if Assigned(Total) and (Total.Value <> null) then
    Edit1.Text := Total.Value
  else
    Edit1.Text := '';
end;

// 金額の計算
procedure TForm1.ClientDataSet1CalcFields(DataSet: TDataSet);
begin
  //if DataSet.State = dsInternalCalc then
  begin
    if DataSet.FindField('ESTIMATE.AMOUNT') <> nil then
    begin
      DataSet.FieldByName('ESTIMATE.AMOUNT').AsCurrency :=
        DataSet.FieldByName('ESTIMATE.QTY').AsFloat *
        DataSet.FieldByName('ESTIMATE.PRICE').AsCurrency;
    end
    else
      DataSet.FieldByName('AMOUNT').AsCurrency :=
        DataSet.FieldByName('QTY').AsFloat *
        DataSet.FieldByName('PRICE').AsCurrency;
  end;
end;

procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
  case RadioGroup1.ItemIndex of
    0 : Test1(ClientDataSet1);
    1 : Test2(ClientDataSet1);
    2 : Test3(ClientDataSet1);
    3 : Test4(ClientDataSet1);
    4 : Test5(ClientDataSet1);
  end;
  with ClientDataSet1 do
  begin
    if RadioGroup1.ItemIndex in [2,4] then
    begin
      Append;
      FieldByName('ITEM.ITEM1').AsString := 'PEN';
      FieldByName('ITEM.ITEM2').AsString := 'Blue';
      FieldByName('ESTIMATE.QTY').AsInteger := 10;
      FieldByName('ESTIMATE.UNIT').AsString := '本';
      FieldByName('ESTIMATE.PRICE').AsString := '1000';
      Append;
      FieldByName('ITEM.ITEM1').AsString := 'Fan';
      FieldByName('ITEM.ITEM2').AsString := 'no blade';
      FieldByName('ESTIMATE.QTY').AsInteger := 3;
      FieldByName('ESTIMATE.UNIT').AsString := '台';
      FieldByName('ESTIMATE.PRICE').AsString := '30000';
      Append;
      FieldByName('ITEM.ITEM1').AsString := 'PC';
      FieldByName('ITEM.ITEM2').AsString := 'FMV';
      FieldByName('ESTIMATE.QTY').AsInteger := 1;
      FieldByName('ESTIMATE.UNIT').AsString := '台';
      FieldByName('ESTIMATE.PRICE').AsString := '180000';
    end
    else
    begin
      Append;
      FieldByName('ITEM').AsString := 'PEN';
      FieldByName('QTY').AsInteger := 10;
      FieldByName('UNIT').AsString := '本';
      FieldByName('PRICE').AsString := '1000';
      Append;
      FieldByName('ITEM').AsString := 'Fan';
      FieldByName('QTY').AsInteger := 3;
      FieldByName('UNIT').AsString := '台';
      FieldByName('PRICE').AsString := '30000';
      Append;
      FieldByName('ITEM').AsString := 'PC';
      FieldByName('QTY').AsInteger := 1;
      FieldByName('UNIT').AsString := '台';
      FieldByName('PRICE').AsString := '180000';
    end;
    CheckBrowseMode;
  end;
end;

|

Quality Central Windows Client

QCの内容を確認しようと、[メニュー]→[ツール]→Quality Centralをクリックすると・・・スプラッシュがかっこいい。 (2009とあるので、ずいぶん前からなのかも知れませんが)

Qc__2


そしてアイコンもきれい。

Qc1icon


ただ、タスクバーには、一瞬こんな懐かしいアイコンも現れます(^-^)

Qc2icon


プログラム自体は、それほど変わってなさそうです・・・って、わざわざ変える必要もないですね。報告されたバグを順番に直して頂くだけでいいです。


totonicaさんのサイトで、Quality Centralに関する詳しい説明があります。

Quality Centralへのレポート方法について
・Quality Centralの基礎知識(Quality Centralの基礎知識を解説します。)
・バグレポートの際のコツ(QCにバグレポートを行う際のコツを紹介します。)
・新機能リクエストの際のコツ(QCに新機能をリクエストする際のコツを紹介します。)

Watercolor City
Quality Central ※リンク先の記事内
http://www.watercolor-city.net/ct_delphi/delphi_tiburon/

|

VCL Styles

Delphi2009までのDBGridは、見た目がそれ以前のものと同様で、現在のソフトにあってとても貧相だったので、私は固定セルをグラデーション描画した自作コンポーネントを使っていました。XE2は、標準で対応しているので、自作コンポーネントの余計な処理を外そうとvcl.DBGridsのTCustomDBGrid.DrawCellのソースを見ていた時です。その中には、TCustomStyleServicesやTStyleManagerといった見慣れないクラスが使われていました。グラデーションのために大げさなと思いつつ、Delphi TStyleManagerで検索してみると次のブログを見つけました。

The Road to Delphi – a Blog about programming
Exploring Delphi XE2 – VCL Styles Part I

な、なんと、テーマを自作してアプリケーションの外観を変えることができるではありませんか!! 本当ならちょっとやってみました的な記事に仕上げたいところですが、先のブログでいろいろ作成されたものが載せられているので、ぜひご覧下さい(^-^)

既にDEKOさんところでも、取り上げられていました。標準で用意されている各スタイルのショットも載せられています。

DEKOのアヤシいお部屋。
スタイル - VCL (Delphi XE2) ※リンク先の記事内
http://ht-deko.minim.ne.jp/ft1109.html#110906

|

Excel2010がTWebBrowser内で開かない。

以前作成した「ExcelをTWebBrowserで開くソフト」がWindows 7、Office2010の環境では、ExcelがTWebBrowser内ではなく、単独に表示されました。そのソフトを使っていた環境がWindows XP、Office 2003だったから知らなかったのですが、About.com Delphi によるとWindows Vista、Office2007で既にそのような動作になっていたようですね。記事は、Vista + Office2007ですが、Windows7 + Office2010でも、記事と同じ設定で、期待の動作になりました。

次のレジストリの値を変更します。
[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\Excel.Sheet.8]
"BrowserFlags"=dword:80000A00
[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\Excel.Sheet.12]
"BrowserFlags"=dword:80000A00


About.com Delphi
Opening Office Documents (Word, Excel) in TWebBrowser on Vista and Office 2007
http://delphi.about.com/od/delphitips2008/qt/wbr_vista.htm

|

SyntaxHighlighterを設定してみました。

ソースコードの表示にSyntaxHighlighterを設定してみました。しかしどこか変です。設定がおかしいのかな?
例えば、 TMyList<T: TMyBase, constructor> = class(TList<T>) と書いてるのに次のようになります。

  TMyList = class(TList)

もう少し設定を試してみます。
と書いて、すぐに思い出しました。設定とかじゃなくて、Genericsのプレースホルダー<T>のせいですね。でも括弧の部分を、いちいち変換するのは面倒です。

|

Genericsの型キャスト?

今更、「Genericsかぁー」なんて突っ込みたくなるでしょうけど、Delphi2009をインストール後、ほとんどプログラムをしてこなかった私にとっては、悩みどころの一つです。

あるクラスとそれを管理するリストを考えた場合、Genericsでリストを作成するといろんな型を扱うことができていいなと思い、TList<T>を使って下記のようなプログラムを書きました。
  TMusic = class(TObject)
  private
    FTitle: String;
    FArtist: String;
  public
    constructor Create(Title, Artist: String);
    procedure SaveToStream(var Stream: TStream);
  end;

  TMyList<T> = class(TList<T>)
  public
    { 略 }
    procedure SaveToStream(var Stream: TStream);
  end;

しかし、下記の部分の型キャストができませんでした。かと言って ここを特定の型で書いてしまうとTListと変わらなくなり、汎用性に欠けます。
procedure TMyList<T>.SaveToStream(var Stream: TStream);
var
  I: Integer;
begin
   Stream.WriteBuffer(Self.Count, SizeOf(Integer));
  for I := 0 to Self.Count -1 do
    T.SaveToStream(Stream); // ←ここの型キャストができない。
end;


試行錯誤の結果、下記のようなプログラムにすることで、型キャストの問題をクリアできました。
  TMyBase = class(TPersistent) 
  public
    procedure SaveToStream(var Stream: TStream); virtual; abstract;
    procedure LoadFromStream(Stream: TStream);  virtual; abstract;
  end;

  // TMyBaseから派生したクラスを扱うリスト
  TMyList<T: TMyBase, constructor> = class(TList<T>)
  public
    destructor Destroy; override;
    procedure ClearItems; 
    procedure SaveToStream(var Stream: TStream);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile(const FileName: String);
    procedure LoadFromFile(const FileName: String);
  end;

  TMusic = class(TMyBase)
  private
    FTitle: String;
    FArtist: String;
  public
    constructor Create; overload;
    constructor Create(Title, Artist: String); overload;
    procedure Assign(Source: TPersistent); override;
    procedure SaveToStream(var Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
  published
    property Title: String read FTitle write FTitle;
    property Artist: String read FArtist write FArtist;
  end;



{ TMyList<T> }

destructor TMyList<T>.Destroy;
begin
  ClearItems;
  inherited;
end;

procedure TMyList<T>.ClearItems;
var
  P: Pointer;
  V: T;
  I,K: Integer;
begin
  for I := 0 to Self.Count -1 do
   begin
    V := Self.Items[I];
    FreeAndNil(V);
  end;
  Self.Clear;
end;

procedure TMyList<T>.LoadFromStream(Stream: TStream);
var
  I,Cnt: Integer;
  V: T;
begin
  ClearItems;
  Cnt := ReadIntegerFromStream(Stream);
  for I := 0 to Cnt -1 do
  begin
    V := T.Create;
    V.LoadFromStream(TStream(Stream));
    Self.Add(V);
  end;
end;

procedure TMyList<T>.SaveToStream(var Stream: TStream);
var
  I: Integer;
begin
  WriteIntegerToStream(Stream,Self.Count);
  for I := 0 to Self.Count -1 do
    T(Items[I]).SaveToStream(TStream(Stream));
end;

procedure TMyList<T>.LoadFromFile(const FileName: String);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(FileName, fmOpenRead);
  try
    FS.Position := 0;
    LoadFromStream(FS);
  finally
    FS.Free;
  end;
end;

procedure TMyList<T>.SaveToFile(const FileName: String);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(FileName, fmCreate);
  try
    FS.Position := 0;
    SaveToStream(TStream(FS));
  finally
    FS.Free;
  end;
end;



{ TMusic }

constructor TMusic.Create(Title, Artist: String);
begin
  FTitle := Title;
  FArtist := Artist;
end;

constructor TMusic.Create;
begin
  FTitle := '';
  FArtist := '';
end;

procedure TMusic.Assign(Source: TPersistent);
begin
  if Assigned(Source) and (Source is TMusic) then
  begin
    Title  := (Source as TMusic).Title;
    Artist := (Source as TMusic).Artist;
    Exit;
  end;
  inherited;
end;

procedure TMusic.LoadFromStream(Stream: TStream);
begin
  FTitle := ReadStringFromStream(Stream);
  FArtist := ReadStringFromStream(Stream);
end;


procedure TMusic.SaveToStream(var Stream: TStream);
begin
  WriteStringToStream(Stream, FTitle);
  WriteStringToStream(Stream, FArtist);
end;



次のように使います。
procedure TForm1.Button1Click(Sender: TObject);
const
  FN = 'MusicList.dat';
var
  MusicList: TMyList<TMusic>;
  Music1: TMusic;
  Music2: TMusic;
begin
  MusicList:= TMyList<TMusic>.Create;
  try
    // 追加
    MusicList.Add(TMusic.Create('love','John Lennon'));
    MusicList.Add(TMusic.Create('yesterady','the Beatles'));
    MusicList.Add(TMusic.Create('Born This Way','Lady Gaga'));

    // 追加
    Music1 := TMusic.Create;
    Music1.Title := 'Burn';
    Music1.Artist := 'Deep Purple';
    MusicList.Add(Music1);

    // 追加(Assignを利用)
    Music2 := TMusic.Create;
    Music2.Assign(Music1);
    MusicList.Add(Music2);

    // ファイルに保存します。
    MusicList.SaveToFile(ExtractFilePath(Application.ExeName) + FN);
  finally
    FreeAndNil(MusicList);
  end;
end;

// load
procedure TForm1.Button2Click(Sender: TObject);
const
  FN = 'MusicList.dat';
var
  Music: TMusic;
  Musiclist: TMyList<TMusic>;
begin
  Memo1.Lines.Clear;
  MusicList:= TMyList<TMusic>.Create;
  try
    MusicList.LoadFromFile(ExtractFilePath(Application.ExeName) + FN);
    for Music in Musiclist do
      Memo1.Lines.Add(Music.Title+' / '+Music.Artist);
  finally
    MusicList.Free;
  end;
end;


Streamの読み書きは、次の手続き・関数を使います。Unicodeの文字列は、ちょっと面倒です。
procedure WriteIntegerToStream(var Stream: TStream; Value: Integer);
begin
  Stream.WriteBuffer(Value, SizeOf(Integer));
end;

function ReadIntegerFromStream(const Stream: TStream): Integer;
begin
  Stream.ReadBuffer(Result, SizeOf(Integer));
end;

procedure WriteStringToStream(var Stream: TStream; Value: String);
var
  I: Integer;
  S: UTF8String;
begin
  S := UTF8String(Value);
  I := Length(S);
  Stream.WriteBuffer(I, SizeOf(Integer));
  if I > 0 then
    Stream.WriteBuffer(Pointer(S)^, I);
end;

function ReadStringFromStream(const Stream: TStream): String;
var
  I: Integer;
  S: UTF8String;
begin
  Stream.ReadBuffer(I, SizeOf(Integer));
  if I > 0 then
  begin
    SetLength(S, I);
    Stream.ReadBuffer(Pointer(S)^, I);
    Result := String(S);
  end;
end;

|

Delphi XE2 Professional インストールしました。

仕事に追われてずっとDelphiから遠のいていました。でも先週ぐらいから昔に作ったプログラムを手直しする必要があって、いろいろと調べていて、XE2を知りました。そう言えば、Embarcaderoからのバージョンアップの案内は、私のところには全く届かなくなっています。私のDelphiが2009までで、このブログも更新していないという理由で案内くれないのかな?(^-^)

初めてXE2の情報を見たときは、正直、不安な気持ちになったというか、はっきり言ってDelphi8やKylixの悪夢がよみがえりました。
(技術的にはすごかったのかも知れませんが・・・ごめんなさい)
64bit対応はともかく、WindowsとMacのクロス開発?FireMonkey?・・・又、エラーばかりで、いつしか消えていくのかも知れないとの不安がいっぱいでした。

そしてそのFireMonkey・・・私はMacを持っていないので、クロス環境では試していませんが、結構いいじゃないですか。この先どのような展開になるのかは想像できませんが、少なくとも見た目重視のアプリを作りたい私にはぴったりです。附属のサンプルを試しただけですが、エラーが表示されることもありませんでした。

全体としては、インストール時から、そしてインストール後も安定して動作しています。
(環境によっては、インストールがままならないバージョンもありましたしね)
もうGalileo IDEにも抵抗はないですし、これからはXE2で、さくさくとプログラムができそうです、腕と時間さえあれば(^_^)

|

« 2011年4月 | トップページ | 2011年10月 »