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のキャッシュの更新終了状態にする。

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

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メソッドをよびだせば、
データの更新ができる。(今回はボタンのクリックに割り当てた。)

以下、ソース例

procedure TForm1.Button1Click(Sender: TObject);
begin
  //ClientDataSet1.Post;
    UIBClientDataSet1.ApplyUpdates(-1);
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)．開発時パッケージをインストールします。

プロセスの再起動

仕事で、プロセスを外部から強制的に再起動を
する必要があったのでとりあえずつくってみた。

停止させるプロセスは、仕様上一意性が保障されている
ので、コマンドライン引数に起動するプロセスの絶対パスを
与えて、そこからプロセスIDを求めています。

プロセスに停止メッセージ（メインウインドウのクローズ）を
ポストし、5秒まっても終了していなかったら
強制終了しています。

プロセスの起動には、JvCreateProcessコンポーネントを
使っています。
このコンポーネントは、非常に便利ですね。

program RestartProcess;

{$APPTYPE CONSOLE}

uses
  SysUtils,Windows,TLHELP32,Messages,JvCreateProcess;


function GetProcessFromName(ProcessName :String) : Cardinal;
var
   ProcEntry : TProcessEntry32;
   SanpshotHandle : THandle;
   ListProcName : String;

begin
   //Toolhelp32を使用する例
  Result := 0;
   SanpshotHandle := TlHelp32.CreateToolhelp32Snapshot(TlHelp32.TH32CS_SNAPPROCESS,0);
   if (SanpshotHandle <> -1) then
      begin
         ProcEntry.dwSize := Sizeof(TProcessEntry32W);
         if (TlHelp32.Process32First(SanpshotHandle,ProcEntry)) Then
         begin
            repeat
              ListProcName := ProcEntry.szExeFile;
              if CompareText(ListProcName,ProcessName) = 0 then
              begin
                 Result := ProcEntry.th32ProcessID;
              end;
              //WriteLn(ListProcName);
          until (TlHelp32.Process32Next(SanpshotHandle,ProcEntry) = false);
       end;
    end;
    CloseHandle(SanpshotHandle);

end;


function EnumWindowsProc(hwindow :HWnd; lparam :LPARAM):BOOL; stdcall;
var
  ProcessID : Cardinal;
  ThreadID : Cardinal;
begin

   Result := True;

   ThreadID := GetWindowThreadProcessId(hwindow, ProcessID);

   If (ProcessID = lParam) Then
   begin
      PostMessage(hwindow, WM_CLOSE, 0, 0);
     Result := true;
   End;
End;


function SendClose(ProcID : Cardinal) : Boolean;
begin
   Result := EnumWindows(@EnumWindowsProc, ProcID)
End;

function StopProcess(ProcessName : String; Force : Boolean = false) : Integer;
var
   ProcessID : Cardinal;
  hProcess : THandle;
begin
   ProcessID := GetProcessFromName(ProcessName);
  if ProcessID = 0 then
  begin
     Result := -1;
  end
  else
  begin
     if (ProcessID > 0) Then
     begin
        if Force then
        begin
           hProcess := OpenProcess(PROCESS_TERMINATE, False, ProcessID);
           TerminateProcess(hProcess , 0 );
           CloseHandle(hProcess);
           Result := 0;
        end
        else
        begin
           Result := 1;
           if SendClose(ProcessID) then
           begin
              Result := 0;
           end;
        end;
     end;
  end;
end;

var
   StopResult : Integer;
   JvCreateProcess: TJvCreateProcess;
  ExeName : String;
  ProcessID : Cardinal;

begin
  try
  { TODO -oUser -cConsole Main : ここにコードを記述してください }

     if ParamCount > 0 then
     begin
        ExeName := ExtractFileName(ParamStr(1));
         StopResult := StopProcess(ExeName);

        //五秒まって停止イしたかどうかを確認する
        Sleep(5000);

        ProcessID := GetProcessFromName(ExeName);

        //プロセスが正常に停止できなかったので' +
        //強制終了する
        if ProcessID > 0 Then
        begin
           StopResult := StopProcess(ExeName,true);
           Sleep(10000);
        end;


        if StopResult <> 1 then
        begin
           JvCreateProcess := TJvCreateProcess.Create(nil);
           try
              JvCreateProcess.CommandLine := ParamStr(1);
              JvCreateProcess.WaitForTerminate := false;
              JvCreateProcess.Run;
           finally
              JvCreateProcess.Free;
            end;
        end;
     end;
     //ReadLn;
  except
    on E:Exception do
      Writeln(E.Classname, ': ', E.Message);
  end;
end.

JvScheduledEventsを試してみる。

仕事で、とあるプロセスを定刻起動する必要があった。

ＯＳ標準のタスクスケジューラを使用してもよっかったが
起動できるのがバッチファイルか単独のEXEになるので
もううちょっと処理を柔軟にしたいと思いJVCLの
JvScheduledEventsを試してみた。

TJvScheduledEventsは、画面でスケジューリングの
設定が可能であるが、今回は、スケジュールを外部
ファイルに持たせたかったので、プラグラム中で
設定することにした。

以下、サンプルで試したソース。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, JvScheduledEvents, StdCtrls, ExtCtrls, ComCtrls, JvComponentBase,
  JvCreateProcess;

type
  TForm1 = class(TForm)
    Button1: TButton;
    DateTimePicker1: TDateTimePicker;
    Label1: TLabel;
    LabeledEdit1: TLabeledEdit;

    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    FJvScheduledEvents : TJvScheduledEvents;
    procedure JvScheduledEventsExecute(Sender: TJvEventCollectionItem;
              const IsSnoozeEvent: Boolean);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  JclSchedule;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  EventItem : TJvEventCollectionItem;
  IJclSched : JclSchedule.IJclSchedule;
  IDaySched : IJclDailySchedule;
  IDyaFreq : IJclScheduleDayFrequency;

