2018年5月19日土曜日

TokyoでDictionaryを要素にもつJson形式のファイルの読み書きをしてみた。

前回、LIST構造を持つJSON形式のファイルを読み書きしたので、今回はDictionary構造を持つファイルを読み書きしてみた。
(プロジェクトは、https://bitbucket.org/OldTPFun/delphitest/src/master/JsonTest/Proj2/ に配置してあります。)

今回読み書きするのは以下のようなファイル。

{"TownName":"木組みの家と石畳の街",
    "Shops":{
        "ラビットハウス":
            {"ShopName":"ラビットハウス",
                "Clerks":[
                    {"Name":"ココア","Age":17},
                    {"Name":"チノ","Age":15},
                    {"Name":"リゼ","Age":17}
                ]      
            },
        "甘兎庵":
            {"ShopName":"甘兎庵",
                "Clerks":[
                    {"Name":"チヤ","Age":17}
                ]
            }
    }
}


先ずは書き込みから。

今回は、Keyが文字列で、ValueがTCoffeeShop型のTDictionaryをシリアライズ・デシリアライズすればよいので、前回にならって、TDictionary用のコンバータ

  TCoffieShopDicConverter = class(TJsonDictionaryConverter<string, TCoffeeShop>);

を作成して、上記のJSON文字列にシリアライズするためのクラスを作成して、TDictionary型の変数にTCoffieShopDicConverter属性を設定

  [JsonSerialize(TJsonMemberSerialization.&Public)]
  TCofeeShopList = class
  private
    FTownName: String;
    FShops: TObjectDictionary<string, TCoffeeShop>;
    procedure SetTownName(const Value: String);
    procedure SetShops(const Value: TObjectDictionary<string, TCoffeeShop>);
    public
      property TownName : String read FTownName write SetTownName;
      [JsonConverter(TCoffieShopDicConverter)]
      property Shops : TObjectDictionary<string, TCoffeeShop> read FShops write SetShops;
      constructor Create;
  end;

で、シリアライズするためのコード

procedure TForm1.Button1Click(Sender: TObject);
var
  CoffeeShop1,CoffeeShop2 : TCoffeeShop;
  serializer: TJsonSerializer;
  CofeeShopList : TCofeeShopList;
  s : string;
begin
  CofeeShopList := TCofeeShopList.Create;
  CoffeeShop1 := TCoffeeShop.Create;
  CoffeeShop2 := TCoffeeShop.Create;
  try
    CoffeeShop1.ShopName := 'ラビットハウス';
    CoffeeShop1.Clerks.Add(TClerk.Create('ココア',17));
    CoffeeShop1.Clerks.Add(TClerk.Create('チノ',15));
    CoffeeShop1.Clerks.Add(TClerk.Create('リゼ',17));

    CoffeeShop2.ShopName := '甘兎庵';
    CoffeeShop2.Clerks.Add(TClerk.Create('チヤ',17));

    CofeeShopList.TownName := '木組みの家と石畳の街';
    CofeeShopList.Shops.Add(CoffeeShop1.ShopName,CoffeeShop1);
    CofeeShopList.Shops.Add(CoffeeShop2.ShopName,CoffeeShop2);

    serializer := TJsonSerializer.Create;
    try

      s := serializer.Serialize(CofeeShopList);
      Memo1.Text := s;

      TFile.WriteAllText('CoffeeShop.Json',s);

    finally
      serializer.Free;
    end;

  finally
    CofeeShopList.Shops.Clear;
    CofeeShopList.Free;
  end;
end;

を書いて実行すると、見事に成功と思いきや・・・・

例外クラスEAbstractError (メッセージ'抽象エラー')を送出しました。

と例外が発生。ありゃりゃ。

デバッグ実行した結果、PropertyToKeyの呼び出し時に例外が発生していることが分かったので、System.JSON.Converters.pasのTJsonDictionaryConverter<k,v>の定義を調べてみると、
TJsonDictionaryConverter<k,v> = class(TJsonConverter)
  protected
    function CreateDictionary: TDictionary<k,v>; virtual;
    function PropertyToKey(const APropertyName: string): K; virtual; abstract;
    function KeyToProperty(const AKey: K): string; virtual; abstract;
    function ReadKey(const AReader: TJsonReader; const ASerializer: TJsonSerializer): string;
    function ReadValue(const AReader: TJsonReader; const ASerializer: TJsonSerializer): V; virtual;
    procedure WriteValue(const AWriter: TJsonWriter; const AValue: V; const ASerializer: TJsonSerializer); virtual;
  public
    procedure WriteJson(const AWriter: TJsonWriter; const AValue: TValue; const ASerializer: TJsonSerializer); override;
    function ReadJson(const AReader: TJsonReader; ATypeInf: PTypeInfo; const AExistingValue: TValue;
      const ASerializer: TJsonSerializer): TValue; override;
    function CanConvert(ATypeInf: PTypeInfo): Boolean; override;
  end;

と、PropertyToKey,とKeyToPropertyにabstractがついているので、この2つは、継承先のコンバーターで実装しないといけなかったのね。

System.JSON.Converters.pasに、TJsonDictionaryConverterを継承した、キーが文字列のTJsonStringDictionaryConverter<V>の定義が あるので、中身をみてみると、

  TJsonStringDictionaryConverter<V> = class(TJsonDictionaryConverter<string, V>)
  protected
    function PropertyToKey(const APropertyName: string): string; override;
    function KeyToProperty(const AKey: string): string; override;
  end;

とあって、実装が

function TJsonStringDictionaryConverter<V>.KeyToProperty(const AKey: string): string;
begin
  Result := AKey;
end;

function TJsonStringDictionaryConverter<V>.PropertyToKey(const APropertyName: string): string;
begin
  Result := APropertyName;
end;

となっているので、Dictionaryのコンバーターを作成する時は、TJsonDictionaryConverterから、キーの型を決めた派生型を作成し、KeyToPropertyにはキーから文字列に変換、PropertyToKeyには文字列からキーの型のインスタンスへの変換を自前で実装すれば、良いわけですね。
例えば、キーが整数型のDictionaryのコンバータは

  TJsonIntegerDictionaryConverter<V> = class(TJsonDictionaryConverter<Integer, V>)
  protected
    function PropertyToKey(const APropertyName: string): Integer; override;
    function KeyToProperty(const AKey: Integer): string; override;
  end;

function TJsonStringDictionaryConverter<V>.KeyToProperty(const AKey: Integer): string;
begin
  Result := AKey.ToString;
end;

function TJsonStringDictionaryConverter<V>.PropertyToKey(const APropertyName: string): Integer;
begin
  Result := APropertyName.ToInteger;
end;

とすれば、良いわけだ。

今回は、定義済みの、TJsonStringDictionaryConverterを使用して先ほどの

  TCoffieShopDicConverter = class(TJsonDictionaryConverter<string, TCoffeeShop>);


  TCoffieShopDicConverter = class(TJsonStringDictionaryConverter<TCoffeeShop>);

に修正し実行すれば、目的のJSON形式の文字列のファイルが作成できます。

ファイルの読み込みは前回と同様、次のコードになります。(確認用に読み込んだものメモに列挙しております。)

procedure TForm1.Button2Click(Sender: TObject);
var
  CoffeeShop : TCoffeeShop;
  CofeeShopList : TCofeeShopList;
  serializer: TJsonSerializer;
  s : string;
  Clerk : TClerk;
begin

  s := TFile.ReadAllText('CoffeeShop.Json',TEncoding.UTF8);

  serializer := TJsonSerializer.Create;
  try
    CofeeShopList := serializer.Deserialize<tcofeeshoplist>(s);
    try
      Memo1.Clear;
      Memo1.Lines.Add(CofeeShopList.TownName);
      for CoffeeShop in CofeeShopList.Shops.Values do
      begin
        Memo1.Lines.Add(CoffeeShop.ShopName);
        for Clerk in CoffeeShop.Clerks do
          begin
          Memo1.Lines.Add(Clerk.Name + '(' + Clerk.Age.ToString() + ')');
        end;
      end;

    finally
      CoffeeShop.Clerks.Clear();
      CoffeeShop.Free;
    end;
  finally
    serializer.Free
  end;

2018年5月3日木曜日

TokyoでJson形式のファイルの読み書きをして見た。

唐突ですが、Json.NET良いですよね。高度なこともできますが、Json形式の文字列のシリアル化/デシリアライズ化がだけで良いな簡単にできますしね。
Delphi(Tokyo)でJson形式のファイルを読み込む必要が出てきたので、Json.NETのような書き方ができなか調べていたところもう1年くらい前の記事になりますが、

@lynatan さんのTJsonSerializerの記事

TJsonSerializerの使い方。
TJsonSerializerの実用例

エンバカデロさんのブログ

TJsonSerializerでJSONに変換する[JAPAN]

DelphiでもTokyoになって、Json.NETのような書き方ができるようになっているとのことでしたので、試して見ました。

読み書きするのは、以下のような内容のファイル

{"ShopName":"ラビットハウス",
  "Clerks":[
    {"Name":"ココア","Age":17},
    {"Name":"チノ","Age":15},
    {"Name":"リゼ","Age":17}
  ]
}

上記の構造にマップできるクラスを作成します。
先ずは、従業員(Clerk)クラス。
パブリックメンバーをシリアライズ対象のするのでクラスに[JsonSerialize(TJsonMemberSerialization.&Public)]
属性を付加しています。
(余談ですが、予約語、指令と被るワードを使う場合、その前に"&"が必要です。)

unit Unit1;
  //パブリックメンバーをシリアライズ対象にする属性
  [JsonSerialize(TJsonMemberSerialization.&Public)]
  TClerk = class
    private
      FName: string;
      FAge: integer;

      procedure SetAge(const Value: integer);
      procedure SetName(const Value: string);
    public
      property Name : string read FName write SetName;
      property Age : integer read FAge write SetAge;
      constructor Create; overload;
      constructor Create(const vName : string; const vAge : integer); overload;
  end;

次に喫茶店(CoffeeShop)クラスの定義
  [JsonSerialize(TJsonMemberSerialization.&Public)]
  TCoffeeShop = class
    private
    FClerks: TList<TClerk>;
    FShopName: string;
    procedure SetClerks(const Value: TList<TClerk>);
    procedure SetShopName(const Value: string);
    public
      property ShopName : string read FShopName write SetShopName;
      
      //TClerkクラスのジェネリックリスト用のコンバーターを登録
      [JsonConverter(TJsonClerkListConverter)]
      property Clerks : TList<TClerk> read FClerks write SetClerks;

      public constructor Create;
  end;

メンバーは、喫茶店名と、従業員のリスト(ジェネリックのリスト)です。
こちらも、パブリックメンバーをシリアル化の対象とします。
ジェネリックのリストは、そのままではシリアライズできないので、Json.Converterユニットに定義済みの TJsonListConverterからTClerk型用の派生クラス

  //TClerk型のリスト用のコンバーター
  TJsonClerkListConverter = class(TJsonListConverter<TClerk>);

を作成し、TClerk型のジェネリックリスト型のメンバーClerks用のコンバーター属性を付加しています。

クラス定義の全体は、以下とおりです。
unit Unit2;

interface
uses
  //Json.SerializersとConverterを使用する。
    System.JSON.Serializers
  , System.JSON.Converters
  //TList<t>を使用する
  , System.Generics.Collections
  ;

type

  //パブリックメンバーをシリアライズ対象にする属性
  [JsonSerialize(TJsonMemberSerialization.&Public)]
  TClerk = class
    private
      FName: string;
      FAge: integer;

      procedure SetAge(const Value: integer);
      procedure SetName(const Value: string);
    public
      property Name : string read FName write SetName;
      property Age : integer read FAge write SetAge;
      constructor Create; overload;
      constructor Create(const vName : string; const vAge : integer); overload;
  end;

  //TClerk型のリスト用のコンバーター
  TJsonClerkListConverter = class(TJsonListConverter<TClerk>;);

  [JsonSerialize(TJsonMemberSerialization.&Public)]
  TCoffeeShop = class
    private
    FClerks: TList<TClerk>;
    FShopName: string;
    procedure SetClerks(const Value: TList<TClerk>);
    procedure SetShopName(const Value: string);
    public
      property ShopName : string read FShopName write SetShopName;
      
      //TClerkクラスのジェネリックリスト用のコンバーターを登録
      [JsonConverter(TJsonClerkListConverter)]
      property Clerks : TList<TClerk> read FClerks write SetClerks;

      public constructor Create;
  end;
implementation

{ TClerk }

constructor TClerk.Create(const vName: string; const vAge: integer);
begin
   FName := vName;
   FAge := vAge;
end;

constructor TClerk.Create;
begin

end;

procedure TClerk.SetAge(const Value: integer);
begin
  FAge := Value;
end;

procedure TClerk.SetName(const Value: string);
begin
  FName := Value;
end;

{ TCoffeeShop }

constructor TCoffeeShop.Create;
begin
  FClerks := TList<TClerk>.Create;
end;

procedure TCoffeeShop.SetClerks(const Value: TList<TClerk>);
begin
  FClerks := Value;
end;

procedure TCoffeeShop.SetShopName(const Value: string);
begin
  FShopName := Value;
end;

end.

上記で定義したクラスに対で、冒頭で示した内容のJson形式の定義ファイルCoffeeShop.Jsonを読み込み、デシリアライズする処理は、以下のとおりとなります。

procedure TForm1.Button2Click(Sender: TObject);
var
  CoffeeShop : TCoffeeShop;
  serializer: TJsonSerializer;
  s : string;
  Clerk : TClerk;
begin

  s := TFile.ReadAllText('CoffeeShop.Json',TEncoding.UTF8);

  serializer := TJsonSerializer.Create;
  try
    CoffeeShop := serializer.Deserialize<TCoffeeShop>(s);
    try
      Memo1.Clear;
      Memo1.Lines.Add(CoffeeShop.ShopName);
      for Clerk in CoffeeShop.Clerks do
      begin
        Memo1.Lines.Add(Clerk.Name + '(' + Clerk.Age.ToString() + ')');
      end;
    finally
      CoffeeShop.Clerks.Clear();
      CoffeeShop.Free;
    end;
  finally
    serializer.Free
  end;

ファイルを読み込み、シリアライザーを生成し、読み込んだJson文字列をデシリアライズして、ショップ名と、店員の情報をメモに表示しています。 (余談ですが、クラス定義で属性を使用しないで、TJsonSerializerインスタンスのConverterリストにTJsonClerkListConverterのインスタンスを登録してもデシリアライズできます。)

冒頭で示した内容のJson形式の定義ファイルを作成する場合は、以下の処理でできます。

procedure TForm1.Button1Click(Sender: TObject);
var
  CoffeeShop : TCoffeeShop;
  serializer: TJsonSerializer;
  s : string;


begin
  CoffeeShop := TCoffeeShop.Create;
  try
    CoffeeShop.ShopName := 'ラビットハウス';
    CoffeeShop.Clerks.Add(TClerk.Create('ココア',17));
    CoffeeShop.Clerks.Add(TClerk.Create('チノ',15));
    CoffeeShop.Clerks.Add(TClerk.Create('リゼ',17));

    serializer := TJsonSerializer.Create;
    try

      s := serializer.Serialize(CoffeeShop);
      Memo1.Text := s;

      TFile.WriteAllText('CoffeeShop.Json',s);

    finally
      serializer.Free;
    end;

  finally
    CoffeeShop.Clerks.Clear();
    CoffeeShop.Free;
  end;
end;

TCoffeeShop型のインスタンスを生成し、メンバーを設定後、シリアライザーを生成しシリアライズ後、ファイルに保存しています。
(確認の為、画面上のメモにも表示しています。)


プロジェクト一式は、https://bitbucket.org/OldTPFun/delphitest/src/master/JsonTest/Proj1/
に配置しております。

2014年1月25日土曜日

GExpertsのMove to Matching Delimiter 機能

数日前、@_fm2さんが、ツイッターで

"DelphiのIDEで  begin 対する end を検索する、ショートカットなんぞはありませんか?"

とのつぶやかれてまた。

これ、IDEの標準機能では、出来なさそうだけど、GExperts のEditor Exports機能で
できます。

GExperts自体は、有名なツールなので、ご存知の方も多いと思います。

先ずは、GExpertsのインストール。

XE4までは、GExperts のサイトにインストーラがあるので、インストラーを使って
セットアップできます。

XE5は、残念ながら、インストーラがないので手動インストールが必要です。
インストール方法は、以下のとおりです。(Delphi XE5が必要です。)

1) SourceForgeのリポジトリからソースを入手します。

