TIdURI を使ってパラメータを取得する

Delphi-ML で GET のパラメータを取得したい、という話を間違えて取らえた際にできたコードです！
TIdURI を使うと URI をパースしてくれるので、↓こんな感じでパラメータを取れます。

uses
  System.SysUtils, System.Classes, IdURI;
 
procedure GetParams(const iURL: String; const iStrings: TStrings);
var
  URI: TIdURI;
  Params: TArray<String>;
  Param: String;
begin
  URI := TIdURI.Create(iURL);
  try
    Params := URI.Params.Split(['&']);
 
    iStrings.Clear;
    for Param in Params do
      iStrings.Add(TIdURI.URLDecode(Param));
  finally
    URI.Free;
  end;
end;

TIdURI の Params は、単純に '?' を探してそれ以降を切り出した物なので、& で split したり、URLDecode したりしています。

FireMonkey2 3D 事始め

そろそろ FireMonkey にも手をつけておかないといけないかな！と思い、ちょっと触ってみました記。

とりあえず、３Dデータを読み込ませて、派手な画面を見たい、ということで、３Dデータを探してみました。
すると、 KINECT 買った時に付いてきた「窓辺ななみ」と「クラウディア窓辺」のデータを発見！

では、 FMX で読み出すぞー！と思って TForm3D を開いて、TModel3D を置いて、MeshCollection の「…」を押してデータ読み込みの画面を開いてみました。

すると、読み込めません！
検索してDEKO さんの所に辿り着きました。
TModel3D で読み込めるのは次の３形式のみということです。

• *.ase
• *.dae
• *.obj

FBX を読み込むためには、別形式にコンバートしないといけないようです。

そこで、また検索してみると Autodesk が FBX Converter を配布していました。



早速ダウンロードして、インストールしてみました。



FBX Converter で変換できる形式で FireMonkey で読み出せるのは「obj」「dae」
で、最初 OBJ 形式に変換してみました。名前に惹かれて……
すると、こんなことに！



ギャア！メタリックでパーツも変なことに！

なので、DAE に変換してみました。



テクスチャが貼れてませんが、上手く行きました（多分）。
と、とりあえず、ここまで到達するのに結構な時間が……

HD アプリケーションに比べて、やることが多いので、ちゃんとしたコードを書けるようになるまでには、まだ時間がかかりそうです

ジェネリクス

Delphi の 2009 から？ジェネリクスに対応しました。
純粋に、そういえば、どういう構造で管理してるのかな？と思ってソースを見てみました。
そうすると、下のようになっており

  TList<T> = class(TEnumerable<T>)
  private
  type
    arrayofT = array of T;

動的配列を使っていました。
なるほど！これならオブジェクトの解放を自分で管理しなくて済みますね！
Delphi の動的配列は解放をコンパイラに任せられるためです。
あって良かった動的配列！

とはいえ、当然のことですが、インスタンスの場合は解放が必要になります。
例えば、以下のコードの様にインスタンスを生成した場合、破棄が必要です。

program Project1;
 
{$APPTYPE CONSOLE}
 
uses
  System.Generics.Collections;
 
type
  // TList で管理されるクラス
  TTest = class
  public
    constructor Create(const iIndex: Integer); reintroduce;
  end;
 
  // TTest クラスを型データとする
  TObjectList = TList<TTest>;
 
{ TTest }
 
constructor TTest.Create(const iIndex: Integer);
begin
  Writeln('TTest.Created !, Index = ', iIndex);
end;
 
procedure Test;
var
  List: TObjectList;
  i: Integer;
begin
  List := TObjectList.Create;
  try
    // インスタンスの生成
    for i := 0 to 9 do
      List.Add(TTest.Create(i));
 
    // インスタンスの解放
    for i := 0 to List.Count - 1 do
      List[i].Free;
  finally
    List.Free;
  end;
end;
 
begin
  Test;
  Readln;
end.

そう考えると TList 等のジェネリクス型と相性が良いのは record の様な気がします。
解放を考えなくて済みますから。

ただ、ここで注意したいのは以前書いた記事のように、record はあくまでも record であるという事です。
TList と組み合わせて使うと、この罠に引っかかりやすいので注意が必要です。

TFindDialogEx と class helper

DEKO さんから class helper を使うと private なメンバにアクセスできちゃうよ！という情報をいただきました。
詳細はリンク先の Owl's perspective さんの所でご覧頂くとして、先日記事した TFindDialogEx を、class helper に書き換えてみました。