begin
  EventItem := FJvScheduledEvents.Events.Add;
  IJclSched := EventItem.Schedule;

   //イベントアイテムのスケジュール自体は、
   //IJclScheduleで受けますが、実態はTJclScheduleで
   //IJclScheduleのほか
   //IJclScheduleDayFrequency,
   //IJclDailySchedule,
    //IJclWeeklySchedule,
   //IJclMonthlySchedule,
   //IJclYearlySchedule
   //を継承しています。

   IJclSched.RecurringType := srkDaily;

   IDaySched := (IJclSched as IJclDailySchedule);
   if Assigned(IDaySched) then
   begin
      //毎日実行する場合は、EveryWeekDayをFalseにして
      //間隔を1(日)にします。
      IDaySched.EveryWeekDay := false;
      IDaySched.Interval := 1;
   end;

   IDyaFreq := (IJclSched as IJclScheduleDayFrequency);
   if Assigned(IDyaFreq) then
   begin
      IDyaFreq.StartTime := DateTimeToTimeStamp(Self.DateTimePicker1.Time).Time;
      IDyaFreq.EndTime   := IDyaFreq.StartTime;
      IDyaFreq.Interval := 1;
   end;

   EventItem.Name := LabeledEdit1.Text;
   EventItem.OnExecute := JvScheduledEventsExecute;
   EventItem.Start;

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FJvScheduledEvents := TJvScheduledEvents.Create(Self);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FJvScheduledEvents.Events.Clear;
  FJvScheduledEvents.Free;
end;

procedure TForm1.JvScheduledEventsExecute(Sender: TJvEventCollectionItem;
  const IsSnoozeEvent: Boolean);
var
  JvCreateProcess: TJvCreateProcess;
begin

  JvCreateProcess := TJvCreateProcess.Create(Self);
  try
    JvCreateProcess.CommandLine := Sender.Name;
    JvCreateProcess.WaitForTerminate := true;
    JvCreateProcess.Run;

  finally
    JvCreateProcess.Free;
  end;


end;

end.

ポイントは、以下の２つかと思います。

1. JclScheduleをUsesに加えることと
2. TJvEventCollectionItem.Scheduleの戻り値がIJclSchedule型であるが実態はTJclSchedule型でIJclScheduleのほかIJclScheduleDayFrequency,IJclDailySchedule,IJclWeeklySchedule,IJclMonthlySchedule,
   IJclYearlyScheduleを継承していて設定したいスケジュールにあわせて適切にキャストする必要があること

今回のサンプルは、『ボタンを押したら指定した時刻にメモ帳を起動する』というタイマーで処理しても
十分なものですが、リフレクション、パッケージの動的ロードなどを使えば、もっと面白いことが
できそうな気がします。

SQL Server のデータベースのテーブルとフィールド名を表示する。（その2)

Sql Server 2005以上であれば、システムカタログに対してクエリを発行することで
テーブル名とフィールド名のリストの取得ができます。
(詳細は、システムカタログのクエリのQandAページを参照)

クエリを発行できるということは、

程度の画面であればマスターリンクを使ってノンコーディング
（クエリーは組む必要はありますが）でテーブルとフィールドのリストを表示できます。

このへんがDelphiのすごいところですね。

以下、フォーム表示をテキスト表示したもの


