LiveBindingを試してみる。

DelphiXE2のLiveBindingの機能を使って、現在時刻を更新する処理を

チュートリアルを参考作ってみた。

処理としては、時刻が更新されると、登録した通知先（作った例場合はフォーム）の

表示を更新する処理になっています。

以下ソース

まずは、時計のソース、タイマーを使って定周期で時刻を更新し、登録先の

更新通知を行っています。

また、変更通知先を登録する処理を書いています。

view plainprint?

1. unit Unit4;  
2.   
3. interface  
4.   
5. uses  
6.  System.SysUtils, System.Classes,Vcl.ExtCtrls, Data.Bind.EngExt,  
7.  Vcl.Bind.DBEngExt, System.Rtti, System.Bindings.Outputs, Vcl.Bind.Editors,  
8.  Data.Bind.Components,  
9.  System.Bindings.EvalProtocol,  
10.  System.Bindings.Expression,  
11.  System.Bindings.ObjEval,  
12.  System.Bindings.Helper;  
13.   
14. type  
15.  TDataModule4 = class(TDataModule)  
16.    FTimer: TTimer;  
17.    procedure FTimerTimer(Sender: TObject);  
18.    procedure DataModuleCreate(Sender: TObject);  
19.    procedure DataModuleDestroy(Sender: TObject);  
20.  private  
21.    { Private 宣言 }  
22.    FNowString : String;  
23.    BindingExpression1: TBindingExpression;  
24.  public  
25.    procedure AddBindingList(const InputScopes: array of IScope; const BindExprStr: string; const OutputScopes: array of IScope; const OutputExpr: string);  
26.    published  
27.    { Public 宣言 }  
28.    property NowString : String read FNowString;  
29.  end;  
30.   
31. var  
32.  DataModule4: TDataModule4;  
33.   
34. implementation  
35.   
36. {%CLASSGROUP 'Vcl.Controls.TControl'}  
37.   
38. uses Unit1;  
39.   
40. {$R *.dfm}  
41.   
42. procedure TDataModule4.AddBindingList(const InputScopes: array of IScope;  
43.  const BindExprStr: string; const OutputScopes: array of IScope;  
44.  const OutputExpr: string);  
45. begin  
46.   
47.  BindingExpression1 :=  TBindings.CreateManagedBinding(  
48.        InputScopes,  
49.        BindExprStr,  
50.        OutputScopes,  
51.        OutputExpr,  
52.        nil);  
53.   
54. end;  
55.   
56. procedure TDataModule4.DataModuleCreate(Sender: TObject);  
57. begin  
58.  //BindScope1.Active := true;  
59. end;  
60.   
61. procedure TDataModule4.DataModuleDestroy(Sender: TObject);  
62. begin  
63.  //BindScope1.Active := false;  
64. end;  
65.   
66. procedure TDataModule4.FTimerTimer(Sender: TObject);  
67. begin  
68.  FNowString := DateTimeToStr(Now);  
69.  TBindings.Notify(Self, 'NowString');  
70.   
71. end;  
72.   
73. end.  

unit Unit4;

interface

uses
 System.SysUtils, System.Classes,Vcl.ExtCtrls, Data.Bind.EngExt,
 Vcl.Bind.DBEngExt, System.Rtti, System.Bindings.Outputs, Vcl.Bind.Editors,
 Data.Bind.Components,
 System.Bindings.EvalProtocol,
 System.Bindings.Expression,
 System.Bindings.ObjEval,
 System.Bindings.Helper;

type
 TDataModule4 = class(TDataModule)
   FTimer: TTimer;
   procedure FTimerTimer(Sender: TObject);
   procedure DataModuleCreate(Sender: TObject);
   procedure DataModuleDestroy(Sender: TObject);
 private
   { Private 宣言 }
   FNowString : String;
   BindingExpression1: TBindingExpression;
 public
   procedure AddBindingList(const InputScopes: array of IScope; const BindExprStr: string; const OutputScopes: array of IScope; const OutputExpr: string);
   published
   { Public 宣言 }
   property NowString : String read FNowString;
 end;

var
 DataModule4: TDataModule4;

implementation

{%CLASSGROUP 'Vcl.Controls.TControl'}

uses Unit1;

{$R *.dfm}

procedure TDataModule4.AddBindingList(const InputScopes: array of IScope;
 const BindExprStr: string; const OutputScopes: array of IScope;
 const OutputExpr: string);
begin

 BindingExpression1 :=  TBindings.CreateManagedBinding(
       InputScopes,
       BindExprStr,
       OutputScopes,
       OutputExpr,
       nil);

end;

procedure TDataModule4.DataModuleCreate(Sender: TObject);
begin
 //BindScope1.Active := true;
end;

procedure TDataModule4.DataModuleDestroy(Sender: TObject);
begin
 //BindScope1.Active := false;
end;

procedure TDataModule4.FTimerTimer(Sender: TObject);
begin
 FNowString := DateTimeToStr(Now);
 TBindings.Notify(Self, 'NowString');

end;

end.

次に、時計を表示するソース。比較のためにポーリング処理で上記のソースのプロパティを使って
タイムスタンプを更新する処理もあります。

view plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,  
7.  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls,  
8.  Data.Bind.EngExt, Vcl.Bind.DBEngExt, System.Rtti, System.Bindings.Outputs,  
9.  Unit4,  
10.  System.Bindings.Expression,  
11.  System.Bindings.ObjEval,  
12.  System.Bindings.Helper,  
13.  Vcl.Bind.Editors, Data.Bind.Components;  
14.   
15.   
16. type  
17.  TForm1 = class(TForm)  
18.    Label1: TLabel;  
19.    Label3: TLabel;  
20.    Timer1: TTimer;  
21.    Label2: TLabel;  
22.    Label4: TLabel;  
23.    procedure Timer1Timer(Sender: TObject);  
24.    procedure FormCreate(Sender: TObject);  
25.    procedure FormClose(Sender: TObject; var Action: TCloseAction);  
26.  private  
27.    { Private 宣言 }  
28.    FSakaClock : TDataModule4;  
29.  public  
30.    { Public 宣言 }  
31.  end;  
32.   
33. var  
34.  Form1: TForm1;  
35.   
36. implementation  
37.   
38. {$R *.dfm}  
39.   
40.   
41. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);  
42. begin  
43.  //FSakaClock.Free;  
44.  FSakaClock.Free;  
45. end;  
46.   
47. procedure TForm1.FormCreate(Sender: TObject);  
48. begin  
49.  FSakaClock := TDataModule4.Create(Self);  
50.  FSakaClock.AddBindingList(  
51.       { inputs }  
52.      [TBindings.CreateAssociationScope([  
53.        Associate(FSakaClock, 'I1')  
54.      ])],  
55.      'I1.NowString',  
56.      { outputs }  
57.      [TBindings.CreateAssociationScope([  
58.        Associate(Label3, 'O1')  
59.      ])],  
60.      'O1.Caption');  
61.   
62.  //FSakaClock := TSakaClock.Create(Self);  
63. end;  
64.   
65. procedure TForm1.Timer1Timer(Sender: TObject);  
66. begin  
67.  Label1.Caption := FSakaClock.NowString;  
68. end;  
69.   
70. end.  

unit Unit1;

interface

uses
 Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
 Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls,
 Data.Bind.EngExt, Vcl.Bind.DBEngExt, System.Rtti, System.Bindings.Outputs,
 Unit4,
 System.Bindings.Expression,
 System.Bindings.ObjEval,
 System.Bindings.Helper,
 Vcl.Bind.Editors, Data.Bind.Components;


type
 TForm1 = class(TForm)
   Label1: TLabel;
   Label3: TLabel;
   Timer1: TTimer;
   Label2: TLabel;
   Label4: TLabel;
   procedure Timer1Timer(Sender: TObject);
   procedure FormCreate(Sender: TObject);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
 private
   { Private 宣言 }
   FSakaClock : TDataModule4;
 public
   { Public 宣言 }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 //FSakaClock.Free;
 FSakaClock.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 FSakaClock := TDataModule4.Create(Self);
 FSakaClock.AddBindingList(
      { inputs }
     [TBindings.CreateAssociationScope([
       Associate(FSakaClock, 'I1')
     ])],
     'I1.NowString',
     { outputs }
     [TBindings.CreateAssociationScope([
       Associate(Label3, 'O1')
     ])],
     'O1.Caption');

 //FSakaClock := TSakaClock.Create(Self);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
 Label1.Caption := FSakaClock.NowString;
end;

end.

CPUのコア数を数える。

Delphiのドキュメントによれば、System.CPUCount変数を参照すればCPUのコア数が
表示できるようだ。

たとえば、

view plainprint?

1. Label1.Caption := IntToStr(System.CpuCount)  

Label1.Caption := IntToStr(System.CpuCount)

でラベルにCPUのコア数が表示できる。

自分のPCで試したけど、シングルコアのCPUなので

当然のことながら1と表示された。

指定したウインドウを最前面にもってくる

VBAから指定したアプリが起動してない場合は起動し、既に起動済みの場合は、最前面に持ってくる
という処理が必要になったので、Delphiで作成してみた。

以下、指定したアプリを前面に持ってくるサンプル。

view plainprint?

1. procedure TForm1.Button1Click(Sender: TObject);  
2. unit Unit1;  
3.   
4. interface  
5.   
6. uses  
7.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
8.   Dialogs, StdCtrls, ExtCtrls;  
9.   
10. type  
11.   TForm1 = class(TForm)  
12.     LabeledEdit1: TLabeledEdit;  
13.     Button1: TButton;  
14.     procedure Button1Click(Sender: TObject);  
15.   private  
16.     { Private 宣言 }  
17.   public  
18.     { Public 宣言 }  
19.   end;  
20.   
21. var  
22.   Form1: TForm1;  
23.   
24. implementation  
25. Uses JclSysInfo;  
26.   
27. {$R *.dfm}  
28. function AllowSetForegroundWindow(dwProcessID: Cardinal): BOOL; stdcall; external 'user32.DLL';  
29.   
30.   
31. procedure TForm1.Button1Click(Sender: TObject);  
32. var  
33.   ProcessList : TStringList;  
34.   i : Integer;  
35.   Pid : Cardinal;  
36.   Wnd: THandle;  
37. begin  
38.   
39.   ProcessList := TStringList.Create;  
40.   try  
41.     //起動するアプリは、自前のものではないので  
42.     //プロセスがいるかどうかは、プロセスのリストを総当りで  
43.     //確認  
44.     JclsysInfo.RunningProcessesList(ProcessList,true);  
45.     i := -1;  
46.     ProcessList.Find(LabeledEdit1.Text,i);  
47.     if i >= 0 then  
48.     begin  
49.       Pid := GetPidFromProcessName(ProcessList.Strings[i]);  
50.       Wnd :=GetMainAppWndFromPid(Pid);  
51.       //いつぞやのバージョンのwindowsから前面に出す許可を  
52.       //しておくことが必要  
53.       AllowSetForegroundWindow(Pid);  
54.       //最小化されているのでアイコンからもとのサイズに  
55.       //戻す  
56.       if IsIconic(Wnd) then  
57.       begin  
58.         OpenIcon(Wnd);  
59.       end  
60.       else  
61.       begin  
62.         //指定したウインドウを前面に  
63.         SetForegroundWindow(wnd);  
64.         //場合によっては、AttachThreadInputで  
65.         //前面に出したいウインドのスレッドにあタッチが必要  
66.       end;  
67.     end;  
68.   
69.   finally  
70.   　ProcessList.Free;  
71. 　　end;  
72. end;  
73.   
74. end.  