2) XE5用のプロジェクトを開きビルドします。
    ビルドすると、GExpertsRSXE5.dllができます。

3) レジストリ登録を行います。
 レジストリエディターで、

 HKEY_CURRENT_USER\Software\Embarcadero\BDS\12.0\Experts\

 に、文字列キーGExpertsを作成し、値にGExpertsRSXE5.dllをフルパスで
 設定します。

インストールに成功すれば、Delphi ( RadStudio )を起動するとメニューに
GExpertsが表示されます。

この状態で、Delphiのソースコードを開き"begin"のところにカーソルをあてて
[CTRL] + [ALT] + [右矢印キー]を押すと、対応する"end"に移動します。
この位置で、もう一回[CTRL] + [ALT] + [右矢印キー]を押すと、"begin"に
戻ります。(このショートカットキーは変更可能です。)

GExpertsのメニューから、Configurationを選択し、設定用のダイアログを開き、
Editor Expertsタブを選択し、Move to Matching Delimiterのところにカーソルを
あてると、機能の説明が確認できます。
説明には、

"  This expert enables you to quickly move to a matching beginning/ending delimiter for the following Delphi tokens: begin, try, case, repeat, for, with, while, asm, do, if, then, else, class, record, array, interface, implementation, uses, private, protected, public, published, until, end, try, finally, except, (/), and [/], .
  It also supports the following C++ tokens: {/}, (/), and [/]
