ラベル 備忘録 の投稿を表示しています。 すべての投稿を表示
ラベル 備忘録 の投稿を表示しています。 すべての投稿を表示

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/
に配置しております。

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

2011年4月3日日曜日

Guid文字列を得る

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

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

end;


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

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


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

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

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

2011年3月1日火曜日

Null許容型

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

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

以下試したソースコード

unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation
Uses DeHL.Nullable;

{$R *.dfm}

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

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

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

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

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

end;

end.

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

2011年2月6日日曜日

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

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

以下、その備忘録

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

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

また、FlameRobin黒猫 SQL StudioA5: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コンポーネントをつかってみた(その3)

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

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

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

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

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


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

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

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

unit UIBCdsDataSet;

interface

uses
  SysUtils, Classes, DB, uibdataset;

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

procedure Register;

implementation

uses uiblib;

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

{ TUIBCdsDataSet }

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

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

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

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

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

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

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

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

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

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

end;

end.

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

2011年1月30日日曜日

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).開発時パッケージをインストールします。

2011年1月27日木曜日

Unified Interbaseコンポーネントをつかってみた(その1)

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

先ずは、インストール

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

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

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

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



Firebirdに接続してみる。

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


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

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

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

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

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

2010年12月9日木曜日

プロセスの再起動

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

停止させるプロセスは、仕様上一意性が保障されている
ので、コマンドライン引数に起動するプロセスの絶対パスを
与えて、そこからプロセス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.

2010年11月3日水曜日

サービスの起動と停止

現在、進行中の案件で、サービスの再起動を定期的に行う必要が
あるので、Delphiでできるかどうか調べてみた。

Delphi PrismではdotNetFreameworkに標準で用意されたクラスが使えるので
簡単だが、Delphi(Win32)では用意されていないみたいだ。

さらに調べたところ、Jedi Code Library(Jcl)には、サービスを扱うクラス
(TJclSCManager,TJclNTService)が用意されていることを知ったので、
実際に検証してみた。

以下、検証用に作ったサンプル(サービスの列挙と指定したサービスの
停止と起動)です。

unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

uses
    JclSvcCtrl
  , TypInfo
  ;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  SvcMgr : TJclSCManager;
  i : Integer;
begin
//
  SvcMgr := TJclSCManager.Create();

  try
    SvcMgr.Refresh(true);
    ListBox1.Clear;
    for i := 0 to SvcMgr.ServiceCount -1 do
    begin
      ListBox1.Items.Add(SvcMgr.Services[i].ServiceName);
    end;


  finally
    SvcMgr.Free;
  end;

end;

procedure TForm1.Button3Click(Sender: TObject);
var
  SvcMgr : TJclSCManager;
  Svc : TJclNTService;
begin
//
  //if True then
  SvcMgr := TJclSCManager.Create();
  try
    SvcMgr.Refresh(true);
    if (SvcMgr.FindService(LabeledEdit1.Text,Svc)) Then
    begin
      if TComponent(Sender).Tag = 1 then
      begin
        Svc.Start;
      end
      else
      begin
        Svc.Stop;
      end;
      Label1.Caption := GetEnumName(TypeInfo(TJclServiceState),Ord(Svc.ServiceState)) ;
    end;
  finally
    SvcMgr.Free;
  end;


end;

procedure TForm1.ListBox1Click(Sender: TObject);
var
  SvcMgr : TJclSCManager;
  Svc : TJclNTService;
begin
  if ListBox1.ItemIndex >=0 then
  begin
    LabeledEdit1.Text := ListBox1.Items.Strings[ListBox1.ItemIndex];
    SvcMgr := TJclSCManager.Create();
    try
      SvcMgr.Refresh(true);
      if (SvcMgr.FindService(LabeledEdit1.Text,Svc)) Then
      begin
        Label1.Caption := GetEnumName(TypeInfo(TJclServiceState),Ord(Svc.ServiceState));
      end;
    finally
      SvcMgr.Free;
    end;

  end;

end;

end.




なお、jclには上記クラスを使用したサンプルプログラムがありますので詳細については
そちらを参照して下さい。

2010年11月2日火曜日

JvScheduledEventsを試してみる。

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

OS標準のタスクスケジューラを使用してもよっかったが
起動できるのがバッチファイルか単独の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.


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


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

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

2010年9月23日木曜日

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;