procedure TForm1.Button1Click(Sender: TObject);
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    LabeledEdit1: TLabeledEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation
Uses JclSysInfo;

{$R *.dfm}
function AllowSetForegroundWindow(dwProcessID: Cardinal): BOOL; stdcall; external 'user32.DLL';


procedure TForm1.Button1Click(Sender: TObject);
var
  ProcessList : TStringList;
  i : Integer;
  Pid : Cardinal;
  Wnd: THandle;
begin

  ProcessList := TStringList.Create;
  try
    //起動するアプリは、自前のものではないので
    //プロセスがいるかどうかは、プロセスのリストを総当りで
    //確認
    JclsysInfo.RunningProcessesList(ProcessList,true);
    i := -1;
    ProcessList.Find(LabeledEdit1.Text,i);
    if i >= 0 then
    begin
      Pid := GetPidFromProcessName(ProcessList.Strings[i]);
      Wnd :=GetMainAppWndFromPid(Pid);
      //いつぞやのバージョンのwindowsから前面に出す許可を
      //しておくことが必要
      AllowSetForegroundWindow(Pid);
      //最小化されているのでアイコンからもとのサイズに
      //戻す
      if IsIconic(Wnd) then
      begin
        OpenIcon(Wnd);
      end
      else
      begin
        //指定したウインドウを前面に
        SetForegroundWindow(wnd);
        //場合によっては、AttachThreadInputで
        //前面に出したいウインドのスレッドにあタッチが必要
      end;
    end;

  finally
  　ProcessList.Free;
　　end;
end;

end.

プロセスリストを表示する（その２）

Project jediのJclのJclSysInfoユニットにある。RunningProcessesList関数を使用すると
プロセスリストが簡単にとれます。

以下、サンプル

view plainprint?

1. procedure TForm1.Button1Click(Sender: TObject);  
2. unit Unit1;  
3.   
4. interface  
5.   
6. uses  
7.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
8.   Dialogs, StdCtrls, ExtCtrls;  
9.   
10. type  
11.   TForm1 = class(TForm)  
12.     LabeledEdit1: TLabeledEdit;  
13.     Button1: TButton;  
14.     ListBox1: TListBox;  
15.     procedure FormCreate(Sender: TObject);  
16.   private  
17.     { Private 宣言 }  
18.   public  
19.     { Public 宣言 }  
20.   end;  
21.   
22. var  
23.   Form1: TForm1;  
24.   
25. implementation  
26. Uses JclSysInfo;  
27.   
28. {$R *.dfm}  
29.   
30. procedure TForm1.FormCreate(Sender: TObject);  
31. var  
32. 　ProcessList : TStringList;  
33.   i : Integer;  
34.   Pid : Cardinal;  
35.   
36. begin  
37. 　ListBox1.Clear;  
38.   ProcessList := TStringList.Create;  
39.   try  
40. 　　JclsysInfo.RunningProcessesList(ProcessList,true);  
41.     for i := 0 to ProcessList.Count-1 do  
42.     begin  
43.       Pid := GetPidFromProcessName(ProcessList.Strings[i]);  
44.       ListBox1.Items.Add('(' + IntToStr(Pid) + ')' + ProcessList.Strings[i]);  
45.     end;  
46.   
47.   finally  
48.   　ProcessList.Free;  
49.   end;  
50.   
51. end;  

procedure TForm1.Button1Click(Sender: TObject);
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    LabeledEdit1: TLabeledEdit;
    Button1: TButton;
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation
Uses JclSysInfo;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
　ProcessList : TStringList;
  i : Integer;
  Pid : Cardinal;

begin
　ListBox1.Clear;
  ProcessList := TStringList.Create;
  try
　　JclsysInfo.RunningProcessesList(ProcessList,true);
    for i := 0 to ProcessList.Count-1 do
    begin
      Pid := GetPidFromProcessName(ProcessList.Strings[i]);
      ListBox1.Items.Add('(' + IntToStr(Pid) + ')' + ProcessList.Strings[i]);
    end;

  finally
  　ProcessList.Free;
  end;

end;

RunningProcessesListは、引数で指定したTStringsを継承した型インスタンスに
プロセスのリストを返してくれます。

このJclSysInfoユニット、ざっと見た感じで、便利そうなものが一杯あった。
サンプルプログラムを元にもうチョットみてみよう。

VBスクリプトを動かす（動画付き）

先日、ツイッターでMicrosoft Scriptコントロールの話題がでたのでDelphiでMicrosoft Scriptコントロールを
使うサンプルを作ってみた。

Microsoft ScriptコントールをDelphiに取り込む必要がある。

Microsoft Scriptコントール取り込むには、コンポーネントの取り込みを選択し

ActiveXコントールの取り込みを選択する。

（ここでタイプライブラリの取り込みを選択するとクラスがつくられないみたい
なので要注意）

コントロールの一覧からMicroSoft Scriptコントロールを選択する。

あとは、画面の支持にしたがってファイルを作成し、Microsoft Scriptコントールを
組み込みたいプロジェクトに読み込む。

ここから、実際につくったサンプル。

サンプルは、

1) a,b二つの引数を持つVBSのＦＵＮＣＴＩＯＮプロシージャを実行する。
  2) VBSはメモコンポーネントに記述する。
3) メモコンポーネントに記述したFUNCTIONのリストをListBoxに表示する。
4) ListBoxから選んだFUNCTIONを実行し結果をラベルに表示する。

とゆうものです。

以下、ソースファイル

view plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, MSScriptControl_TLB, StdCtrls;  
8.   
9. type  
10.   TForm1 = class(TForm)  
11.     Memo1: TMemo;  
12.     スクリプトを登録: TButton;  
13.     ListBox1: TListBox;  
14.     選択した関数を実行: TButton;  
15.     実行結果: TLabel;  
16.     Label2: TLabel;  
17.     procedure FormCreate(Sender: TObject);  
18.     procedure FormClose(Sender: TObject; var Action: TCloseAction);  
19.     procedure スクリプトを登録Click(Sender: TObject);  
20.     procedure 選択した関数を実行Click(Sender: TObject);  
21.   private  
22.     { Private 宣言 }  
23.     FScriptControl:TScriptControl;  
24.   public  
25.     { Public 宣言 }  
26.   end;  
27.   
28. var  
29.   Form1: TForm1;  
30.   
31. implementation  
32.   
33. uses ActiveX,VarUtils;  
34.   
35. {$R *.dfm}  
36.   
37. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);  
38. begin  
39.  FScriptControl.Free;  
40. end;  
41.   
42. procedure TForm1.FormCreate(Sender: TObject);  
43. begin  
44.   FScriptControl := TScriptControl.Create(Self);  
45.   {Jscriptを使用するときは、'VBSCRIPT'を'JScript'に変更する。}  
46.   FScriptControl.Language := 'VBSCRIPT';  
47. end;  
48.   
49. procedure TForm1.スクリプトを登録Click(Sender: TObject);  
50. var  
51.   i : Integer;  
52. begin  
53.   
54.   ListBox1.Clear;  
55.     
56. 　{Scriptコントロールにコードを追加}  
57. 　FScriptControl.AddCode(WideString(Memo1.Text));  
58.   
59.   {プロシージャコレクションを操作することでプロシージャーのリストを得る}  
60.   for i := 0  to FScriptControl.Procedures.Count -1 do  
61.   begin  
62.   
63.     {VB(VB6,VBA)用のCOMのコレクションは1基数のものが多いので注意}  
64.     ListBox1.Items.Add(FScriptControl.Procedures.Item[i+1].Name);  
65.   end;  
66.   
67. end;  
68. procedure TForm1.選択した関数を実行Click(Sender: TObject);  
69. var  
70.   ResultStr : OleVariant;  
71.   ParamArray : Variant;  
72.   PParamArray : PVarArray;  
73.   MyParams : PIntegerArray;  
74. begin  
75.     
76.   {パラメータはヴァリアント型の配列で渡す必要がある}  
77.   ParamArray := VarArrayCreate([0, 1], varVariant);  
78.   ParamArray[0] := 3;  
79.   ParamArray[1] := 5;  
80.     
81.   PParamArray := VarArrayAsPSafeArray(ParamArray);  
82.   ResultStr := FScriptControl.Run(WideString(ListBox1.Items[ListBox1.ItemIndex]),  
83.                               PSafeArray(PParamArray));  
84.   Label2.Caption := VarToStr(ResultStr);  
85.   
86. end;  
87.   
88. end.  

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, MSScriptControl_TLB, StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    スクリプトを登録: TButton;
    ListBox1: TListBox;
    選択した関数を実行: TButton;
    実行結果: TLabel;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure スクリプトを登録Click(Sender: TObject);
    procedure 選択した関数を実行Click(Sender: TObject);
  private
    { Private 宣言 }
    FScriptControl:TScriptControl;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ActiveX,VarUtils;

{$R *.dfm}

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 FScriptControl.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FScriptControl := TScriptControl.Create(Self);
  {Jscriptを使用するときは、'VBSCRIPT'を'JScript'に変更する。}
  FScriptControl.Language := 'VBSCRIPT';
end;

procedure TForm1.スクリプトを登録Click(Sender: TObject);
var
  i : Integer;
begin

  ListBox1.Clear;
  
　{Scriptコントロールにコードを追加}
　FScriptControl.AddCode(WideString(Memo1.Text));

  {プロシージャコレクションを操作することでプロシージャーのリストを得る}
  for i := 0  to FScriptControl.Procedures.Count -1 do
  begin

    {VB(VB6,VBA)用のCOMのコレクションは1基数のものが多いので注意}
    ListBox1.Items.Add(FScriptControl.Procedures.Item[i+1].Name);
  end;

end;
procedure TForm1.選択した関数を実行Click(Sender: TObject);
var
  ResultStr : OleVariant;
  ParamArray : Variant;
  PParamArray : PVarArray;
  MyParams : PIntegerArray;
begin
  
  {パラメータはヴァリアント型の配列で渡す必要がある}
  ParamArray := VarArrayCreate([0, 1], varVariant);
  ParamArray[0] := 3;
  ParamArray[1] := 5;
  
  PParamArray := VarArrayAsPSafeArray(ParamArray);
  ResultStr := FScriptControl.Run(WideString(ListBox1.Items[ListBox1.ItemIndex]),
                              PSafeArray(PParamArray));
  Label2.Caption := VarToStr(ResultStr);

end;

end.

以下、コントロールの取り込みと上記プログラムを実行しているところのデモ動画

Guid文字列を得る

Delphiで、Guidを得るには、通常の場合CreateGuid手続きを使用します。
また、Guid文字列を得るする場合には、GuidToString手続きを使用して文字列に変換します。

view plainprint?

1. procedure TForm1.Button1Click(Sender: TObject);  
2. var  
3.   guid : TGuid;  
4. begin  
5.   CreateGuid(guid);  
6.   LabeledEdit1.Text := GuidToString(guid);  
7.   
8. end;  

procedure TForm1.Button1Click(Sender: TObject);
var
  guid : TGuid;
begin
  CreateGuid(guid);
  LabeledEdit1.Text := GuidToString(guid);

end;