The following steps are taken to match delimiters:
 - Beginning at the current cursor position, the expert looks to the left on the current line for a delimiter token such as "begin".
 - If a delimiter token is found, the expert scans for the matching token, such as "end" in the above instance.
 - If no delimiter is found to the left, as in the case "if|(i=0)" (where '|' represents the cursor), the expert attempts to find a delimiter token to the right of the current cursor position. In the mentioned example, this will identify the opening parenthesis, and an attempt is made to locate the closing parenthesis. "

とありますので、指定したトークンとペアになるトークンがあれば、その位置に
移動するようです。

試しに、try 〜 finally 〜 end で試した場合、finallyの位置でこの機能を使用した
場合の移動先は状況に依存するようでした。
(tryからはfinallyに、endからはfinallyにそれぞれ移動します。)

ソースも公開されてますので、GX_eFindDelimiter.pas等を書き換えれば
動きのカスタマイズも可能かと思います。










2012年12月13日木曜日

publishedなメソッドを隠す(ネストした型宣言使用編)

前回の続きです。

さて、最近のDelphiでは、ネストした型宣言が可能で、クラス宣言の中にクラスの宣言ができます。

この機能を使って、クラスの使用者からpublishedなメソッドを隠すことを試してみました。

以下、ソースです。

先ず、 【関数名でメソッドが呼び出されるクラスのサンプル】

unit Unit2;

interface

  type TMyCallCalc = class
    public
      function CallCalc(CalcName : string; a, b: double) : double;
    private
      type TMyCalc = class
        published
          function Add(a,b : double) : double;
          function Subtract(a,b : double) : double;
      end;

  end;


implementation
{ TMyCalc }

function TMyCallCalc.TMyCalc.Add(a, b: double): double;
begin
  Result := a + b;
end;

function TMyCallCalc.TMyCalc.Subtract(a, b: double): double;
begin
  Result := a - b;
end;


type TMyCalcFunc = function(a,b : double) : double of object;

function TMyCallCalc.CallCalc(CalcName : string; a, b: double) : double;
var
  MyCalc     : TMyCalc;
  MyCalcFunc : TMyCalcFunc;
  MethodVar : TMethod;
begin

  MyCalc := TMyCalc.Create;
  try
    MethodVar.Data := MyCalc;
    MethodVar.Code := MyCalc.MethodAddress(CalcName);


    if Assigned(MethodVar.Code) then
    begin
      MyCalcFunc := TMyCalcFunc(MethodVar);
      Result := MyCalcFunc(a,b);
    end;
  finally
    MyCalc.Free;
  end;

end;

end.

親クラスのprivateセクションにpublishedなメソッドを持つ子クラスを宣言しています。
これで、ユニットの使用者からは、子クラスのメソッドの宣言が見えなくなり、直接呼び出す
ことができなくなります。
ユニットの使用者には、publicセクションにメソッドを宣言することで、間接的に目的の
メソッドが呼び出せるようにします。

次に上記のクラスを使用するコード


unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    StaticText1: TStaticText;
    StaticText2: TStaticText;
    procedure OnCalcBtnClick(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Unit2;

procedure TForm1.OnCalcBtnClick(Sender: TObject);
var
  CallCalc : TMyCallCalc;
begin
  CallCalc := TMyCallCalc.Create;
  try
    StaticText2.Caption := FloatToStr(CallCalc.CallCalc(
                                    TButton(Sender).Caption,
                                    StrToFloat(LabeledEdit1.Text),
                                    StrToFloat(LabeledEdit2.Text)));
  finally
    CallCalc.Free;
  end;

end;

end.

ユニットを使用する側からは子クラスが見えませんので、親クラスのpublicなメソッドのみが
使用できます。



publishedなメソッドを隠す

前回の続きです。

TObjectのMethodAddressメソッドを使用すれば関数名(文字列)でメソッドをコールできます。

しかし、 MethodAddressメソッドでメソッドのアドレスを取得するには、可視性をpublishedに
する必要があり、 publishedにした瞬間にメソッドの存在が丸わかりになってしまいます。

前回の例のような単純な演算であればまあ良いかと思うのですが、いわゆるFactoryメソッド
とかだと、使用者にその存在を隠したい場合があり、このままではちょっと不完全です。

さて、どうしようか?というのが今回のテーマになります。(2010以降の拡張Rttiを使えば良い
というのはあるのですが、今回は別の方法を考えます。)

ところで、DelphiのUnitのimplementationセクションで定義した型(クラスを含む)は別のユニット
から参照できない仕様となっています。

したがって、クラスの定義を  implementation で行えば、外部から処理の存在を隠したうえで
 MethodAddressメソッド が使用可能なクラスができそうです。

で、実際に、作ってみました。

先ずは、【メソッドポインタ経由で呼び出されるクラスのサンプル】

unit Unit2;

interface

  function CallCalc(CalcName : string; a, b: double) : double;

implementation

  type TMyCalc = class
  published
    function Add(a,b : double) : double;
    function Subtract(a,b : double) : double;
  end;

  type TMyCalcFunc = function(a,b : double) : double of object;

{ TMyCalc }

function TMyCalc.Add(a, b: double): double;
begin
  Result := a + b;
end;

function TMyCalc.Subtract(a, b: double): double;
begin
  Result := a - b;
end;


function CallCalc(CalcName : string; a, b: double) : double;
var
  MyCalc     : TMyCalc;
  MyCalcFunc : TMyCalcFunc;
  MethodVar : TMethod;
begin

  MyCalc := TMyCalc.Create;
  try
    MethodVar.Data := MyCalc;
    MethodVar.Code := MyCalc.MethodAddress(CalcName);


    if Assigned(MethodVar.Code) then
    begin
      MyCalcFunc := TMyCalcFunc(MethodVar);
      Result := MyCalcFunc(a,b);
    end;
  finally
    MyCalc.Free;
  end;

end;

end.

publishedの可視性を持つクラスをimplementationセクションに定義しています。
但し、そのままでは、外部のユニットからメソッドをコールできませんので、
外部からのアクセスようにラッパー関数を定義しています。

次に、【関数名を文字列で指定して処理を呼び出すサンプル】

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    StaticText1: TStaticText;
    StaticText2: TStaticText;
    procedure OnCalcBtnClick(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Unit2;

procedure TForm1.OnCalcBtnClick(Sender: TObject);
begin
  StaticText2.Caption := FloatToStr(CallCalc(
                                    TButton(Sender).Caption,
                                    StrToFloat(LabeledEdit1.Text),
                                    StrToFloat(LabeledEdit2.Text)));
end;

end.

unit2のinterfaceセクションに定義したラッパーを使って処理を呼び出しています。


implementationセクションにクラスを定義することで、外部からその存在を隠しつつ
メソッド名を文字列で指定してメソッドをコールすることが可能です。

但し、この方法ですとクラスそのものも隠れてしまいすのでもう少しなんとかしたい
ところです。

ネストした型宣言が可能なバージョンのDelphiであれば、何とかできそうな気が
しますが、その検証はまた後日・・・

2012年12月12日水曜日

メソッドを名前で呼び出す

前回の続きです。

関数(function)のメソッドポインタが定義できれば、TObjectのMethodAddressを使って
関数名を(文字で)指定してコールすることが可能です。

以下、サンプルソース。

先ずは、【メソッドポインタ経由で呼び出されるクラスのサンプル】

unit Unit2;

interface

  type TMyCalc = class
  published
    function Add(a,b : double) : double;
    function Subtract(a,b : double) : double;
  end;

implementation

{ TMyCalc }

function TMyCalc.Add(a, b: double): double;
begin
  Result := a + b;
end;

function TMyCalc.Subtract(a, b: double): double;
begin
  Result := a - b;
end;

end.

MethodAddressを使用するためにpublishedを指定してることに注意願います。

次に、【関数名を文字列で指定して処理を呼び出すサンプル】

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    StaticText1: TStaticText;
    StaticText2: TStaticText;
    procedure OnCalcBtnClick(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Unit2;

type TMyCalcFunc = function(a,b : double) : double of object;

procedure TForm1.OnCalcBtnClick(Sender: TObject);
var
  MyCalc     : TMyCalc;
  MyCalcFunc : TMyCalcFunc;
  MethodVar : TMethod;
begin

  MyCalc := TMyCalc.Create;
  try
    MethodVar.Data := MyCalc;
    MethodVar.Code := MyCalc.MethodAddress(TButton(Sender).Caption);


    if Assigned(MethodVar.Code) then
    begin
      MyCalcFunc := TMyCalcFunc(MethodVar);
      StaticText2.Caption := FloatToStr(MyCalcFunc(StrToFloat(LabeledEdit1.Text),StrToFloat(LabeledEdit2.Text)));
    end;
  finally
    MyCalc.Free;
  end;

end;

end.

ボタンのキャプション名が名前のメソッドが定義されているという前提で、ボタンのキャプションを
使って関数をコールして、結果を求めています。


関数のメソッドポインタ

メソッドポインタでfunctionを使った例のサンプルです。
あまり見当たらなかったので、備忘録がわりに公開しときます。


【メソッドポインタ経由でfunctionを呼び出すサンプル】


unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    StaticText1: TStaticText;
    StaticText2: TStaticText;
    procedure OnCalcBtnClick(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Unit2;

type TMyCalcFunc = function(a,b : double) : double of object;

procedure TForm1.OnCalcBtnClick(Sender: TObject);
var
  MyCalc     : TMyCalc;
  MyCalcFunc : TMyCalcFunc;
  Method: TMethod;
begin

  MyCalc := TMyCalc.Create;
  try
    //Method.Data := MyCalc;
    if TButton(Sender).Caption = 'Add' then
    begin
      MyCalcFunc := MyCalc.Add;
    end
    else
    begin
      MyCalcFunc := MyCalc.Subtract;
    end;
    StaticText2.Caption := FloatToStr(MyCalcFunc(StrToFloat(LabeledEdit1.Text),StrToFloat(LabeledEdit2.Text)));
  finally
    MyCalc.Free;
  end;

end;

end.


【メソッドポインタ経由で呼び出されるクラスのサンプル】


unit Unit2;

interface

  type TMyCalc = class
    function Add(a,b : double) : double;
    function Subtract(a,b : double) : double;
  end;

implementation

{ TMyCalc }

function TMyCalc.Add(a, b: double): double;
begin
  Result := a + b;
end;

function TMyCalc.Subtract(a, b: double): double;
begin
  Result := a - b;
end;

end.


メソッドポインタはヘルプにもあるように、

Type 型名 = "メソッドの定義" of object

のように宣言します。

ここで、"メソッドの定義"は、通常の手続き(関数)の名前を抜いたものになるので、
例えば、TObject型のSenderを引数に持ち、戻り値がない"メソッドの定義"は、

procedure(Sender : TObject)

同様に、Double型のaとbを引数に持ち、Double型の戻り値がある"メソッドの定義"は

function(a,b : Double) : Double

となります。

上記のサンプル1では、ボタンのキャプションに応じてif分で関数を切り替えています。

この例では、関数が2つだけなので、メソッドポインタ経由ではなく、直接目的の関数を
コールしたほうが良いのですが、
同じ型の引数を持つ関数が多数ある場合、メソッドポインタと、TObject.MethodAddressを
組み合わるとコード量を減らせる可能性があります。(上の例だとボタンのCaptionと関数名を
合わせおくことによりif文(あるいは、Case文)を無くすことが可能です。)

そのへんの話はまた後日・・・




2012年11月10日土曜日

TZipFile.ZipDirectoryContentsのCOMラッパー

仕事で、VB6でフォルダーを圧縮する必要が出てきて、どうしようかと迷ってた時
DEKOさんが以前フォルダごと圧縮してZipファイルを作成するデモを紹介してたのを
思い出したのでCOM化してVB6,VBAから呼び出せるようにしてみた。

以下、ソース


unit DirZipImp;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, ActiveX, SimpleDirZip_TLB, StdVcl;

type
  TDirZip = class(TAutoObject, IDirZip)
  protected
    procedure Compress(const SrcDirName, ZipFileName: WideString); safecall;
    procedure Extract(const ZipFileName, DestDirName: WideString); safecall;

  end;

implementation

uses ComServ,System.Zip;

procedure TDirZip.Compress(const SrcDirName, ZipFileName: WideString);
begin
  TZipFile.ZipDirectoryContents(ZipFileName,SrcDirName);
end;

procedure TDirZip.Extract(const ZipFileName, DestDirName: WideString);
begin
  TZipFile.ExtractZipFile(ZipFileName,DestDirName);
end;

initialization
  TAutoObjectFactory.Create(ComServer, TDirZip, Class_DirZip,
    ciMultiInstance, tmApartment);
end.



Delphiが作成したタイプライブラリーは
// ************************************************************************ //
// 警告
// -------
// このファイルはタイプ ライブラリ インポータまたはタイプ ライブラリ エディタで生成されています。
// 構文エラーがない場合には、エディタはファイルへの変更を構文解析します。
// ただし、エディタで変更したときは、このファイルは再生成され、
// コメントやフォーマットの変更は失われます。
// ************************************************************************ //
// 2012/11/10 20:48:27 に生成されたファイル (- $Rev: 12980 $, 52614628)

[
  uuid(A77B985B-35E5-49A6-91CB-5BCD38D54C22),
  version(1.0)

]
library SimpleDirZip
{

  importlib("stdole2.tlb");

  interface IDirZip;
  coclass DirZip;


  [
    uuid(2CCEF7D7-0EF5-467E-BFEC-F4574049C00D),
    helpstring("DirZip Object のディスパッチ インターフェイス"),
    dual,
    oleautomation
  ]
  interface IDirZip: IDispatch
  {
    [id(0x000000C9)]
    HRESULT _stdcall Compress([in] BSTR SrcDirName, [in] BSTR ZipFileName);
    [id(0x000000CA)]
    HRESULT _stdcall Extract([in] BSTR ZipFileName, [in] BSTR DestDirName);
  };

  [
    uuid(2B59D5EC-076B-4577-8C09-F3968AEFF615),
    helpstring("DirZip Object")
  ]
  coclass DirZip
  {
    [default] interface IDirZip;
  };

};

unit SimpleDirZip_TLB;

// ************************************************************************ //
// 警告
// -------
// このファイルで宣言されている型はタイプ ライブラリから読み取られたデータから
// 生成されています。このタイプ ライブラリが明示的あるいは(このタイプ ライブラ
// リを参照しているほかのタイプ ライブラリ経由で)間接的に再インポートされた
// り、タイプ ライブライブラリの編集中にタイプ ライブラリ エディタの[更新]コマ
// ンドを実行した場合、このファイルの内容はすべて再生成され、手動で加えた変更
// はすべて失われます。
// ************************************************************************ //

// $Rev: 52393 $
// 下に説明されたタイプ ライブラリから 2012/11/10 20:48:24 に生成されたファイル。

// ************************************************************************  //
// タイプ ライブラリ: C:\Users\saka_xps\Documents\Saka_Develop\DelProj\SimpleDirZip (1)
// LIBID: {A77B985B-35E5-49A6-91CB-5BCD38D54C22}
// LCID: 0
// ヘルプファイル:
// ヘルプ文字列:
// 依存関係リスト:
//   (1) v2.0 stdole, (C:\Windows\SysWOW64\stdole2.tlb)
// SYS_KIND: SYS_WIN32
// ************************************************************************ //
{$TYPEDADDRESS OFF} // ポインタの型チェックをオフにしてコンパイルすること
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}
{$ALIGN 4}

interface

uses Winapi.Windows, System.Classes, System.Variants, System.Win.StdVCL, Vcl.Graphics, Vcl.OleServer, Winapi.ActiveX;

// *********************************************************************//
// タイプ ライブラリで宣言される GUID. 以下のプレフィックスを使う:
//   Type Libraries     : LIBID_xxxx
//   CoClasses          : CLASS_xxxx
//   DISPInterfaces     : DIID_xxxx
//   Non-DISP interfaces: IID_xxxx
// *********************************************************************//
const
  // タイプ ライブラリのメジャー バージョンとマイナー バージョン
  SimpleDirZipMajorVersion = 1;
  SimpleDirZipMinorVersion = 0;

  LIBID_SimpleDirZip: TGUID = '{A77B985B-35E5-49A6-91CB-5BCD38D54C22}';

  IID_IDirZip: TGUID = '{2CCEF7D7-0EF5-467E-BFEC-F4574049C00D}';
  CLASS_DirZip: TGUID = '{2B59D5EC-076B-4577-8C09-F3968AEFF615}';
type
// *********************************************************************//
// タイプ ライブラリで宣言される前方参照
// *********************************************************************//
  IDirZip = interface;
  IDirZipDisp = dispinterface;
// *********************************************************************//
// タイプ ライブラリで宣言される CoClass
// (注意: ここで各 CoClass とデフォルトのインターフェイスをマッピングする)
// *********************************************************************//
  DirZip = IDirZip;


// *********************************************************************//
// インターフェイス: IDirZip
// フラグ: (4416) Dual OleAutomation Dispatchable
// GUID: {2CCEF7D7-0EF5-467E-BFEC-F4574049C00D}
// *********************************************************************//
  IDirZip = interface(IDispatch)
    ['{2CCEF7D7-0EF5-467E-BFEC-F4574049C00D}']
    procedure Compress(const SrcDirName: WideString; const ZipFileName: WideString); safecall;
    procedure Extract(const ZipFileName: WideString; const DestDirName: WideString); safecall;
  end;

// *********************************************************************//
// DispIntf:  IDirZipDisp
// フラグ:     (4416) Dual OleAutomation Dispatchable
// GUID:      {2CCEF7D7-0EF5-467E-BFEC-F4574049C00D}
// *********************************************************************//
  IDirZipDisp = dispinterface
    ['{2CCEF7D7-0EF5-467E-BFEC-F4574049C00D}']
    procedure Compress(const SrcDirName: WideString; const ZipFileName: WideString); dispid 201;
    procedure Extract(const ZipFileName: WideString; const DestDirName: WideString); dispid 202;
  end;

// *********************************************************************//
// クラス DirZip は、Create および CreateRemote メソッドを使用して
// CoClass DirZip が公開するデフォルトのインターフェイス IDirZip の
// インスタンスを作成する。このタイプ ライブラリのサーバーによって
// 公開された CoClass オブジェクトに対し、オートメーションを行いたい
// クライアントが用いるために、これらの関数が存在する。
// *********************************************************************//
  CoDirZip = class
    class function Create: IDirZip;
    class function CreateRemote(const MachineName: string): IDirZip;
  end;

implementation

uses System.Win.ComObj;

class function CoDirZip.Create: IDirZip;
begin
  Result := CreateComObject(CLASS_DirZip) as IDirZip;
end;

class function CoDirZip.CreateRemote(const MachineName: string): IDirZip;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_DirZip) as IDirZip;
end;

end.

VB6,VBAの呼び出しのサンプルは、


Private Sub CommandButton1_Click()
    Dim DirZip As SimpleDirZip.DirZip
    
    Set DirZip = New SimpleDirZip.DirZip
    
    Call DirZip.Compress("C:\Users\ppp", "C:\Users\pp\ppp.zip")    
    Set DirZip = Nothing
    
End Sub

Private Sub CommandButton2_Click()
    
    Dim DirZip As SimpleDirZip.DirZip
    
    Set DirZip = New SimpleDirZip.DirZip
    
    Call DirZip.Extract("C:\Users\pp\ppp.zip", "C:\Users\pp\p")
    
    Set DirZip = Nothing

End Sub

C#とかでComを作るより簡単かも。

ところで、タイプライブラリでインターフェイスのメソッド名を編集時にメソッド名が全部消せないのは
仕様なんかしら・・・。
とりあえず2007では消せたんだけど・・・・。

AnsiExtractQotedStr

QuotedStr関数の存在は、知ってたけど、AnsiExtrctQuotedStrの存在は知らなかった。(^^ゞ
ってことで、使ってみた。
以下ソース


program Project1;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils;

var
  s :String;
  src : PWideChar;
begin
  try
    { TODO -oUser -cConsole メイン : ここにコードを記述してください }
    s := 'ミリアリア';
    Writeln(s);
    s := QuotedStr(s);
    Writeln(s);
    src := PwideChar(s);
    s := AnsiExtractQuotedStr(src,'''');
    Writeln(s);

    readln;

  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.


AnsiExtractQuitedStr内のsrcのとこで、直接キャストしようとすると コンパイルエラーが出るので、一度変数受けでキャスト。
で実行結果は、


2012年11月8日木曜日

指定したフォルダの特定のファイルをSJISからUTF8に変更する

今の仕事で使用した、SJIS→UTF8のチャラツール。
ファイル数がすくなければ、手作業でするけど、ファイル数が多いのファイルが
サブディレクトリにわたるので、作ってみた。
諸般の事情により、Delphi2007で作ったので、UTF8への変換にはjclUnicodeの
TWideStringList、ファイルの走査にはJclFileUtilsのTJclFileEnumeratorを利用した。
(変換元ファイルのディレクトリ、変換先のディレクトリの指定にJvclの TJvDirectoryEdit
を使用した。)

以下ソースコード。


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,JclStrings, JclFileUtils, StdCtrls, Mask, JvExMask, JvToolEdit,jclUnicode;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    JvDirectoryEdit1: TJvDirectoryEdit;
    JvDirectoryEdit2: TJvDirectoryEdit;
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    FFileEnumerator: TJclFileEnumerator;
    FDirCount: Integer;
    FTaskID: TFileSearchTaskID;
    FT0: TDateTime;
    procedure DirectoryEntered(const Directory: string);
    procedure AddFile(const Directory: string; const FileInfo: TSearchRec);
    procedure TaskDone(const ID: TFileSearchTaskID; const Aborted: Boolean);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
uses Types,StrUtils, VBLikeString;
{$R *.dfm}

{ TForm1 }

procedure TForm1.AddFile(const Directory: string; const FileInfo: TSearchRec);
var
  SourceFileName,TargetFileName : String;
  TargetDir : String;
  SourceText : TStringList;
  TargetText : TWideStringList;
  LineCount : Integer;
  WorkStrings : TStringDynArray;
  //RevArray : Array of String;
  RevisionString : String;
  IsHeaderArea : Boolean;
begin
  SourceFileName := Directory + FileInfo.Name;

  //変換後ファイルの書き込み先フォルダは、元ファイルのフルパスの変換元フォルダに指定した
  //文字列を変換後に指定したフォルダに置換すれば良い
  TargetFileName := ReplaceText(SourceFileName,JvDirectoryEdit1.Text,JvDirectoryEdit2.Text);
  TargetDir := ExtractFileDir(TargetFileName);

  //ディレクトリがなければ作成する
  if not(DirectoryExists(TargetDir)) then ForceDirectories(TargetDir);

  SourceText := TStringList.Create;
  try
    SourceText.LoadFromFile(SourceFileName);
    TargetText := TWideStringList.Create;
    try
      //TargetText.Text := ReplaceStr(SourceText.Text,'@CRLF',sLineBreak);
      TargetText.Text := SourceText.Text;
      TargetText.SaveUnicode := true;
      TargetText.SaveFormat := sfUTF8;
      TargetText.SaveToFile(TargetFileName);
    finally
      TargetText.Free;
    end;
  finally
    SourceText.Free;
  end;
  Memo1.Lines.Add(SourceFileName);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  RootDirectories: TStrings;
begin

  FFileEnumerator.SearchOption[fsLastChangeAfter] := false;
  FFileEnumerator.SearchOption[fsLastChangeBefore] := false;

  RootDirectories := TStringList.Create;
  try
    StrToStrings(JvDirectoryEdit1.Text, DirSeparator, RootDirectories, False);
    FFileEnumerator.RootDirectories := RootDirectories;
  finally
    RootDirectories.Free;
  end;
  FFileEnumerator.FileMask := '*.c;*.h';
  FFileEnumerator.SearchOption[fsMinSize] := false;
  FFileEnumerator.SearchOption[fsMaxSize] := false;
  FFileEnumerator.IncludeSubDirectories := true;
  FFileEnumerator.IncludeHiddenSubDirectories := true;
  FFileEnumerator.CaseSensitiveSearch := false;
  FDirCount := 0;

  FT0 := Now;
  FTaskID := FFileEnumerator.ForEach(AddFile);

end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  FFileEnumerator.StopTask(FTaskID);
end;

procedure TForm1.DirectoryEntered(const Directory: string);
begin
  Inc(FDirCount);
end;

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

procedure TForm1.FormCreate(Sender: TObject);
begin
  FFileEnumerator := TJclFileEnumerator.Create;
  FFileEnumerator.OnEnterDirectory := DirectoryEntered;
  FFileEnumerator.OnTerminateTask := TaskDone;

end;

procedure TForm1.TaskDone(const ID: TFileSearchTaskID; const Aborted: Boolean);
begin
  //
end;

end.

TJclFileEnumeratorは、ファイル検索の条件を設定したうえで、検索条件に該当するファイルが
見つかった場合に呼び出すメソッドを指定してForEcahメソッドを実行すれば、都度、指定した
メソッドを呼び出してくれるので、ForEachに指定しメソッドにSJIS→UTF8の変換処理を
書けばよい。(ソース上ではAddFile)

TStringListを使ってファイルを読み込み、そのテキストをTWideStringListに
渡して、 をTWideStringListでUTF-8を指定して保存することにより、UTF-8変換を
実施した。(このへんは、Delphi 2009以降ならもっとスマートにできる思う。)


2012年9月11日火曜日

Joinのオーバーロード

Joinのオーバーロードを試してみた。
但し、
class function Join(const Separator: string; const Values: IEnumerable): string; overload; static;
以外です。
詳細はプログラム中のコメントに記述しました。
以下、プログラム



program Project3;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils, System.Variants;


var
  s : string;
  a,b : single;
  s1,S2: string;
  elm : TArray;
  //sh : TStringHelper;
begin
  try
    { TODO -oUser -cConsole メイン : ここにコードを記述してください }
   //sh : TStringHelper

   //オーバーロードの1つ目
   //オープン配列を使用した形です。
   writeln('overload1:オープン配列');
   s := s.Join(',',['ミリー','ハイネ']);
   write('OK:');
   writeln(s);
   writeln;

   s1 := '2.17'; s2 := '9.19';
   s := s.Join(',',[s1,s2]);
   write('OK:');
   writeln(s);
   writeln;

   //文字列以外の型だとうまく出力できないようです。
   //空文字が出力されます。
   a := 2.17; b := 9.19;
   s := s.Join(',',[a,b]);
   write('NG');
   writeln(s);
   writeln;


   //オーバーロードの2つ目
   //文字列配列の結合開始位置(0基数)と数を指定
   //この例では、ニーナ,ベルト・サタンと表示します。
   //文字列配列作成の為にとりあえず分割
   s := 'ドッペ,パックン,ニーナ,ベルト・サタン,キノッピー';
   elm := s.Split([',']);
   writeln('overload2:開始位置と数を指定');
   writeln('元の文字列配列');
   for s1 in elm do
   begin
     writeln(s1);
   end;
   writeln('0基数で2番目の文字列から2個の文字列を結合');
   s := s.Join(',',elm,2,2);
   writeln(s);
   writeln;

   readln;



  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.


実行結果は

です。

2012年9月10日月曜日

Splitのオーバーロード

Delphi XE3のオーバーロードを試してみた。
各オーバーロードの内容はプログラム中のコメントに
記載しました。

program Project2;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils;

var
  s,s1 : string;
  elm : TArray;
  elm2 : TArray;
  //sh : TStringHelper;
begin
  try
    { TODO -oUser -cConsole メイン : ここにコードを記述してください }
   //sh : TStringHelper
   s := 'ドッペ,パックン,ニーナ,,ベルト・サタン,,キノッピー';
   //Writeln(s);

   //カンマで分割
   //オーバーロードの1つ目、第二引数に正の整数を入れると
   //先頭から指定した個数だけ分割します。
   //分割できる数以上の数を指定すると無視します。
   //この場合は、ドッペとパックンだけを切り出します。
   elm := s.Split([','],2);
   write('overload1:');writeln(s);
   //分割した要素を表示
   for s1 in elm do
   begin
     writeln(s1);
   end;

   writeln;

   //結合(念のため文字列を初期化)
   //s := '';
   //Writeln(s);

   //s := s.Join(',',elm);
   //Writeln(s);


   //オーバーロードの2つ目、第二引数に
   //TStringSplitOptions.ExcludeEmptyを指定すると
   //空文字を無視して切り出します。
   //TStringSplitOptionsを指定しない場合、あるいは
   //TStringSplitOptions.Noneを指定した場合は
   //空文字も1つとして切り出します。
   elm2 := s.Split([','],TStringSplitOptions.None);
   write('overload2-1:');writeln(s);
   for s1 in elm2 do
   begin
     writeln(s1);
   end;
   writeln;

   elm2 := s.Split([','],TStringSplitOptions.ExcludeEmpty);
   write('overload2-2:');writeln(s);
   for s1 in elm2 do
   begin
     writeln(s1);
   end;
   writeln;


   //オーバーロードの3つ目、第二引数に正の整数を入れると
   //先頭から指定した個数だけ分割します。
   //このときTStringSplitOptions.ExcludeEmptyを指定すると
   //空文字を無視して切り出します。
   //TStringSplitOptionsを指定しない場合、あるいは
   //TStringSplitOptions.Noneを指定した場合は
   //空文字も1つとして切り出します。
   //この場合はベルト・サタンも切り出します。
   elm2 := s.Split([','],4,TStringSplitOptions.ExcludeEmpty);
   write('overload3:');writeln(s);
   for s1 in elm2 do
   begin
     writeln(s1);
   end;
   writeln;

   //オーバーロードの4つ目、セパレータに文字列を指定する
   //こともできます。
   //この場合は、ドッペ,パッと,ニーナ,,ベルト・サタン,,キノッピー
   //に分割されます。
   //(セパレータにCRLFを指定することが可能です。)
   elm2 := s.Split(['クン'],TStringSplitOptions.None);
   write('overload4:');writeln(s);
   for s1 in elm2 do
   begin
     writeln(s1);
   end;
   writeln;


   //オーバーロードの5つ目、セパレータに文字列を指定したうえで
   //分割した結果を取り出すことも可能です。
   //この場合は、ドッペ,パッだけを取り出します。
   //に分割されます。
   elm2 := s.Split(['クン'],1,TStringSplitOptions.None);
   write('overload5:');writeln(s);
   for s1 in elm2 do
   begin
     writeln(s1);
   end;
   writeln;


   readln;


  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.

で実際に実行した結果のビットマップが


です。

追伸:サンプルに使用した文字列がマイナーすぎたようなので、ちょっとだけわかりやすい
ものにしました。

2012年9月5日水曜日

SplitとJoin

Delphi XE3で新たに導入されたStringHelperを使ってみた。 使ったのはJoinとSplit。
それぞれ一番簡単な呼び出し形式です。
以下、プログラム



unit Unit1;
program Project1;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils;

var
  s : string;
  elm : TArray;
  //sh : TStringHelper;
begin
  try
    { TODO -oUser -cConsole メイン : ここにコードを記述してください }
   //sh : TStringHelper
   s := 'キャサリン,さをり,ツネアキ,ハゲミーナ,ヒデオ';
   Writeln(s);

   //カンマで分割
   elm := s.Split([',']);

   //分割した要素を表示
   for s in elm do
   begin
     writeln(s);
   end;

   //結合(念のため文字列を初期化)
   s := '';
   s := s.Join(',',elm);

   Writeln(s);
   readln;



  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.

で実際に実行した結果が、

です。

2012年6月7日木曜日

DelphiでExcelブック内のシート一覧を取得し表示する(dbGo経由)

前のブログで、ExcelのTypeライブラリーを使ってシート一覧を取得しましたが
ついでといっては、なんですが、dbGo(Ado)を使って、シート一覧を取得してみます。

TAdoQueryを使ってSQL文で、テーブル一覧を取得できないか、ちょっと調べたましたが
無理そうだったので、ここでは、

TADOConnection.OpenSchema (
         const Schema: TSchemaInfo;  
        const Restrictions: OleVariant;
         const SchemaID: OleVariant;
                 DataSet: TADODataSet);

メソッドを使ってテーブルを取得します。

方法は、簡単で、

OpenSchema関数のパラメータ

     Schemaに TSchemaInfo.siTables
     DataSetに スキーマ取得結果の書き込み先のレコードセットを指定します。

      
     また、今回は、RestrictionsSchemaIDは使用しませんのでEmptyParamを指定します。


さて、やってみます。

フォームにTADOConnectionを配置し、ConnectionStringの

   ProviderにMicrosoft.ACE.OLEDB.12.0
   Data SourceにExcelのワークブックのパス
   Extended PropertiesにExcel 12.0(Excel2010の場合)

を指定します。

(ConnectionStringについては、http://connectionstrings.com/ が参考になります。)


次に結果格納先としての TADODataSetコンポーネントを配置し、Connectionプロパティに
上記の TADOConnectionコンポーネントを指定します。

あとは、通常の操作で、DataSource,DbGridを配置し、それぞれ接続します。

あとはボタンなどを配置しそのイベントハンドラに

  ADOConnection1.Connected := true;
  ADOConnection1.OpenSchema(siTables, EmptyParam, EmptyParam,ADODataSet1);
 

のようなコードを書きます。

で実行すれば、





のように結果が得られます(右側)

 
 
なお、torry's Delphiのページにもうちょっと詳しいサンプルがあります。http://www.swissdelphicenter.ch/torry/showcode.php?id=1433

また、AdoでのExcelのSchema,については、MSのHELP
http://support.microsoft.com/kb/257819/ja


が参考になります。

2012年6月3日日曜日

DelphiでExcelブック内のシート一覧を取得し表示する

先日、DelphiでExcelのWorkSheetを列挙しながらSheetを編集する処理を作成したとき、
思いもよらずはまったので、自分メモとして保存。

DelphiからExcelを操作する方法としては、

  1. Excelのタイプライブラリーをインポート
  2. dbGoを使用する
  3. サードパーティのコンポーネントを使用する
  4. ・・・
などの方法があげらるが、

今回は、1.タイプタイプライブラリーをインポートしてExcelを操作しシート名を一覧表示する
処理をつかった。

以下、ソース

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

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

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Excel_TLB,System.Win.ComObj;
const
  LCID = LOCALE_SYSTEM_DEFAULT;


procedure TForm1.Button1Click(Sender: TObject);
Var
  ExcelApp : Excel_TLB.ExcelApplication;
  ExcelBook : Excel_TLB.ExcelWorkbook;
  ExcelSheet : Excel_TLB.ExcelWorksheet;
  BookPath : String;
  i : integer;
begin
  ListBox1.Clear;
  ExcelApp := CreateComObject(CLASS_ExcelApplication) as ExcelApplication;
  ExcelApp.DisplayAlerts[LCID] := false;

  BookPath := IncludeTrailingPathDelimiter(ExtractFileDir(Application.ExeName)) + 'Test.xlsx';

  ExcelBook := ExcelApp.Workbooks.Add(BookPath, LCID);

  (* このように書きたいが
    'GetEnumerator' のメンバが含まれていないかアクセスできないため)
      通常では使用不可   
  for  ExcelSheet in  ExcelBook.Worksheets do
  begin
     ListBox1.Items.Add(ExcelSheet.Name);
  end;
  *)


  // Excelのコレクションは1基数なので1からカウントを始める。
  for i := 1 to ExcelBook.Worksheets.Count do
  begin
    ExcelSheet := ExcelBook.Worksheets.Item[i] As  Excel_TLB.ExcelWorksheet;
    ListBox1.Items.Add(ExcelSheet.Name);
  end;

  ExcelSheet := nil;
  ExcelBook.Close(false,BookPath,false,LCID);
  ExcelBook := nil;

  if Assigned(ExcelApp) then
  begin
    ExcelApp.Quit;
    ExcelApp := nil;
  end;


end;

end. 
for ~ in doの構文が使えると、基数のこと意識しなくても良いが、コンパイルすると

 E2431 for-in ステートメントはコレクション型 'Sheets' で動作できません('Sheets' に 'GetEnumerator' のメンバが含まれていないかアクセスできないため)

のメッセージが、出てEXEが作れないため、従来のfor文で列挙している。

  Excelのコレクションが1基数なので、for 文は、1からシート数まででにしていのが
 ポイントです。(ポイントというもののものではありませんが・・・)

 まあ、Excelに限らず、Win32版のVisual Basic(VB6,VB5)とか、VBAのコレクションInterface
 は基本1基数なのですが・・・

 下図のようなブックに対して





 上のような処理を実行すると

 のような結果がえられます。


以下は、余談ですが、

自分 、Excelのコレクションが1基数だということをすっかり忘れていて、結果、午前中つぶしちゃいました。

2012年3月5日月曜日

Unified Interbaseコンポーネントをつかってみた(番外編:Delphi Xe2で使う)

Unified Interbaseリポジトリには、Delphi Xe2用のパッケージ(プロジェクト)がありますので

Unified InterbaseのコンポーネントはDelphi Xe2にインストール可能です。

Xe2のバージョン管理リポジトリから開く機能を使って
としてソースをダウンロードし、
ダウンロード先、packagesフォルダから、UIBD16Win32.groupprojを開いて
ビルドすればインストールできます。

インストールしたコンポーネントは、

な感じになります。(64ビットもサポートされたてます。)

あとは、Unified Interbaseコンポーネントをつかってみた(その1)と同様にして
Firebirdと接続が可能です。

2011年9月24日土曜日

LiveBindingを試してみる。

DelphiXE2のLiveBindingの機能を使って、現在時刻を更新する処理を
チュートリアルを参考作ってみた。

処理としては、時刻が更新されると、登録した通知先(作った例場合はフォーム)の
表示を更新する処理になっています。

以下ソース

まずは、時計のソース、タイマーを使って定周期で時刻を更新し、登録先の
更新通知を行っています。
また、変更通知先を登録する処理を書いています。


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.


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


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.

2011年8月17日水曜日

CPUのコア数を数える。

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

たとえば、

Label1.Caption := IntToStr(System.CpuCount)


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

自分のPCで試したけど、シングルコアのCPUなので
当然のことながら1と表示された。

2011年7月7日木曜日

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

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

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

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.

プロセスリストを表示する(その2)

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

以下、サンプル

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