まず、TCommonDialog と TFindDialog の class helper を書きます。

type
  TCommonDialogHelper = class helper for TCommonDialog
  public
    procedure ReleaseRedirector;
  end;
 
  TFindDialogHelper = class helper for TFindDialog
  public
    procedure ReleaseHandle;
  end;
 
{ TCommonDialogHelper }
 
procedure TCommonDialogHelper.ReleaseRedirector;
begin
  Self.FRedirector.Free;
end;
 
{ TFindDialogHelper }
 
procedure TFindDialogHelper.ReleaseHandle;
begin
  Self.FFindHandle := 0;
end;

TCommonDialog のヘルパが必要なのは FRedirector は TCommonDialog のメンバだからです。

TFindDialog は TCommonDialog と同じ Unit 内にあるので、特に何もせず FRedirector を参照できます。

コードで Self を強調表示してありますが、それは Self を外すとコンパイルが通らないためです。
注意してください。

これらのヘルパメソッドを実際に使う部分は以下のようになります。

function TFindDialogEx.Execute(ParentWnd: HWND): Boolean;
var
  TId: DWORD;
begin
  // 無効なウィンドウハンドルでは 0 が返る
  TId := GetWindowThreadProcessId(Handle);
  if (TId = 0) then begin
    ReleaseHandle;
    ReleaseRedirector;
  end;
 
  Result := inherited;
end;

RTTI を使った場合より大分すっきりしました。

どのメンバを操作しなくてはいけないのかが判っている場合は、class helper の方が良さそうです。

TRichEdit と VCL スタイル

ソースはこちら(GitHub)

TRichEdit と VCL スタイルを併用する場合は注意が必要です。
というのも、TRichEdit は、VCL スタイルをサポートしているとは言いづらいためです。
もしかすると、Vcl.ComCtrls に登録されている Win32 Common Controls は、どれも問題があるのかもしれません。
個人的に TListView や TTreeView は使い方が煩雑なので、使っていないため判りませんが……。

QuolityCentral に送った画像で申し訳ないですが、TRichEdit と VCL スタイルを併用するとこんな事が起こります。


スクロールバーの亡霊が表示される



文字の再描画がおかしい
というか、そもそもフォントの色がおかしい



このように色々と崩れます。
VCL スタイルが適用されているフォームにTRichEdit のインスタンスを作るだけで簡単に確認可能です。

また、画像としては取れていませんが、WM_ERASEBKGND を受け取ると TRichEdit.Color で背景色が塗りつぶされるため、一瞬「白」が見えた後にスタイルの色で塗られます。
これの解決策は、TRicEdit.Color にスタイルの色を設定しておけば大丈夫です。

uses
  Vcl.Themes;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  RichEdit1.Color := StyleServices.GetStyleColor(scWindow);
end;

この処置を行うと、文字の再描画がおかしい（２番目の画像）、という問題も直ります。

と、色々とおかしいので、TRichEdit と VCL スタイルは、併用しない方が賢明です。
どうしても、という場合は、下記の様にします。

procedure TForm1.FormCreate(Sender: TObject);
begin
  // 背景色をスタイルの色と同じに設定する
  RichEdit1.Color := StyleServices.GetStyleColor(scWindow);
 
  // スクロールバーを消さない
  RichEdit1.HideScrollBars := False;
 
  // フォントは自前でやる
  RichEdit1.StyleElements := [seClient, seBorder]; 
  RichEdit1.Font.Color := 
    StyleServices.GetFontColor(sfEditBoxTextNormal);
 
  // なお上記のコードを別のメソッドに纏めて、
  //スタイルが変更されるとき必ず呼ばれるようにしておく必要がある。
end;

これで、一応、おかしな動作はしなくなります。

TCommnDialog と Style

ソースはこちら(GitHub)

まずは、これをご覧ください。



TOpenTextFileDialog を開いたところです。
みんな、VCL スタイルを使ってないのかな……
いや！ HTML5 Builder を作った時に気づいてるハズなんだが！

……まあそれはそれとして、これを何とかしなくてはなりません。
前回の記事と同様に、拡張 RTTI を使ってコントロールから Style を取り除くコードを書きました。

unit uStyleUtils;
 
interface
 
procedure ClearStyles(const iObj: TObject);
 
implementation
 
uses
  System.Rtti, System.TypInfo, Vcl.Controls;
 
procedure ClearStylesSub(const iControl: TControl);
var
  i: Integer;