Delphi XEでは、TGuid型に対して、TGuidHelperクラスが実装されているので
このHelperを利用してもGuidを得ることができます。
(Helperは.Net FrameworkのGuid構造体と同じ動きをするように実装されている
ようです。但し、.Net側のToStringメソッドでは文字列が中括弧で囲まれないので
注意が必要かなぁ？)

view plainprint?

1. procedure TForm1.Button2Click(Sender: TObject);  
2. var  
3.   guid:TGUID;  
4.   S:String;  
5. begin  
6.   guid := TGUID.NewGuid;  
7.   LabeledEdit1.Text := guid.ToString;  
8. end;  

procedure TForm1.Button2Click(Sender: TObject);
var
  guid:TGUID;
  S:String;
begin
  guid := TGUID.NewGuid;
  LabeledEdit1.Text := guid.ToString;
end;

TGuidHelperクラスにはGuidの表現形式に応じていくかのCreate関数が用意されていますで
プログラム中で使用している表現形式からGUDIの生成が可能です。

下記の例は、文字列で表現されたGUIDからTGuid型の変数を得る例です。

view plainprint?

1. procedure TForm1.Button3Click(Sender: TObject);  
2. var  
3.   guid:TGUID;  
4. begin  
5. 　guid := TGUID.Create('{1F447130-60E2-40A0-9A00-EB94C1C7D691}');  
6.   label1.Caption := guid.Tostring; //{1F447130-60E2-40A0-9A00-EB94C1C7D691}が表示される  
7. end;  

procedure TForm1.Button3Click(Sender: TObject);
var
  guid:TGUID;
begin
　guid := TGUID.Create('{1F447130-60E2-40A0-9A00-EB94C1C7D691}');
  label1.Caption := guid.Tostring; //{1F447130-60E2-40A0-9A00-EB94C1C7D691}が表示される
end;

TSingletonImplementationクラス

Delphi XEのHelpを見ていて、TSingletonImplementationというクラスがあるのに気づいた。

HELPをみると、IInterface の基本実装が必要で参照カウントが無効なシンプルなクラスの基底クラスなそうな。

ということは、COMでなインターフェイスについては、このクラスを使えばよいのかぁ～。

でも、何故Generics.Defaultsに配置してあるのだろう。

ClientDatasetのでも

Buleberry社のFlashBack ExpressのテストでClientDataSetのチョットしたサンプル動画(スクリーンキャプチャー）を
作ってみた。

サンプルの内容は、IDE上でクライアントデータセットのフィールドを作成し

Delphiのプログラムでデータをセットするものです。

編集もなにもしてないので、チョットまのびした動画になっちゃてます。

Null許容型

delphilhlplibの中にNull許容型が容易されてるのでちょっと試してみた。

delpjihlplibは上記のリンクから最新のモジュールをダウンロードして
パッケージをインストールすることで使用可能になります。

以下試したソースコード

view plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, StdCtrls;  
8.   
9. type  
10.   TForm1 = class(TForm)  
11.     Button1: TButton;  
12.     Label1: TLabel;  
13.     Label2: TLabel;  
14.     Label3: TLabel;  
15.     procedure Button1Click(Sender: TObject);  
16.   private  
17.     { Private 宣言 }  
18.   public  
19.     { Public 宣言 }  
20.   end;  
21.   
22. var  
23.   Form1: TForm1;  
24.   
25. implementation  
26. Uses DeHL.Nullable;  
27.   
28. {$R *.dfm}  
29.   
30. procedure TForm1.Button1Click(Sender: TObject);  
31. var  
32.   i : Nullable <integer>  
33. begin  
34.   
35.   //値を代入する前はNULL  
36.   if i.IsNull then  
37.   begin  
38.     Label1.Caption := 'Null';  
39.   end;  
40.   
41.   //値を代入すると普通の型のように扱える  
42.   i.Value := 100;  
43.   Label2.Caption := IntToStr(i);  
44.   
45.   //MakeNullでNullをセットできるようだ。  
46.   i.MakeNull;  
47.   
48.   if i.IsNull then  
49.   begin  
50.     Label3.Caption := 'Null';  
51.   end;  
52.   
53. end;  
54.   
55. end.  

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation
Uses DeHL.Nullable;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  i : Nullable <integer>
begin

  //値を代入する前はNULL
  if i.IsNull then
  begin
    Label1.Caption := 'Null';
  end;

  //値を代入すると普通の型のように扱える
  i.Value := 100;
  Label2.Caption := IntToStr(i);

  //MakeNullでNullをセットできるようだ。
  i.MakeNull;

  if i.IsNull then
  begin
    Label3.Caption := 'Null';
  end;

end;

end.

delphihelplibには、そのほかにもいろいろなクラスがあるようなので、追々試してみようと思う。

Unified Interbaseコンポーネントをつかってみた（その4）

Unified Interbaseコンポーネントをつかってみた（その3）で、ClientDataSet接続用に
TUIBDataSetをカスタマイズした。このカスタマイズしたコンポーネントを使って
TClientDataSet及びTDataSetProviderを使ってのデータ更新を試してみた。

以下、その備忘録

DBExpressドライバを使えば、フラットなテーブルや簡単なリンクテーブルであれば
自動的にデータ操作のSQLを作ってDBに書き込んでくれる。

しかし、複雑なJoin等でデータを表示する場合はDbExpressドライバを使っても
テーブルへの操作は自前で実施する必要がある。

また、FlameRobin、黒猫 SQL Studio、A5:SQL Mk-2のツールでデータ更新用の
SQLである程度自動で作成できるので 自前で実施してもそんなに手間ではないので
データの更新を手動で行う。

DataSetProviderで、データの更新を自分で実施する方法は、エンバカデロさんのヘルプ
に手順が書いてあるのでこれに従って更新処理を書いた。

その実装は、以下のとおり

フォームのUIBTransactionコンポーネントを配置し、UIBDatabaseコンポーネントを
接続する。また今回はテストなので、暗黙のトランザクションになるようの
コンポーネントを設定した。（下図）

UIBQueryコンポーネントを配置し上記のUIBTransactionオブジェクトに接続する。

DataSetProviderのUpdateModeを実際の処理に合わせて設定する。
（今回は、"upWhereChanged"に設定)