object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 535
  ClientWidth = 727
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object PageControl1: TPageControl
    Left = 0
    Top = 0
    Width = 727
    Height = 535
    ActivePage = TabSheet2
    Align = alClient
    TabOrder = 0
    object TabSheet1: TTabSheet
      Caption = 'TabSheet1'
      object Label1: TLabel
        Left = 192
        Top = 88
        Width = 56
        Height = 13
        Caption = #12501#12451#12540#12523#12489#21517
      end
      object Label2: TLabel
        Left = 16
        Top = 88
        Width = 50
        Height = 13
        Caption = #12486#12540#12502#12523#21517
      end
      object Label3: TLabel
        Left = 552
        Top = 88
        Width = 56
        Height = 13
        Caption = #12501#12451#12540#12523#12489#21517
      end
      object Label4: TLabel
        Left = 376
        Top = 88
        Width = 50
        Height = 13
        Caption = #12486#12540#12502#12523#21517
      end
      object Button1: TButton
        Left = 96
        Top = 16
        Width = 169
        Height = 33
        Caption = 'dbGo'#12398#12513#12477#12483#12489#12434#20351#29992
        TabOrder = 0
        OnClick = Button1Click
      end
      object ListBox1: TListBox
        Left = 16
        Top = 106
        Width = 169
        Height = 401
        ItemHeight = 13
        TabOrder = 1
        OnClick = ListBox1Click
      end
      object ListBox2: TListBox
        Left = 191
        Top = 106
        Width = 169
        Height = 401
        ItemHeight = 13
        TabOrder = 2
      end
      object ListBox3: TListBox
        Left = 376
        Top = 106
        Width = 169
        Height = 401
        ItemHeight = 13
        TabOrder = 3
        OnClick = ListBox3Click
      end
      object ListBox4: TListBox
        Left = 550
        Top = 106
        Width = 169
        Height = 401
        ItemHeight = 13
        TabOrder = 4
      end
      object Button2: TButton
        Left = 472
        Top = 16
        Width = 169
        Height = 33
        Caption = 'DbExpress'#12398#12513#12477#12483#12489#12434#20351#29992
        TabOrder = 5
        OnClick = Button2Click
      end
    end
    object TabSheet2: TTabSheet
      Caption = 'TabSheet2'
      ImageIndex = 1
      object DBGrid1: TDBGrid
        Left = 0
        Top = 0
        Width = 145
        Height = 507
        Align = alLeft
        DataSource = DataSource1
        TabOrder = 0
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'Tahoma'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'Name'
            Visible = True
          end>
      end
      object DBGrid2: TDBGrid
        Left = 145
        Top = 0
        Width = 160
        Height = 507
        Align = alLeft
        DataSource = DataSource2
        TabOrder = 1
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'Tahoma'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'NAME'
            Visible = True
          end>
      end
    end
    object TabSheet3: TTabSheet
      Caption = 'TabSheet3'
      ImageIndex = 2
      object DBGrid3: TDBGrid
        Left = 0
        Top = 0
        Width = 177
        Height = 507
        Align = alLeft
        DataSource = DataSource3
        TabOrder = 0
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'Tahoma'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'Name'
            Visible = True
          end>
      end
      object DBGrid4: TDBGrid
        Left = 177
        Top = 0
        Width = 184
        Height = 507
        Align = alLeft
        DataSource = DataSource4
        TabOrder = 1
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'Tahoma'
        TitleFont.Style = []
        Columns = <
          item
            Expanded = False
            FieldName = 'NAME'
            Visible = True
          end>
      end
    end
  end
  object ADOConnection1: TADOConnection
    Connected = True
    ConnectionString =
      'Provider=SQLNCLI10.1;Integrated Security="";Persist Security Inf' +
      'o=False;User ID=sa;Initial Catalog=AdventureWorks;Data Source=SA' +
      'KANOTE-PC\SqlExpress;Initial File Name="";Server SPN=""'
    LoginPrompt = False
    Provider = 'SQLNCLI10.1'
    Left = 16
    Top = 456
  end
  object SQLConnection1: TSQLConnection
    ConnectionName = 'MSSQLConnection'
    DriverName = 'MSSQL'
    GetDriverFunc = 'getSQLDriverMSSQL'
    LibraryName = 'dbxmss.dll'
    LoginPrompt = False
    Params.Strings = (
      'SchemaOverride=%.dbo'
      'DriverUnit=DBXMSSQL'
    
        'DriverPackageLoader=TDBXDynalinkDriverLoader,DBXCommonDriver150.' +
        'bpl'
    
        'DriverAssemblyLoader=Borland.Data.TDBXDynalinkDriverLoader,Borla' +
        'nd.Data.DbxCommonDriver,Version=15.0.0.0,Culture=neutral,PublicK' +
        'eyToken=91d62ebb5b0d1b1b'
    
        'MetaDataPackageLoader=TDBXMsSqlMetaDataCommandFactory,DbxMSSQLDr' +
        'iver150.bpl'
    
        'MetaDataAssemblyLoader=Borland.Data.TDBXMsSqlMetaDataCommandFact' +
        'ory,Borland.Data.DbxMSSQLDriver,Version=15.0.0.0,Culture=neutral' +
        ',PublicKeyToken=91d62ebb5b0d1b1b'
      'GetDriverFunc=getSQLDriverMSSQL'
      'LibraryName=dbxmss.dll'
      'VendorLib=sqlncli10.dll'
      'MaxBlobSize=-1'
      'OSAuthentication=False'
      'PrepareSQL=True'
      'DriverName=MSSQL'
      'HostName=SAKANOTE-PC\SQLEXPRESS'
      'Database=AdventureWorks'
      'User_Name=sa'
      'Password=sysdba'
      'BlobSize=-1'
      'ErrorResourceFile='
      'LocaleCode=0000'
      'IsolationLevel=ReadCommitted'
      'OS Authentication=False'
      'Prepare SQL=False'
      'ConnectTimeout=60'
      'Mars_Connection=False')
    VendorLib = 'sqlncli10.dll'
    Connected = True
    Left = 464
    Top = 56
  end
  object ADOQuery1: TADOQuery
    Connection = ADOConnection1
    CursorType = ctStatic
    Parameters = <>
    SQL.Strings = (
      'SELECT Object_ID, Name FROM SYS.TABLES')
    Left = 16
    Top = 488
  end
  object DataSetProvider1: TDataSetProvider
    DataSet = ADOQuery1
    Left = 56
    Top = 504
  end
  object ClientDataSet1: TClientDataSet
    Active = True
    Aggregates = <>
    Params = <>
    ProviderName = 'DataSetProvider1'
    Left = 88
    Top = 504
  end
  object DataSource1: TDataSource
    DataSet = ClientDataSet1
    Left = 24
    Top = 184
  end
  object ADOQuery2: TADOQuery
    Connection = ADOConnection1
    CursorType = ctStatic
    Parameters = <
      item
        Name = 'Object_ID'
        DataType = ftInteger
        Value = 14623095
      end>
    SQL.Strings = (
      'SELECT Object_ID , NAME FROM sys.columns')
    Left = 144
    Top = 504
  end
  object ClientDataSet2: TClientDataSet
    Active = True
    Aggregates = <>
    IndexFieldNames = 'Object_ID'
    MasterFields = 'Object_ID'
    MasterSource = DataSource1
    PacketRecords = 0
    Params = <>
    ProviderName = 'DataSetProvider2'
    Left = 208
    Top = 504
  end
  object DataSetProvider2: TDataSetProvider
    DataSet = ADOQuery2
    Left = 176
    Top = 504
  end
  object DataSource2: TDataSource
    DataSet = ClientDataSet2
    Left = 96
    Top = 176
  end
  object ClientDataSet3: TClientDataSet
    Active = True
    Aggregates = <>
    Params = <>
    ProviderName = 'DataSetProvider3'
    Left = 464
    Top = 112
  end
  object DataSetProvider3: TDataSetProvider
    DataSet = SQLQuery1
    Left = 464
    Top = 168
  end
  object SQLQuery1: TSQLQuery
    MaxBlobSize = -1
    Params = <>
    SQL.Strings = (
      'SELECT Object_ID, Name FROM SYS.TABLES')
    SQLConnection = SQLConnection1
    Left = 464
    Top = 216
  end
  object DataSource3: TDataSource
    DataSet = ClientDataSet3
    Left = 456
    Top = 280
  end
  object DataSetProvider4: TDataSetProvider
    DataSet = SQLQuery2
    Left = 600
    Top = 176
  end
  object ClientDataSet4: TClientDataSet
    Active = True
    Aggregates = <>
    IndexFieldNames = 'Object_ID'
    MasterFields = 'Object_ID'
    MasterSource = DataSource3
    PacketRecords = 0
    Params = <>
    ProviderName = 'DataSetProvider4'
    Left = 592
    Top = 104
  end
  object DataSource4: TDataSource
    DataSet = ClientDataSet4
    Left = 576
    Top = 280
  end
  object SQLQuery2: TSQLQuery
    MaxBlobSize = -1
    Params = <
      item
        DataType = ftInteger
        Name = 'Object_ID'
        ParamType = ptInput
        Value = 14623095
      end>
    SQL.Strings = (
      'SELECT Object_ID , NAME FROM sys.columns')
    SQLConnection = SQLConnection1
    Left = 584
    Top = 240
  end
end

SQL Server のデータベースのテーブルとフィールド名を表示する。（その1)

仕事でSql Serverのテーブルリストを表示する必要があったので・・・