begin
  if (iControl <> nil) then begin
    if (iControl is TWinControl) then
      with TWinControl(iControl) do
        for i := 0 to ControlCount - 1 do
          ClearStylesSub(Controls[i]);
 
    iControl.StyleElements := [];
  end;
end;
 
procedure ClearStyles(const iObj: TObject);
var
  Context: TRttiContext;
  Fields: TArray<TRttiField>;
  Field: TRttiField;
  RttiType: TRttiType;
  Obj: TObject;
begin
  Context := TRttiContext.Create;
  try
    try
      Fields := Context.GetType(iObj.ClassType).GetFields;
 
      for Field in Fields do begin
        RttiType := Field.FieldType;
 
        if
          (RttiType = nil) or (RttiType.TypeKind <> tkClass) or
          (Field.Name = 'FOwner') or (Field.Name = 'FParent')
        then
          Continue;
 
        try
          Obj := Field.GetValue(iObj).AsObject;
        except
          Obj := nil;
        end;
 
        if (Obj <> nil) and (Obj is TControl) then
          ClearStylesSub(TControl(Obj));
      end;
    except
    end;
  finally
    Context.Free;
  end;
end;
 
end.

全文引用しても、この程度の長さのものです。
使い方は

procedure TForm1.FormCreate(Sender: TObject);
begin
  ClearStyles(OpenTextFileDialog1);
end;

と最初に一回呼ぶだけです。
これで、キレイに表示できるようになりました。

TFindDialog とスタイル

ソースはこちら(GitHub)

TFindDialog に TControl 派生コントロールを乗せる必要があり、TFindDialogEx を実装しました。
TFindDialog に限らず TCommonDialog を継承するダイアログは、Windows のコモンダイアログのラッパーになっています。
そのため、VCL のコントロールを乗せるのは、少しテクニックが必要です。

具体的には、下記の様に TPanel などのコンテナに乗せてやる必要があるのです。

// Vcl.ExtDlg の TOpenTextFileDialog から引用
constructor TOpenTextFileDialog.Create(AOwner: TComponent);
var
  I: Integer;
begin
  (省略)
 
  FPanel := TPanel.Create(Self);
  with FPanel do
  begin
    (省略)
 
    with FLabel do
    begin
      (省略)
      Parent := FPanel;
    end;
 
    FComboBox := TComboBox.Create(Self);
    with FComboBox do
    begin
      (省略)
      Parent := FPanel;
    end;
  end;
end;

もし、TPanel に乗せないとどうなるかというと、フォーカスを受け取れなくなり、マウス・キーボードの操作が効かなくなります。

ということで、まねして TFindDialogEx のコンストラクタでも TPanel のインスタンスを生成します。

constructor TFindDialogEx.Create(iOwner: TComponent);
begin
  inherited;
 
  FPanel := TPanel.Create(Self);
  with FPanel do begin
    BevelInner := bvNone;
    BevelOuter := bvNone;
    StyleElements := [];
    FullRepaint := False;
    TabOrder := 0;
    TabStop := True;
    Color := clBtnFace;
  end;
end;

ここで重要なのは StyleElements です。
Windows のコモンダイアログに乗るので Style による描画は必要ありません。
もし、StyleElements に何もしていないと……



上図のように周りから浮いてしまいます。
次に、ダイアログに乗せるコントロールを追加するメソッドを定義します。

// iControl を FPanel の子供に設定する
procedure TFindDialogEx.AddControl(const iControl: TControl);
begin
  if (FControl <> nil) then
    FControl.Parent := nil;
 
  FControl := iControl;
 
  if (FControl <> nil) then begin
    FControl.Parent := FPanel;
 
    ListupControl(
      FControl,
      procedure (const iControl: TControl)
      begin
        iControl.StyleElements := [];
      end
    );
  end;
end;
 
// ListUpControl は全てのコントロールを列挙する
type
  TListupCallback = reference to procedure (const iControl: TControl);
      
procedure TFindDialogEx.ListupControl(
  const iControl: TControl;
  const iCallback: TListupCallback);
var
  i: Integer;
begin
  if (iControl <> nil) then begin
    if (iControl is TWinControl) then
      with TWinControl(iControl) do
        for i := 0 to ControlCount - 1 do
          ListupControl(Controls[i], iCallback);
 
    iCallback(iControl);
  end;
end;

このように FPanel を Parent に設定しています。
また、FPanel と同様に StyleElements も [] として設定しています。

ListupControl では reference to を使って、無名メソッドを呼び出すようにしています。
これによって、Listup した Control を簡単に処理できます。

