2012年11月27日火曜日

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 したりしています。

2012年11月22日木曜日

FireMonkey2 3D 事始め

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

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

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

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

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

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

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



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



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



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

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



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

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

2012年11月19日月曜日

ジェネリクス

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 と組み合わせて使うと、この罠に引っかかりやすいので注意が必要です。

2012年11月14日水曜日

TFindDialogEx と class helper

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

まず、TCommonDialogTFindDialogclass 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 の方が良さそうです。

2012年11月9日金曜日

TRichEdit と VCL スタイル


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

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;

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

と、色々とおかしいので、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;

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

2012年11月8日木曜日

TCommnDialog と Style


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



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;

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


2012年11月7日水曜日

TFindDialog とスタイル


TFindDialogTControl 派生コントロールを乗せる必要があり、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 については、第23回デベロッパーキャンプ福士さんの資料が詳しいです。

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

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

2012年11月5日月曜日

Drag and Drop Suite 2

数個前に Drag and Drop Suite を紹介しました。
これで、一見落着に思えたのですが、1つ問題が出てきました。
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です。
作者とコンタクトを取りたいけど、英語ができない……。

2012年11月2日金曜日

Record クイズ

突然ですがクイズです。

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

■ リスト1
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 があります。

■ リスト2
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;

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

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
























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

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

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

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

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; // 代入できない左辺値エラー