DataSetProviderのBeforeUpdateRecordイベントハンドラにDB更新の処理を
記述する。このとき、更新処理が終わったら、

Applied := true

とし、ClientDataSetのキャッシュの更新終了状態にする。

今回のテストで書いた処理は下のとおり、

view plainprint?

1. procedure TForm1.DataSetProvider1BeforeUpdateRecord(Sender: TObject;  
2.   SourceDS: TDataSet; DeltaDS: TCustomClientDataSet; UpdateKind: TUpdateKind;  
3.   var Applied: Boolean);  
4. var  
5.     i : Integer;  
6.   SQL : String;  
7.   ValueStr : String;  
8.   NewStr : String;  
9.   OldStr : String;  
10.   //UIBDeltaDs : TUIBClientDataSet;  
11. begin  
12.   
13.   //UIBDeltaDs := TUIBClientDataSet.Create(Self);  
14.   //UIBDeltaDs := DeltaDS.CloneCursor();  
15.   
16.   UIBQuery1.SQL.Clear;  
17.   
18.   UIBQuery1.SQL.Add('UPDATE EMPLOYEE SET ' + #13#10);  
19.   
20.   while not(DeltaDS.eof) do  
21.   begin  
22.       //DeltaDS  
23.      SQL := '';  
24.      for i := 0 to DeltaDS.FieldCount - 1 do  
25.      begin  
26.        //UIBDeltaDs.DataConvert(  
27.        if not(VarIsEmpty(DeltaDS.Fields[i].NewValue)) then  
28.        begin  
29.           //UIBQuery1.SQL.Add  
30.           NewStr := VarToStr(DeltaDS.Fields[i].NewValue);  
31.           OldStr := IfThen(not(VarIsNull(DeltaDs.Fields[i].OldValue)), VarToStr(DeltaDS.Fields[i].OldValue));  
32.   
33.           if CompareText(NewStr,OldStr) <> 0 Then  
34.           begin  
35.              if (DeltaDs.Fields[i].DataType = ftDatetime) then  
36.              begin  
37.                 ValueStr := FormatDateTime(  
38.                                  'yyyy/mm/dd hh:nn:ss',  
39.                                  VarToDateTime(DeltaDs.Fields[i].NewValue)  
40.                             );  
41.                    ValueStr := QuotedStr(ValueStr);  
42.              end  
43.              else  
44.              begin  
45.                        ValueStr := VarToStr(DeltaDS.Fields[i].NewValue);  
46.                      if   (DeltaDs.Fields[i].DataType = ftString)  
47.                        Or (DeltaDs.Fields[i].DataType = ftWideString)  
48.                      then  
49.                      begin  
50.                         ValueStr := QuotedStr(ValueStr);  
51.                      end  
52.                 end;  
53.             end;  
54.   
55.              SQL := SQL + ', ' + DeltaDS.Fields[i].FieldName + ' = ' + ValueStr + #13#10;  
56.                  ListBox1.Items.Add(DeltaDS.Fields[i].FieldName);  
57.                  ListBox1.Items.Add(NewStr);  
58.                  ListBox1.Items.Add(OldStr);  
59.           end;  
60.        end;  
61.   
62.      if Length(Trim(SQL)) > 0 then  
63.      begin  
64.        Sql := RightStr(Sql,Length(Sql)-1);  
65.      end;  
66.   
67.      UIBQuery1.SQL.Add(SQL);  
68.   
69.      UIBQuery1.SQL.Add('WHERE EMP_NO = ' + VarToStr(DeltaDS.FieldByName('EMP_NO').OldValue));  
70.   
71.      Memo1.Lines.Assign(UIBQuery1.SQL);  
72.   
73.      UIBQuery1.ExecSQL;  
74.   
75.       DeltaDS.Next;  
76.   end;  
77.     Applied := true;  
78.   //UIBDeltaDs.Free;  
79. end;  

procedure TForm1.DataSetProvider1BeforeUpdateRecord(Sender: TObject;
  SourceDS: TDataSet; DeltaDS: TCustomClientDataSet; UpdateKind: TUpdateKind;
  var Applied: Boolean);
var
    i : Integer;
  SQL : String;
  ValueStr : String;
  NewStr : String;
  OldStr : String;
  //UIBDeltaDs : TUIBClientDataSet;
begin

  //UIBDeltaDs := TUIBClientDataSet.Create(Self);
  //UIBDeltaDs := DeltaDS.CloneCursor();

  UIBQuery1.SQL.Clear;

  UIBQuery1.SQL.Add('UPDATE EMPLOYEE SET ' + #13#10);

  while not(DeltaDS.eof) do
  begin
      //DeltaDS
     SQL := '';
     for i := 0 to DeltaDS.FieldCount - 1 do
     begin
       //UIBDeltaDs.DataConvert(
       if not(VarIsEmpty(DeltaDS.Fields[i].NewValue)) then
       begin
          //UIBQuery1.SQL.Add
          NewStr := VarToStr(DeltaDS.Fields[i].NewValue);
          OldStr := IfThen(not(VarIsNull(DeltaDs.Fields[i].OldValue)), VarToStr(DeltaDS.Fields[i].OldValue));

          if CompareText(NewStr,OldStr) <> 0 Then
          begin
             if (DeltaDs.Fields[i].DataType = ftDatetime) then
             begin
                ValueStr := FormatDateTime(
                                 'yyyy/mm/dd hh:nn:ss',
                                 VarToDateTime(DeltaDs.Fields[i].NewValue)
                            );
                   ValueStr := QuotedStr(ValueStr);
             end
             else
             begin
                       ValueStr := VarToStr(DeltaDS.Fields[i].NewValue);
                     if   (DeltaDs.Fields[i].DataType = ftString)
                       Or (DeltaDs.Fields[i].DataType = ftWideString)
                     then
                     begin
                        ValueStr := QuotedStr(ValueStr);
                     end
                end;
            end;

             SQL := SQL + ', ' + DeltaDS.Fields[i].FieldName + ' = ' + ValueStr + #13#10;
                 ListBox1.Items.Add(DeltaDS.Fields[i].FieldName);
                 ListBox1.Items.Add(NewStr);
                 ListBox1.Items.Add(OldStr);
          end;
       end;

     if Length(Trim(SQL)) > 0 then
     begin
       Sql := RightStr(Sql,Length(Sql)-1);
     end;

     UIBQuery1.SQL.Add(SQL);

     UIBQuery1.SQL.Add('WHERE EMP_NO = ' + VarToStr(DeltaDS.FieldByName('EMP_NO').OldValue));

     Memo1.Lines.Assign(UIBQuery1.SQL);

     UIBQuery1.ExecSQL;

      DeltaDS.Next;
  end;
    Applied := true;
  //UIBDeltaDs.Free;
end;

ここで、テーブルに対する操作は、UpdateKindで、変更対象のレコードは、DeltaDS
で取得できる。

あとは、適当なタイミングでClientDataSetのApplyUpdateメソッドをよびだせば、
データの更新ができる。(今回はボタンのクリックに割り当てた。)

以下、ソース例

view plainprint?

1. procedure TForm1.Button1Click(Sender: TObject);  
2. begin  
3.   //ClientDataSet1.Post;  
4.     UIBClientDataSet1.ApplyUpdates(-1);  
5. end;  

procedure TForm1.Button1Click(Sender: TObject);
begin
  //ClientDataSet1.Post;
    UIBClientDataSet1.ApplyUpdates(-1);
end;

Unified Interbaseコンポーネントをつかってみた（その３）

Unified Interbaseコンポーネントをつかってみた（その1）でUIBDataSet経由でDBグリッドに
データを表示した。

しかし、UIBDataSetはReadOnlyのデータセットなので、編集が不可となっています。
(前回のサンプルを実行してもグリッドに入力ができません。)

いくつか、実験をおこなった結果、UIBDataSetは、単方向データセットとして機能している
ようなので、ClientDataSetを経由で接続すれば、DbExpressドライバのように使えるはず
だと思い試してみた。

以下、試して確認できたことを備忘録代わりに記述

フォームにTClientDataSetコンポーネントとTDataSetProviderコンポーネントを配置し、
UIBDataset → DatasetProvieder → ClientDataset → DataSourceにリンク変更


ここで、ClientDataset をActiveにするとタイムスタンプがうまく処理できないようでエラーが
発生するので、ClinetDataSet、およびUIBDataSetのソースを調べた結果、以下のとおり
データ形式の不整合があった。

UIBDataSet -> TDatetime型
ClinetDataSet　→ 通算のミリ秒(ftDatetime指定時）

そこで、ClientDatasetと時刻データが正しく連携が取れるようUIBDataSetを拡張したコンポーネントで、接続した。
以下、ソース

view plainprint?

1. unit UIBCdsDataSet;  
2.   
3. interface  
4.   
5. uses  
6.   SysUtils, Classes, DB, uibdataset;  
7.   
8. type  
9.   TUIBCdsDataSet = class(TUIBDataSet)  
10.   private  
11.     { Private 宣言 }  
12.   protected  
13.     { Protected 宣言 }  
14.   public  
15.     { Public 宣言 }  
16.     function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload;{$IFNDEF FPC} override; {$ENDIF}  
17.     {$IFNDEF FPC}  
18.     function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; overload; override;  
19.     {$ENDIF}  
20.   published  
21.     { Published 宣言 }  
22.   end;  
23.   
24. procedure Register;  
25.   
26. implementation  
27.   
28. uses uiblib;  
29.   
30. procedure Register;  
31. begin  
32.   RegisterComponents('UIB', [TUIBCdsDataSet]);  
33. end;  
34.   
35. { TUIBCdsDataSet }  
36.   
37. function TUIBCdsDataSet.GetFieldData(FieldNo: Integer;  
38.   Buffer: Pointer): Boolean;  
39. var  
40.   doubleBuf : TDateTime;  
41.   aFieldType: TUIBFieldType;  
42.   tsbuf : TTimeStamp;  
43. begin  
44.   
45.  Result := inherited GetFieldData(FieldNo, Buffer);  
46.   if not(Result) then Exit;  
47.   if Buffer = nil then Exit;  
48.   
49.   aFieldType := Self.InternalFields.FieldType[FieldNo -1];  
50.   
51.   if aFieldType = uftTimestamp then  
52.   begin  
53.    doubleBuf := TDateTime(Buffer^);  
54.     tsbuf := DateTimeToTimeStamp(doubleBuf);  
55.   
56.    Double(Buffer^) :=  TimeStampToMSecs(tsbuf);  
57.  end;  
58. end;  
59.   
60. function TUIBCdsDataSet.GetFieldData(Field: TField; Buffer: Pointer;  
61.   NativeFormat: Boolean): Boolean;  
62. var  
63.  //SF : TSQLResult;  
64.   doubleBuf : TDateTime;  
65.   aFieldType: TUIBFieldType;  
66.   tsbuf : TTimeStamp;  
67. begin  
68.   
69.   Result := inherited GetFieldData(Field, Buffer,NativeFormat);  
70.   if not(Result) then Exit;  
71.   if Buffer = nil then Exit;  
72.   
73.   //SF := Self.InternalFields;  
74.   aFieldType := Self.InternalFields.FieldType[Field.FieldNo-1];  
75.   
76.   if aFieldType = uftTimestamp then  
77.   begin  
78.    doubleBuf := TDateTime(Buffer^);  
79.     tsbuf := DateTimeToTimeStamp(doubleBuf);  
80.   
81.    Double(Buffer^) :=  TimeStampToMSecs(tsbuf);  
82.   end;  
83.   
84. end;  
85.   
86. end.  

unit UIBCdsDataSet;

interface

uses
  SysUtils, Classes, DB, uibdataset;

type
  TUIBCdsDataSet = class(TUIBDataSet)
  private
    { Private 宣言 }
  protected
    { Protected 宣言 }
  public
    { Public 宣言 }
    function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload;{$IFNDEF FPC} override; {$ENDIF}
    {$IFNDEF FPC}
    function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; overload; override;
    {$ENDIF}
  published
    { Published 宣言 }
  end;

procedure Register;

implementation

uses uiblib;

procedure Register;
begin
  RegisterComponents('UIB', [TUIBCdsDataSet]);
end;

{ TUIBCdsDataSet }

function TUIBCdsDataSet.GetFieldData(FieldNo: Integer;
  Buffer: Pointer): Boolean;
var
  doubleBuf : TDateTime;
  aFieldType: TUIBFieldType;
  tsbuf : TTimeStamp;
begin

 Result := inherited GetFieldData(FieldNo, Buffer);
  if not(Result) then Exit;
  if Buffer = nil then Exit;

  aFieldType := Self.InternalFields.FieldType[FieldNo -1];

  if aFieldType = uftTimestamp then
  begin
   doubleBuf := TDateTime(Buffer^);
    tsbuf := DateTimeToTimeStamp(doubleBuf);

   Double(Buffer^) :=  TimeStampToMSecs(tsbuf);
 end;
end;

function TUIBCdsDataSet.GetFieldData(Field: TField; Buffer: Pointer;
  NativeFormat: Boolean): Boolean;
var
 //SF : TSQLResult;
  doubleBuf : TDateTime;
  aFieldType: TUIBFieldType;
  tsbuf : TTimeStamp;
begin

  Result := inherited GetFieldData(Field, Buffer,NativeFormat);
  if not(Result) then Exit;
  if Buffer = nil then Exit;

  //SF := Self.InternalFields;
  aFieldType := Self.InternalFields.FieldType[Field.FieldNo-1];

  if aFieldType = uftTimestamp then
  begin
   doubleBuf := TDateTime(Buffer^);
    tsbuf := DateTimeToTimeStamp(doubleBuf);

   Double(Buffer^) :=  TimeStampToMSecs(tsbuf);
  end;

end;

end.

これで時刻型のフィールドでエラーが発生することなく連携ができた。

Unified Interbaseコンポーネントをつかってみた（その2-- Delphi2007に入れる）

Unified Interbaseコンポーネントは、Delphi2007で使えます。

インストールするには、UIBD11Win32.groupprojを開き
実行時パッケージ→開発時パッケージの順でインストールします。

ただし、Delphi2007のUnified Interbaseコンポーネントは、内部で
SynEditコンポーネントを使用しているので先にSynEditをインストール
する必要があります。

SynEditは、次の手順でインストールします。（自分が行った方法です。)

1. ダウンロードサイトより最新版(2011.01.30現在では2.0.6)をダウンロードして
適当な場所に解凍します。

2. PackageフォルダーからDelphi2006用のプロジェクトグループ
 SynEdit_R2006.groupprojを開きます。(Delphi2007用のものがない為です。)

3. プロジェクトファイル名をSynEdit_R2007.groupproj、および、として保存します。
   これは、下図のようにDelphi2007用のパッケージがSynEdit_R2007を
要求しているからです。

 (ここをR2006にしても良いと思いますが自分はSynEditのパッケージ名を変えました。)

4. SynEditをインストールします。

なお、この状態で、SynEditの開発用パッケージもインストールする場合は、

(a)．上記2と同様にSynEdit_D2006.groupprojを開き
(b).  パッケージソースファイルをのrequiresのSynEdit_R2006をSynEdit_R2007と
しパッケージ名をSynEdit_D2007.groupprojに変更して保存し
(c)．開発時パッケージをインストールします。

Unified Interbaseコンポーネントをつかってみた（その１）

Unified Interbaseコンポーネントは、Delphi XE対応のInterbase, Firebird接続用のコンポーネントです。
FB2.5にも対応しているということなのでちょっと試してみたので備忘録代わりに記述

先ずは、インストール

Unified Interbaseのリポジトリからファイルをダウンロード

ダウンロードしたZIPファイルを適当なフォルダに展開し、パッケージフォルダから
UIBD15Win32.groupprojを開く。

開発時パッケージUIBD15Win32D.bplをインストール
エラーが発生しなければ

下図のようにツールパレットにコントロールが登録されます。

Firebirdに接続してみる。

フォームにTUIBDatabaseコンポーネントを配置して右クリックを押すと
接続エディタが表示されるので、接続情報を入力する。
テストボタンで接続をテストすることができます。

UIBDataSetコンポーネントを配置しDatabsaeプロパティにUIBDatabseを指定します。
SQLプロパティにSQL文を記述します。

次に、UIBTransactionプロパティを配置し、DatabaseプロパティにUIBDatabseを指定します。
（UIBTransactionは、きめ細かい設定ができるようなのですが、ここではそのまま使います。）

また、UIBDataSetコンポーネントのTransactionプロパティにUIBTransactionを指定します。

あとは、DataSourceコンポーネントを介してDatabaseコントロールと接続します。

UIBDatabseのConnectedプロパティと、UIBDatasetのActiveプロパティをTrueにすれば
下図のようにデータが読み込めます。