次に、ダイアログに FPanel を乗せる処理です。
コモンダイアログは、WM_INITDIALOG メッセージで、初期化処理をします。
TCommonDialog には WM_INITDIALOG メッセージを受信したときに呼ばれる DoShow メソッドがあります。
そこで、これを override して、初期化処理をします。

type
  TFindDialogEx = class(TFindDialog)
  (略)
  protected
    procedure DoShow; override;
  (略)
  end;
 
implementation
 
procedure TFindDialogEx.DoShow;
var
  WndRect: TRect;
  tmpRect: TRect;
begin
  inherited;
 
  GetWindowRect(Handle, WndRect); // Screen 座標の位置。NoClient エリアも含む
  GetClientRect(Handle, tmpRect); // Window 座標の位置。Client エリアのみ
 
  if (FControl <> nil) then begin
    FPanel.ParentWindow := Handle; // Dialog を親に設定
 
    // パネルのサイズを計算
    FPanel.ClientHeight := FControl.Height;
    FPanel.SetBounds(
      0,
      tmpRect.Height - 10, // 10 pixel 位上だと見栄えが良い
      tmpRect.Width,
      FControl.Height);
 
    // パネルの高さ分、ダイアログのウィンドウを伸ばす
    MoveWindow(
      Handle,
      WndRect.Left,
      WndRect.Top,
      WndRect.Width,
      WndRect.Height + FPanel.Height, // FPanel の高さ分伸ばす
      True);
  end;
end;

では、ここまでで動かしてみると……



なんと、コントロールが表示されていません。
ちなみに、マウスをオーバーしたり、Alt キーを押すと表示されます。
これは、Windows のコモンダイアログのメッセージ処理が上手く流れてこないためです。
なので、コモンダイアログの WM_ERASEBKGND メッセージで、コントロールを再描画してやる必要があります。

procedure TFindDialogEx.WMEraseBkGnd(var ioMsg: TWMEraseBkGnd);
begin
  inherited;
 
  ListupControl(
    FControl,
    procedure (const iControl: TControl)
    begin
      iControl.Repaint; // 再描画させる
    end
  );
end;

では、これでもう一度表示させてみると……



上手く表示されました。
で、事はこれで終わりかと思いきや、とんでもないバグが潜んでいたのです。

TFindDialog は他のダイアログと違い、モードレスなダイアログです。
つまり、ダイアログを表示している最中に、ユーザーは任意のフォームを操作できます。
そのため、TFindDialog を出したまま、スタイルを変更することもできるのです。

もし、そうするとどうなるかというと、Execute を呼び出してもダイアログは表示されなくなります。

これは、何故かと言うと下記のコードが Execute に記述されているからです。

function TFindDialog.Execute(ParentWnd: HWND): Boolean;
var
  Option: TFindOption;
begin
  if FFindHandle <> 0 then // 0 かどうかで判断している
  begin
    // 0 じゃなかったら既に表示されていると判断して
    // ウィンドウを前に持ってくる処理を走らせる
    // しかし！ ウィンドウハンドルが無効だった場合、何も起きない！
    BringWindowToTop(FFindHandle);
    Result := True;
  end else
  begin
    (略)
  end;
end;

Style が変更されるとウィンドウは RecreateWnd を使って再生成されます。
そのため、FFindHandle は 0 ではありませんが、無効なウィンドウハンドルになっています。
これによって、Execute を呼び出しても何も起きないのです。

そこで、この不具合を取り除くために拡張 RTTI を使って、FFindHandle を 0 にします。

function TFindDialogEx.Execute(ParentWnd: HWND): Boolean;
var
  TId: DWORD;
  Context: TRttiContext;
  Field: TRttiField;
  Obj: TObject;
begin
  // 無効なウィンドウハンドルでは 0 が返る
  TId := GetWindowThreadProcessId(Handle);
  if (TId = 0) then begin
    Context := TRttiContext.Create;
    try
      try
        Field := Context.GetType(Self.ClassType).GetField('FFindHandle');
        if (Field <> nil) then
          Field.SetValue(Self, 0); // FFindHandle を 0 に
 
        Field := Context.GetType(Self.ClassType).GetField('FRedirector');
        if (Field <> nil) then begin
          Obj := Field.GetValue(Self).AsObject;
          if (Obj <> nil) then
            Obj.Free; // FRedirector を解放
        end;
      except
      end;
    finally
      Context.Free;
    end;
  end;
 
  Result := inherited;