DelphiでSQl Srerverのテーブルリストを表示する方法をいくつか


1. dbGOのConnectionのGetTableNamesメソッドとGetFieldNamesメソッドを利用する。


dbGoのGetTableNamesを利用すればInitial_Catalogで指定したデータベースの
テーブルリストを取得できます。

また、GetFieldNamesを利用すれば、指定したテーブルのフィールドのリストを表示できます。

ソースは、こんな感じ・・・
（ボタンをクリックするとテーブルのリストを表示し、リストの中のテーブルをクリックすると
クリックしたテーブルのリストを表示します。）

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOConnection1.Connected := true;
  ADOConnection1.GetTableNames(ListBox1.Items,false);
  ADOConnection1.Connected := false;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
var
  TableName : String;
begin
   if ListBox1.Items.Count > 0 then
   begin
      TableName := ListBox1.Items[ListBox1.ItemIndex];
      if Length(TableName) > 0 then
      begin
        ADOConnection1.Connected := true;
        ADOConnection1.GetFieldNames(TableName,ListBox2.Items);
        ADOConnection1.Connected := false;
      end;
   end;
end;

2. DbExpressを利用する。

DbExpressのSQLConnectionにもGetTableNamesメソッドとGetFieldNamesがあるので
dbGOと同様に処理できます。

ただし、試した中では、DbExpressでは、スキーマを指定しないとdboスキーマのテーブル
しか取得しないようなので、GetSchemaNamesでスキーマ名のリストを取得したうえで
スキーマ毎にテーブルを取得する必要がありました。

でソースはこんな感じ。スキーマ名を取得してる関係でちょっと複雑です。

procedure TForm1.Button1Click(Sender: TObject);

procedure TForm1.Button2Click(Sender: TObject);
var
  GetSchemaNames : TStringList;
  TableNames : TStringList;
  i,j : Integer;
begin
  ListBox3.Items.Clear;
  SQLConnection1.Connected := true;
  GetSchemaNames := TStringList.Create;
  try
    SQLConnection1.GetSchemaNames(GetSchemaNames);
    for i := 0 to GetSchemaNames.Count -1 do
    begin
      TableNames := TStringList.Create;
      try
        SQLConnection1.GetTableNames(TableNames,GetSchemaNames.Strings[i],false);
        for j := 0 to TableNames.Count-1 do
        begin
          ListBox3.Items.Add(GetSchemaNames.Strings[i] + '.' + TableNames.Strings[j]);
        end;
      finally
        TableNames.Free;
      end;
    end;
  finally
    GetSchemaNames.Free;
  end;
  SQLConnection1.Connected := false;
end;

procedure TForm1.ListBox3Click(Sender: TObject);
var
  TableName : String;
begin
   if ListBox1.Items.Count > 0 then
   begin
      TableName := ListBox3.Items[ListBox3.ItemIndex];
      if Length(TableName) > 0 then
      begin
        SQLConnection1.Connected := true;
        SQLConnection1.GetFieldNames(TableName,ListBox4.Items);
        SQLConnection1.Connected := false;
      end;

   end;
end;

SameValue関数

StackOverFlowのTopicのトピックを見ていてDelphiのMathユニットに

SameValue関数なる関数が用意されていることを初めて知りました。

この関数は、指定した値が、２つの値がEpsilonで指定した値以内に
あれば、等しいと見なす関数です。