end;

FFindHandle だけではなく FRedirector というコントロールも破棄する必要があるので、それも破棄しています。
このように拡張 RTTI を使うと private として隠蔽されていた変数やメソッドまで呼べてしまいます。

Java を知っている方にはおなじみ？のリフレクションと同じ機能です。
静的型付けのコンパイル型言語で、同じ事ができるとは驚きです。

非常に強力なので、注意が必要です。

拡張 RTTI については、第２３回デベロッパーキャンプの福士さんの資料が詳しいです。

これで、完全に動作するようになりました。

Delphi でコモンダイアログをカスタマイズする方法があまり存在しないので、書いてみました。

Drag and Drop Suite ２

数個前に Drag and Drop Suite を紹介しました。
これで、一見落着に思えたのですが、１つ問題が出てきました。
OnGetStream イベントで戻す値は、AStream だけです。
AStream に nil を返すと、false と判断されます（ドロップに失敗）。
このとき、続くデータが存在したとしても、それ以降全ての処理がキャンセルされてしまいます。

例えば、

Data := TVirtualFileStreamDataFormat(dataFormatSource.DataFormat);
Data.FileNames.Clear;
 
for i := 0 to FTargets.Count - 1 do
  Data.FilesNames.Add(FTargets[i]);

と、していたときに、最初の一個で失敗すると、全部失敗します。

これでは、FTP 系のソフトの操作として問題があるので、ソースを書き換えてしまいます。
DragDropFile.pas の 2476 行目に OnGetStream を呼ぶ記述があります。
その下に、Result := True; と書いて、常に成功状態にします。

FOnGetStream(Self, Index, Stream);
Result := True;

これだけで、OKです。
作者とコンタクトを取りたいけど、英語ができない……。

Record クイズ

ソースはこちら（GitHub）

突然ですがクイズです。

下記の様なレコード型 TBar があります。

■ リスト１

TBar = record
  FBaz: Boolean;
  constructor Create(const iBaz: Boolean);
  procedure SetBaz(const iBaz: Boolean);
end;
 
// レコード型のコンストラクタは引数がないといけない
constructor TBar.Create(const iBaz: Boolean);
begin
  SetBaz(iBaz);
end;
 
// FBaz を設定する Accesser
procedure TBar.SetBaz(const iBaz: Boolean);
begin
  FBaz := iBaz;
end;

TBar をリストに持つ TFoo があります。

■ リスト２

TFoo = class
  FBars: TList<TBar>;
  procedure Check;
  constructor Create; reintroduce;
  destructor Destroy; override;
end;
 
constructor TFoo.Create;
var
  Bar: TBar;
begin
  inherited;
 
  // リストを生成
  FBars := TList<TBar>.Create;
 
  // FBaz = False で生成
  FBars.Add(TBar.Create(False));
 
  // FBaz = True に設定
  for Bar in FBars do
    Bar.SetBaz(True);
end;
 
destructor TFoo.Destroy;
begin
  FBars.Free;
 
  inherited;
end;

では、このとき、下記のコードを実行すると何が出力されるでしょうか？

■ リスト３

begin
  with TFoo.Create do
    try
      if (FBars[0].FBaz) then
        Writeln('TRUE')
      else
        Writeln('FALSE');
 
      Readln;
    finally
      Free;
    end;
end.

こんな風に書いているから丸わかりでしょうが、答えは FALSE です。

何故かと言うとレコードはあくまでレコードだから、です。
クラスのようにメソッドを持てるようになりましたが、（当然ですが）レコード型の代入は値のコピーが渡されるに過ぎません。

クラスなら、変数に保持されているのはポインタですので、値を変更すれば元の値が変わります

なので「リスト２」にあった下記のコードは

var
  Bar: TBar;
begin
  （略）
  // ローカル変数 Bar の FBaz が設定されただけで
  // FBars[0] の Bar が設定されるわけではない！
  for Bar in FBars do
    Bar.SetBaz(True);
end;

あくまでローカル変数に対しての操作になります。
ローカル変数ですのでメソッドを抜けたら、破棄されます。

クラス感覚で、レコード型を使うと痛い目にあうよ！というお話しでした。

つまり痛い目に遭ったわけです……
TStyleProvider が更新されております……

ちなみに、SetBaz というメソッドを作ったのは、下記の様に代入エラーが出るからです。
これで気づきました。

for Bar in FBars do
  Bar.FBaz := True; // 代入できない左辺値エラー