DelphiというかVCL(RTLも含むには）便利な比較関数が用意されています。

今まで、都度都度、自作していたかと思うとちょっと反省。

プロセスリストを表示する。

プロセスの一覧を表示するサンプルです。

Toolhelp32(DelphではTlHelp32)が使える環境では
比較的簡単ですが、

procedure TForm1.Button2Click(Sender: TObject);
var
 ProcEntry : TProcessEntry32W;
   SanpshotHandle : THandle;
begin
 //Toolhelp32を使用する例
   SanpshotHandle := TlHelp32.CreateToolhelp32Snapshot(TlHelp32.TH32CS_SNAPPROCESS,0);
   if (SanpshotHandle <> -1) then
   begin
    ListBox1.Items.Clear;
    ProcEntry.dwSize := Sizeof(TProcessEntry32W);
      if (TlHelp32.Process32First(SanpshotHandle, ProcEntry)) Then
      begin
         repeat
          ListBox1.Items.Add(ProcEntry.szExeFile);
         until (TlHelp32.Process32Next(SanpshotHandle,ProcEntry) = false);
      end;
   end;
   CloseHandle(SanpshotHandle);

end;

使えない環境(といいても、4.0以下のNTだけですが・・・）だと
大変です。

procedure TForm1.Button1Click(Sender: TObject);
var
    cb : Cardinal;
   elements : Cardinal;
   Needs : Cardinal;
   ProcIdArray : Array of DWORD;
   Win32Ret : LongBool;
   i : Cardinal;
   ProcHandle : THandle;
   OpenMode : THandle;
   ProcessName : String;

begin

    //プロセス数がいくつあるか解らないので大きめにとっておく
   elements := 128;
   Needs := elements * Sizeof(DWORD);
   cb := 0;
   while (cb <= Needs) do
   begin

        SetLength(ProcIdArray, elements);
       cb := Length(ProcIdArray) * Sizeof(DWORD);
       Needs := 0;
      Win32Ret := PsApi.EnumProcesses(PDWORD(ProcIdArray),cb,Needs);

      //APIが失敗したら抜ける
      if (not(Win32Ret)) then
      begin
         break;
      end;

      //領域が足りなかったときに備えて倍にする。
      elements := elements * 2;

   end;

   if (Win32Ret) then
   begin
       ListBox1.Items.Clear;
      OpenMode := Windows.PROCESS_QUERY_INFORMATION or Windows.PROCESS_VM_READ;
        elements := Needs div Sizeof(DWORD);
       for i := 0 to elements - 1 do
       begin
          //プロセスIDから情報をえる
         ProcHandle := Windows.OpenProcess(OpenMode,FALSE,ProcIdArray[i]);
         if (ProcHandle <> 0) then
         begin
             ProcessName := GetProcessName(ProcHandle);
            if (Length(ProcessName) > 0) then
            begin
                ListBox1.Items.Add(ProcessName);
            end;
         end;
         Windows.CloseHandle(ProcHandle);
      end;
   end;

end;

function TForm1.GetProcessName(ProcessHandle: THandle): String;
var
    cb : Cardinal;
   elements : Cardinal;
   Needs : Cardinal;
   ModuleHandleArray : Array of THandle;
   Win32Ret : LongBool;
   i : longint;
   ModuleHandle: THandle;
   ModuleName : WideString;
   ModeleNameLength : Integer;
   ProcessName : String;
   FileExt : String;
begin

    Result := '';
    //モジュール数数がいくつあるか解らないので大きめにとっておく
   elements := 128;
   Needs := elements * Sizeof(DWORD);
   cb := 0;
   while (cb <= Needs) do
   begin

        SetLength(ModuleHandleArray, elements);
       cb := Length(ModuleHandleArray) * Sizeof(DWORD);
       Needs := 0;
      Win32Ret := PsApi.EnumProcessModules(ProcessHandle,PDWORD(ModuleHandleArray),cb,Needs);

      //APIが失敗したら抜ける
      if (not(Win32Ret)) then
      begin
         break;
      end;
      //領域が足りなかったときに備えて倍にする。
      elements := elements * 2;
   end;

   if (Win32Ret) then
   begin
       ModeleNameLength := 255;
      SetLength(ModuleName,ModeleNameLength);
        elements := Needs div Sizeof(DWORD);
       for i := 0 to elements - 1 do
       begin
          ModuleHandle := ModuleHandleArray[i];
          ModeleNameLength := PsApi.GetModuleBaseName(
                                  ProcessHandle,
                                ModuleHandle,
                                PWideChar(ModuleName),
                                ModeleNameLength);
         if (ModeleNameLength > 0) then
         begin
             //モジュール名がExeファイルであればプロセスとみなす。
             SetLength(ModuleName,ModeleNameLength);
            ProcessName := ModuleName;
            FileExt := ExtractFileExt(ProcessName);
            if (CompareText(FileExt,'.EXE') = 0)  then
            begin
                Result :=  ProcessName;
               break;
            end;
         end;
      end;
   end;
end;

IOUtilsユニットをつかってみる（その1)

Delphi2010で追加されたIOUtilsユニットを使ってファイルリスト
（正確にはファイル名のリスト）を取得するだけであれば、

TDirectory.GetFilesメソッドで簡単に取得できます。

Delphi Prism(.Net版）とほぼ同じ形でかけます。



GetFilesメソッドはいくつかOverLoadの定義がありますが、

今回は、

function GetFiles(const Path: string;
const SearchPattern: string;
const SearchOption: TSearchOption): TStringDynArray; overload; static;


を使用した簡単なサンプルを作ってみました。

ここで、Pathは検索パス
　　　　SearchPatternは、検索パターン(全検索は'*')
　 SearchOptionは、
　　　　　サブディレクトリも検索するときはsoAllDirectories
　　　　　指定したディレクトリのみを検索するときは、soTopDirectoryOnly
を指定します。

以下、サンプルプログラム

procedure TForm1.ButtonExecGetFileClick(Sender: TObject);
var
MyDir : IOUtils.TDirectory;
 FileList : TStringDynArray;
 FileName : String;
begin

ListBox1.Clear;

if Self.CheckBoxFindSubDir.Checked then
 begin
 FileList := MyDir.GetFiles(EditStartPath.Text,'*',TSearchOption.soAllDirectories);
 end
 else
 begin
 FileList := MyDir.GetFiles(EditStartPath.Text,'*.XLS',TSearchOption.soTopDirectoryOnly);
 end;

 for FileName In FileList do
 begin
  ListBox1.Items.Add(FileName);
 end;

end;

と結構簡単にかけます。
（ただ、ファイル数が多いとなかなか帰ってこないです。)

Rttiを使ってClientDataSetを作ってみる

以前、Team JapanのブログにEmployeeクラスのインスタンスからInsert文を
生成するサンプルのポストがありましたが、ちょっと改良してTClientDataSetを
動的生成する例を書いてみた。（って使い道があるかちょっと疑問です。）

一応ソースは、こんな感じ

unit Unit3;

interface

uses
　　DBClient;

  type DataSetOperator = Record
     function CreateDataSet(obj : TObject) : TClientDataSet;
     function AddRecord(cds : TClientDataSet; obj : TObject) : Boolean;
  End;


implementation

uses
 Rtti,TypInfo, DB, SysUtils;
{ DataSetFactory }

function DataSetOperator.AddRecord(cds: TClientDataSet; obj: TObject): Boolean;
var
 ctx    : TRttiContext;
 rtp    : TRttiProperty;
 rtps   : TArray;
begin

 ctx := TRttiContext.Create;

 rtps := ctx.FindType(obj.UnitName + '.' + obj.ClassName).GetProperties;
  cds.Append;
 for rtp in rtps do
 begin
   cds.FieldByName(rtp.Name).Value := rtp.GetValue(obj).AsVariant;
 end;
  cds.UpdateRecord;
end;

function DataSetOperator.CreateDataSet(obj: TObject): TClientDataSet;
var
 ctx    : TRttiContext;
 rtp    : TRttiProperty;
 rtps   : TArray;
 cds    : TClientDataSet;
 ft     : TFieldType;
  fn     : String;
  ftSize : Integer;
  //ftdf : TFieldDef;
begin

 cds := TClientDataSet.Create(nil);

 ctx := TRttiContext.Create;

 rtps := ctx.FindType(obj.UnitName + '.' + obj.ClassName).GetProperties;

 for rtp in rtps do
 begin
   //ここがちょっとダサイかも
     //DelphiのRTTIの型とDBの型のマッチング
     ftSize := 0;
     if CompareText(rtp.PropertyType.Name,'Integer') = 0 then ft := ftInteger;
     if CompareText(rtp.PropertyType.Name,'String')  = 0 then
     begin
    ft := ftString;
        ftSize := 50;
     end;
     if CompareText(rtp.PropertyType.Name,'TDateTime') = 0 then ft := ftDateTime;
     if CompareText(rtp.PropertyType.Name,'Currency') = 0 then ft := ftCurrency;
     //if CompareText(rtp.PropertyType.Name,'Currency') = 0 then ft := ftCurrency;

     cds.FieldDefs.Add(rtp.Name,ft,ftSize);

 end;
  cds.CreateDataSet;
  Result := cds;
  //cds.FieldDefs.Add();

end;

end.

DBのデータ型の列挙とRTTIのデータ型の列挙が微妙に違っているので
そのマッピングを少々強引に行ってます。

で、上のユニットを利用する例が

unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

uses Unit2, Unit3,DBClient;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
 Emp : TEmployee;
   DF  : DataSetOperator;
   cds : TClientDataSet;
begin

 Emp := TEmployee.Create;

   cds := DF.CreateDataSet(Emp);
   cds.Active := true;
 DataSource1.DataSet := cds;
   //DataSource1.DataSet.Active := true;

   Emp.EmpNo := 2;
   Emp.FirstName := 'OldTPFun';
   Emp.LastName := 'Delphi';
   Emp.HireDate := StrToDate('2009/10/07');
   Emp.Salary := 100000.00;
   DF.AddRecord(cds,Emp);

   Emp.Free;
end;

end.

このプログラム上で使っているEmployee型の定義は以下のとおりです。

unit Unit2;

interface

 type TEmployee = class
   private
    FEmpNo: Integer;
    FFirstName: String;
    FLastName: String;
    FHireDate: TDateTime;
    FSalary: Currency;
    procedure SetEmpNo(const Value: Integer);
    procedure SetFirstName(const Value: String);
    procedure SetLastName(const Value: String);
    procedure SetHireDate(const Value: TDateTime);
    procedure SetSalary(const Value: Currency);
   public
    property EmpNo : Integer read FEmpNo write SetEmpNo;
    property FirstName : String read FFirstName write SetFirstName;
      property LastName : String read FLastName write SetLastName;
      property HireDate : TDateTime read FHireDate write SetHireDate;
      property Salary : Currency read FSalary write SetSalary;
   end;
implementation

{ TEmployee }

procedure TEmployee.SetEmpNo(const Value: Integer);
begin
  FEmpNo := Value;
end;

procedure TEmployee.SetFirstName(const Value: String);
begin
  FFirstName := Value;
end;

procedure TEmployee.SetHireDate(const Value: TDateTime);
begin
  FHireDate := Value;
end;

procedure TEmployee.SetLastName(const Value: String);
begin
  FLastName := Value;
end;

procedure TEmployee.SetSalary(const Value: Currency);
begin
  FSalary := Value;
end;

end.

TValue型を試してみる

Rttiユニットで新たに定義されたTValue型は、汎用に使えるデータ型に
なっていて、Delphiで使う基本的な型は、Implicit演算子が定義されており
代入可能になっている。

で、実験してみた。以下ソースコード

program Project1;
{$APPTYPE CONSOLE}

uses
  SysUtils,
  rtti,
  typinfo;

var
  tv: TValue;
  obj: TObject;
  intary: Array of TValue;

begin
  try
      { TODO -oUser -cConsole Main : ここにコードを記述してください }
      // 先ずは何も入れない場合
      if tv.IsEmpty then
      begin
          writeln('TValueはからです');
      end;

      tv := 100;
      writeln('TValueは' + tv.TypeInfo.Name + 'です。');

      tv := 100.0;
      writeln('TValueは' + tv.TypeInfo.Name + 'です。');

      tv := 'saka';

      writeln('TValueは' + tv.TypeInfo.Name + 'です。');

      obj := TObject.Create;
      tv := obj;
      writeln('TValueは' + tv.TypeInfo.Name + 'です。');

      tv := obj.ClassType;
      writeln('TValueは' + tv.TypeInfo.Name + 'です。');

      obj.Free;

end.

で実行した様子が下図。

Rttiを試してみるその４

以前のポストで、可視性がPrivateのメソッドは、読めないということを
記述しましたが、実際には、

自分で定義したメソッドであれば

コンパイラ指定{$RTTI EXPLICIT METHODS}で
TRttiContextのGetMehtodで列挙する可視性を制御することが可能のようです。

{$RTTI EXPLICIT METHODS([vcPublished,vcPublic,vcProtected,vcPrivate])}

とすれば、すべての可視性の列挙が可能です。（正し、継承元のメソッドには
可視性の制御は及ばない見たいです。）

また、

{$RTTI EXPLICIT METHODS([vcPrivate])}

とすれば、Private可視性のメソッドの列挙が可能です。

以下、検証ように使ったソースです。

unit Unit1;

interface

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

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

var
 Form1: TForm1;

implementation

uses Rtti,Typinfo,Unit2;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
 ctx : TRttiContext;
 rtmary : TArray;
 rtm : TRttiMethod;
 obj : TObject;
 Args : Array of TValue;
 rtp : TRttiType;
 idx : Integer;
begin

 ctx := TRttiContext.Create;

 //自分で定義したメソッドのみを取得するには、
 //GetDeclaredMethodsを使います。
 rtmary := ctx.GetType(Unit2.TSakaTest).GetDeclaredMethods;
 //rtmary := ctx.GetType(Unit2.TSakaTest).GetMethods();

 CheckListBox1.Clear;

 if rtmary <> nil then
 begin
   for rtm in rtmary do
   begin
     idx := CheckListBox1.Items.Add(rtm.Name);
     if rtm.Visibility = TMemberVisibility.mvPrivate then
     begin
         CheckListBox1.Checked[idx] := true;
     end;

   end;

 end;

end;

end.

unit Unit2;
interface

   uses classes;

//   {$RTTI EXPLICIT METHODS([vcPublished,vcPublic,vcPrivate])}
  {$RTTI EXPLICIT METHODS([vcPrivate])}
  Type TSakaTest = Class(TObject)
      private
         function SayPrivateMessage : String;
     public
         function SayPublicMessage : String;
  End;

implementation

{ TSakaTest }

function TSakaTest.SayPrivateMessage: String;
begin
  Result := 'This is a Private Method';
end;

function TSakaTest.SayPublicMessage: String;
begin
  Result := 'This is a Public Method';
end;

end.

Rttiを試してみるその３

文字列で指定したクラスのインスタンスを作成する例を作ってみました。
(Button3Click）
試行錯誤のうえで作成したソースなので、とりあえず動きましたが
正しいソースかどうかは、分かりません。もっと良い方法が
あれば教えて下さい。

この手の処理はActivatorクラスのある.Netのほうが簡単だと
思います。

unit Unit1;

interface

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

type
  TForm2 = class(TForm)
    Button3: TButton;
    LabeledEdit1: TLabeledEdit;
    ListBox1: TListBox;
    Button1: TButton;
    Label1: TLabel;
    procedure Button3Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  protected
  public
    { Public 宣言 }

  end;

var
  Form1: TForm2;
implementation
uses
  Rtti,TypInfo;

{$R *.dfm}


procedure TForm2.Button1Click(Sender: TObject);
var
  LContext: TRttiContext;
  LType: TRttiType;
  LTypes:TArray;

begin

 LoadPackage('SakaPack.bpl');

  { Obtain the RTTI context }
  LContext := TRttiContext.Create;

  { Obtain the second package (rtl140) }
  LTypes := LContext.GetTypes();

  { Enumerate all types in the rtl140 package }

   //for LPackage in LPackages do
 //begin
      for LType in LTypes do
      begin
         ListBox1.Items.Add(LType.QualifiedName);
      end;
   //end;
   ListBox1.Items.SaveToFile('P.Txt');

end;

procedure TForm2.Button3Click(Sender: TObject);
var
 ctx : TRttiContext;
 rtm : TRttiMethod;
 rst : TValue;
 SakaInf : ISakaTest;
   rtt : TRttiType;
   Args : Array of TValue;


begin

   //とりあえず別パッケージで動的ロード化とする
   LoadPackage('SakaPack.bpl');

 ctx := TRttiContext.Create;

   //文字列で型情報を探す場合は、FindTypeを使う
   //完全一致なのでユニット名を含めて指定
   rtt := ctx.FindType('Unit2.' + LabeledEdit1.Text);

   //コンストラクタはとりあえずCreateであることが前提
   rtm := rtt.GetMethod('Create');

 if rtm <> nil then
 begin
      if rtm.IsConstructor then
      begin
         //1. クラスの場合は、TRttiInstanceTypeで戻ってくるのでキャスト
         //2. MetaaclassTypeプロパティで実際のクラスがとれるみたい。
         rst := rtm.Invoke(TRttiInstanceType(rtt).MetaclassType,Args);
         if rst.IsObject Then
         begin
            SakaInf := TSakaTest(rst.AsObject) As ISakaTest;
            Label1.Caption := SakaInf.SayMessage();
         end;
            //Label1.Caption := obj.ClassName;
      end;
   end;


end;

end.

でUnit2で使ったソースがこちら

unit Unit2;

interface
 uses classes;

   {$RTTI EXPLICIT METHODS([vcPublic])}
 Type ISakaTest = interface(IInterface)
  ['{FAAA20A5-E078-4E22-96C2-139E7E57CBFB}']
  function SayMessage : String;
 end;

   {$RTTI EXPLICIT METHODS([vcPublished,vcPublic])}
   Type TSakaTest = Class(TInterfacedPersistent, ISakaTest)
    function SayMessage : String; virtual;
   End;

   {$RTTI EXPLICIT METHODS([vcPublished,vcPublic])}
 Type TSakaTest1 = Class(TSakaTest)
      Public
       function  SayMessage : String; override;
   End;

   {$RTTI EXPLICIT METHODS([vcPublished,vcPublic])}
 Type TSakaTest2 = Class(TSakaTest)
    Public
      function  SayMessage : String; override;
   End;

var
  SakaTest : ISakaTest;

implementation

//uses
 //Classes;



{ TSakaTest1 }

function TSakaTest1.SayMessage: String;
begin
 Result := 'Hello Delphi First';
end;

{ TSakaTest2 }

function TSakaTest2.SayMessage: String;
begin
 Result := 'Hello Delphi Second';
end;

{ TSakaTset }

function TSakaTest.SayMessage: String;
begin
 Result := '';
end;

initialization
   RegisterClass(TSakaTest);
   RegisterClass(TSakaTest1);
   RegisterClass(TSakaTest2);

end.

Rttiを試して見るその２

前回のポストに引き続いて、メソッドの動的呼び出し。

整数の足し算を行う例です。以下ソース

unit Unit1;

interface

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

type
 TForm1 = class(TForm)
   Button3: TButton;
   LabeledEdita: TLabeledEdit;
   Label1: TLabel;
   LabeledEditb: TLabeledEdit;
   Label2: TLabel;
   LabelResult: TLabel;
   procedure Button3Click(Sender: TObject);
 private
   { Private 宣言 }
 protected
 public
   { Public 宣言 }
   function Sakasum(a,b : Integer) : Integer;

 end;

var
 Form1: TForm1;

implementation
uses
 Rtti,TypInfo;

{$R *.dfm}


procedure TForm1.Button3Click(Sender: TObject);
var
 ctx : TRttiContext;
 rtm : TRttiMethod;
 Args : Array of Rtti.TValue;
 rst : TValue;
begin
 //
 ctx := TRttiContext.Create;
 rtm := ctx.GetType(Self.ClassType).GetMethod('SakaSum');

 if rtm <> nil then
 begin
   SetLength(Args,2);
   //TValueは、演算子Implicitが定義されているので基本的な型は
   //変換による代入が可能
   Args[0] := StrToInt(LabeledEdita.Text);
   Args[1] := StrToInt(LabeledEditb.Text);
   rst := rtm.Invoke(Self,Args);
   //結果はAsXXXXX関数を使って取り出せる。
   Self.LabelResult.Caption := IntToStr(rst.AsInteger);
 end;
end;


function TForm1.Sakasum(a, b: Integer): Integer;
begin
 Result := a + b;
end;

end.

TValueの使い方が分からなくて結構悩みました。

で、ソースをみたら基本的な型については、
Implicit演算子のオーバーロードが
定義されているのね。

このへんはHelpに書いといて欲しかったです。
(C++ のHELPには書いてあります。）

（英語版のDoc Wikiがメンテナンス中だったので
日本語版でのみ書いていないのかはちょっと不明です。）

また、こちらにDelphi Prismで上記と同様な処理を
記述しました。

Rttiを試して見る

動的にメソッドを読み出す簡単なプログラムを作ってみました。
プログラムそのものには意味はありません。

プレビュー会に説明があったようにprivateなメソッドは読めませんでした。
メソッドの可視属性を示す型があったので読めてもよいと思ったのですが・・・

また、GetDeclaredMethodsをつかうと自分が宣言したメソッドのみ
リストできます。

以下ソースです。

unit Unit1;

interface

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

type
 TForm1 = class(TForm)
   Button1: TButton;
   LabeledEdit1: TLabeledEdit;
   Button2: TButton;
   ListBox1: TListBox;
   procedure Button1Click(Sender: TObject);
   procedure Button2Click(Sender: TObject);
 private
   { Private 宣言 }
   //procedure SakaTest2;
 protected
   //procedure SakaTest1;
   procedure SakaTest2;
 public
   { Public 宣言 }
   procedure SakaTest2;
   procedure SakaTest1;
 end;

var
 Form1: TForm1;

implementation
uses
 Rtti,TypInfo;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
 ctx : TRttiContext;
 rtm : Rtti.TRttiMethod;
 obj : TObject;
 Args : Array of TValue;
begin
 //
 ctx := TRttiContext.Create;


 //rtm := ctx.GetType(obj).GetMethod(LabeledEdit1.Text);

 rtm := ctx.GetType(Self.ClassType).GetMethod(LabeledEdit1.Text);

 if rtm <> nil then
 begin
   //obj := Self;
   rtm.Invoke(Self,Args);
 end;

end;

procedure TForm1.Button2Click(Sender: TObject);
var
 ctx : TRttiContext;
 rtmary : TArray;
 rtm : TRttiMethod;
 obj : TObject;
 Args : Array of TValue;
 rtp : TRttiType;
begin

 ctx := TRttiContext.Create;

 //rtm := ctx.GetType(obj).GetMethod(LabeledEdit1.Text);
 //ctx.FindType()
 //rtp := ctx.GetType(Self.ClassType);
 //rtp.IsPublicType := false;

 rtmary := ctx.GetType(Self.ClassType).GetDeclaredMethods;

 ListBox1.Clear;

 if rtmary <> nil then
 begin
   for rtm in rtmary do
   begin
     ListBox1.Items.Add(rtm.Name);
     if rtm.Name = LabeledEdit1.Text then
     begin
       rtm.Invoke(Self,Args);
     end;

   end;

 end;

end;

procedure TForm1.SakaTest1;
begin
 Application.MessageBox('Hello Delphi','First Text');
end;

procedure TForm1.SakaTest2;
begin
 Application.MessageBox('Hello Delphi','Second Text');
end;

end.

引数つきのメソッドコールはまた次回

IDEの配置（その１)

上の図は、自分のIDEの配置です。
Visual Studioでオブジェクトインスペクタが右にあるのに
なれちゃったのでオブジェクトインスペクタは右側に
配置しています。

また、ツールパレットなど、構造ペインなども右側に
持っています。

これは、自分が右利きだからです。

意外に便利な配置なので、右利きの人は
良かったら試して下さい。

Pascal Scriptを使ってみた

Delphi Prismの関係でRemObjectsのWEBサイトを見たところPascal Scriptが
Freeと書いてあったのインストール。

Delphi2009にインストールしてみたけど、コンパイルエラーが・・・
内容を良く調べてみるとUnicode化に伴うエラーコードっぽい。

自分の手ではちょっと直しようがないので（パーサー周りポインターが
多くなるのでちょっとつらいかな？）とりあえずDelphi 2007で試用

サンプルは右図のメモにコードを入力して、結果をラベルに表示する簡単なものです。

ソースコードは、こんな感じ。

unit Unit1;

interface

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

type
TForm1 = class(TForm)
  Memo1: TMemo;
  Button1: TButton;
  Label1: TLabel;
  PSScript1: TPSScript;
  procedure Button1Click(Sender: TObject);
  procedure PSScript1Compile(Sender: TPSScript);
private
  { Private declarations }
  procedure DsWrite(s: string);
public
  { Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
Self.PSScript1.Script.Assign(Self.Memo1.Lines);
Self.PSScript1.Compile;
Self.PSScript1.Execute;
end;

procedure TForm1.DsWrite(s: string);
begin
Label1.Caption := s;
end;

procedure TForm1.PSScript1Compile(Sender: TPSScript);
begin
  Sender.AddMethod(Self,@TForm1.DsWrite, 'procedure Writeln(s: string);');
end;

end.

Pascal ScriptのコンパイラとDelphiのコードを結びつけることができるので
以外に応用範囲が広いかも・・・・

また、上の例ではやってないが、Pascal Scriptでコンパイル済みのストリーム
データの読み書きもできるので、自作のアプリケーションにちょっとした演算を
組み込むには便利かも？

もうちょっと深く突っ込んでみよう。

Delphi Success Stories

Nick HodgesがBolgでDelphi Success Storiesを募集しています。
これって、CodeGear Japan経由でも遅れるのかな？

IDEのショートカット

Rad Studio 2007のIDEのDeafultのキーバインドを使用の場合
Ctrlキーを押しながら→キーを押す(移行[CTRL+→]のように記述）と
一語進みます。反対に[CTRL+←]で一語戻ります。

これらのショートカットキーを使用した場合、必ず行頭と行末に
一度カーソルがとまります。また行を超えて移動しますので
行間を移動する場合は次の動きになります。

行末で[CTRL+→]…次の行の行頭に移動します。
行頭で[CTRL+←]…前の行の行末に移動します。
(下図を参照）

文字列から数値への変換

Delphiでは、文字列から数値への変換に以下の３種類の関数があります。

(1) StrToXXX
(2) StrToXXXDef
(3) TryStrToXXX

(XXXは、変換後の型です。）

(1)は、変換できない場合、EConvertErrorの例外が発生します。
(2)は、変換できない場合、第2引数Defaultに指定した値を返します。
(3)は、戻り値がBoolean型で、変換できた場合はTrue,できなかった場合はFalseが帰ります。
　　　 変換結果は、out指定の第2引数に格納されます。

使いわけは、場合・場合によって違いますが、自分は以下の使いわけをしています。

基本は、(3)を使用。
但し、例外が発生しないことがわかっている場合　(1)を使用。

(2)を使用する場合はほどんどないです。