2013年12月25日水曜日

チラ裏(個人的な事を振り返る)

Delphi Advent Calendar 2013 の 12/25 の記事です。

ということで、ブログで初めて個人的な事を書くよ!!
Delphi Advent Calendar の最後の記事がチラ裏でごめんね!!

今年あった大きな事は
  1. Delphi iOS の本を出した
  2. Embarcadero MVP になった
  3. LL祭りに出た
ってことです。

まず、本については、非常に僥倖でした。
お話を頂いて、毎晩+土日を使って書いたんですけど、まだベータ版の段階だったので、メソッドが変わったり、動作が変わるwww
何度、書き直した事か……!
そして、査読してくださった方々や、エンバカデロの皆さん、CUTT SYSTEM の皆さんのご協力があって、完成しました。
人生で本を出すのは2度目ですが、やっぱり、大変な作業でしたよ…。



次は、エンバカデロ MVP になりました、というお話です。
エンバカデロ MVP になるためには、デベロッパーキャンプなどのイベントに出演していること、ブログなどで情報を発信していること、などがあります。
そして、誰かが推薦して認められると、MVPになります。
MVP は年に1回9月に任命されます。

ここで、凄いのは、エンバカデロ本社の MVP 担当部署から直接連絡が来るところです。
エンバカデロ日本法人は関与していません!

僕は英語のメールは全部 SPAM だと思っているので、危うく MVP 任命のメールを捨てるところでした!
ちなみに、推薦してくれたのもエンバカデロの人では無いですし、MVP 担当部署は僕の知らない所ですし、誰かが便宜を図ってくれたとかは無いです。

で、多分誰も知らないと思うので、MVPに任命されると何が起こるのか、を言えるところだけ言うと
  • RAD Studio Enterprise 版の1年間限定ライセンスが貸与される
  • MVP オンライン・ミーティングに出席のお願いがくる(基本向こうの時間なので厳しい)
  • CodeRage などのイベントがあると、イベントの宣伝のお願いが来る
  • FieldTest のお願いがくる
といったところです。
あとは、言えない部分でいくつかありますが、そこは察して!!
あ、ちなみに、悪口を言ってはいけないとかも無いです。



3つめは「LL まつり」という、Lightweight Language のイベントに出席したことです。
Delphi なんで、いままでクライアントサイドのイベントにしか出たこと無かったですが、ちょっとしたご縁により、出させて貰いました。
これで、Delphi について話せたのが個人的には凄く嬉しい出来事でした。
というのも、Delphi 知らない人にも Delphi という言葉を伝えられたのと、昔 Delphi 使ってた人達に Delphi を思い出して貰えたからです!

今の Delphi は、iOS / Android / Win / OS X と4つのプラットフォームに対応していますが、これを伝えられたのは本当に大きくて、色々と反響をいただきました。



最後に、来年のこと。
LL まつりの縁で、来年の CROSS 2014 にも登壇します。これも、どちらかといえば LL 系言語のイベントですが、言語同士のバトルが見たいwwwということでお話を頂きました。
が、バトルはしません!宗教戦争になるので!それぞれの言語について、色々紹介するイベントになります。

さらに、その後「Developers Summit」にも出ます!
こちらでは、モバイル開発に対して、ちょっと話してきます。

と、いうことで、2014年も色々活動できたらなーと思っています。

あ、そうそう、Delphi Android の本も書いているので、今しばらくお待ちを……

それでは、良いお年を!!

2013年12月23日月曜日

FireMonkey の TWebBrowser を Win/Mac で使えるようにする!

Delphi Advent Calendar 2013 12/23 の記事です。

なんだか、結構需要があるっぽい FireMonkey 用の TWebBrowser を作りました!というお話です。

FireMonkey で複数 Platform に対応するコントロールを作るためには「共通の要素を Interface 化する」という作業が必要になります。
そして、それぞれの Platform で、その Interface を実装してやります。
今回は、iOS / Android 用の TWebBrowser が継承しているのと同じ ICustomBrowser を継承して、Win/Mac 用の TWebBrowser を作りました。

また、FireMonkey のファイル名は、FMX.コントロール名.Platform.pas とする慣習があります。
ということで、今回は
  • FMX.WebBrowser.Win.pas
  • FMX.WebBrowser.Mac.pas
という名前にしました。

また、元々の TWebBrowser は iOS / Android 用なので Parent を設定するという処理がありません。
Parent が設定されたら ICustomBrowser を継承した WebBrowser を表示する必要があるので、それらを処理する TWebBrowserEx というコンポーネントも作りました。

また、もう一つ FireMonkey の慣習があって、各プラットフォーム用の Interface は、implementation 部に書き、interface 部には、それを登録する関数だけ宣言する、というモノがあります。
あまり好きでは無いのですが、今回は、それに習って Win/Mac 用のユニットには RegisterWebBrowserService と UnregisterWebBrowserService という関数だけ用意しました。

unit FMX.WebBrowser.Win;
interface
procedure RegisterWebBrowserService;
procedure UnRegisterWebBrowserService;
implementation

unit FMX.WebBrowser.Mac;
interface
procedure RegisterWebBrowserService;
procedure UnRegisterWebBrowserService;
implementation

この関数を呼ぶと、TPlatformServices に Win/Mac 用の WebBrowser コントロールを「生成するクラスのインスタンス」が登録される仕組みです。
ここで、WebBrowser コントロールのインスタンスを登録してはいけません!そうすると1個しかインスタンスが作れませんからね!
WebBrowser コントロールを生成するクラスのインスタンスを登録しておけば、そのインスタンスを取り出して、いくらでも WebBrowser を生成できます。

登録したインスタンスは TPlatformServices.Current.SupportsPlatformService メソッドで取り出せます。

RegisterWebBrowserService は initialization で呼ぶようにします。

initialization
RegisterWebBrowserService;
end.

これで、それぞれの Platform 用のユニットを読み込むと、Platform に適したコンポーネントが使えるようになります。
もちろん、それぞれの Platform 用のユニットは IFDEF を使って、どれを読み込むか制御します。
今回は、Win/Mac 用なので、下記のように制御しました。

uses
System.Rtti
{$IFDEF MSWINDOWS}
, FMX.WebBrowser.Win
{$ENDIF}
{$IFDEF MACOS}
, FMX.WebBrowser.Mac
{$ENDIF}
;

これで、Win/Mac 用の WebBrowser を使えるようになりました。
しかし、WebBrowserEx には、WebBrowser を生成しているコードはありません!
生成するコードは、親の親である TCustomWebBrowser の Create で生成されています。
TPlatformServices に登録してあるので、こちらでは何もせずに、正しいインスタンスが生成されます。すばらしい!

ちなみに、軽く各 Platform の実装を説明すると、

Windows 用は、VCL の TWebBrowser を使っています。
IWebBrowserX を取り出したりとか、めんどくさいから!!
FireMonkey でも別に VCL のコントロールも使えてしまうのです。
FireMonkey は TForm だけが Window Handle を持っています。
Windows 用 WebBrowser は、VCL なので、独自に WindowHandle を持っています。
そのため、VCL の TWebBrowser より 上に FireMonkey のコントロールを載せることはできません!
今回は、TForm の指定された(Parent で)場所にコントロールが載っているように見せています。
単純に、Parent の Left,Top,Right,Bottom に合致するように TWebBrowser を作っているだけです。

OS X 用も基本的には同じ仕組みです。
ただ、こちらは VCL の TWebBrowser などないので、自分で WebView を実装しました…超大変だった…Obj-C から Delphi 用のファイルを作るのが
これができたら、あとは実直に WebView を作るだけです。
で、結構はまってる人が居るみたいですが、StackOverflow に提示してあるコードは間違っています
なぜか setHostWindow を使っていますが、これはレシーバ用の Host を決めるためのもので、Parent を設定するモノではありません!
実際には、下記のように addSubView を使って親を設定します。

procedure TMacWebBrowserService.UpdateContentFromControl;
var
View: NSView;
Bounds: TRectF;
begin
if (FWebView <> nil) then begin
if
(FWebControl <> nil)
and not (csDesigning in FWebControl.ComponentState)
and (FForm <> nil)
then begin
Bounds := GetBounds;
View := WindowHandleToPlatform(FForm.Handle).View;
View.addSubview(FWebView);
if (SameValue(Bounds.Width, 0)) or (SameValue(Bounds.Height, 0)) then
FWebView.setHidden(True)
else begin
FWebView.setFrame(GetNSBounds);
FWebView.setHidden(not FWebControl.ParentedVisible);
end;
end
else
FWebView.setHidden(True);
end;
end;

これで、表示されるようになります。

実際に使うと、こんな感じ!






2013年12月22日日曜日

FireMonkey で閉じるボタン付きの TabItem を作る

Delphi Advent Calendar 2013 12/22 の記事です。

FireMonkey で「閉じるボタン付きの TabItem」を作ってみました。
これは、そもそもは facebook の Delphi Talks グループで田中さんが「格好いい?「PageControl 」を探しています」というスレッドを立てたので、僕が FireMonkey で作るのはいかがですか!とオススメした所から始まっています。
ということで、FireMonkey でコンポーネントをるのは大変ではないので、作りました
でも、うかうかしているうちに、やましょうさんの前日の Advent Calendar

> Fmxで作成してみるとわかるのですが、
> delphi+fmxって
> 本当に凄い!!
>
> だってこんなコンポーネントが簡単にできるんですよ。。
> しかも、携帯端末(iosなど)で動くのですから。。

と、言いたいことを言われてしまいました!!/(^o^)\
これが Delphi Advent Calendar の怖いところ!!早い者勝ちなので、来年からは書きたいことがあったら、もっと早く書こう…

まあ、それはそれとして、FireMonkey で、コンポーネントを作る方法は大きく分けて次の3段階が必要です。
  1. スタイルを作る
  2. コンポーネントを作る
  3. コンポーネントエディタを作る
VCL のコンポーネントと大きく違うのは1番目のスタイルを作る部分です。
FireMonkey の場合、見た目の制御は、ほとんど全部スタイルに任せます。
ですが!スタイルを1から作るのはメンドクサイ!
大体が TShape から派生した TRectangle とか TCircle とか TText とかを組み合わせて作るのですが、そういった簡単な図形以外は TPath を使って作ります。
TPath は SVG とか XAML のパスデータを描画してくれるコントロールです。
今回の「閉じるボタン」は「×」の形をしているので、単純な Shape を組み合わせて作るのは大変です!
なので、今回はズルします!
既に「×」ボタンを持っているコントロールからスタイルを盗みましょう。
そのコントロールとは TClearingEdit です。



ということで、方針が定まったのでスタイルを作っていきます。まずは、TStyleBook をフォームに貼ります。



そして、TStyleBook をダブルクリックしてスタイルエディタを開きます。



そして、デフォルトのスタイルから、まあ、なんでもいいんですが、ここでは構造が簡単な Dark スタイルを読み込みました。

「適用して閉じる」を押して、Style エディタを閉じます。
そして、TForm の StyleBook に StyleBook1 を設定します。



次に TTabControl を Form に貼ります。TTabControl は Common Controls にあります。
貼ったら右クリックしてコンポーネントエディタを開いて TTabItem を1つ作りましょう。
そして、できた TTabItem を右クリックして「カスタムスタイルの編集...」を押します。



すると!先ほど作った TabItem1 専用の Style が自動的に作られます。



これを編集していきます。
そして、先ほど盗んでくる!と言った TClearingEdit の「×」印を盗みます!



これを、そのまま TTabItem に移動しちゃいます。



そして、「適用して閉じる」を押して、スタイルエディタを閉じます。



フォームに戻ってみると……切れてる!!
そうです。「×」印が増えた分、文字が切れてしまったのです。

これは、ソースを修正しないと直せないので、スタイルの編集はここまでにして、次にソースを作っていきます……と、その前に作った Style を保存します。

StyleBook をダブルクリックして、スタイルエディタを開き、「保存」ボタンを押します。



すると、Style がテキストで保存されます。
なので、できあがった tabitem1style1 の "object TLayer" で表されるブロックを残して、あとは消します。



そして、これを保存しておきます。

さて、ではソースを作っていきます。
閉じるボタンが付いている TabItem を、TTabItemWithClose という名前にしました。

unit FMX.TabItemWithClose;
 
interface
 
uses
System.Classes
, FMX.Controls
, FMX.TabControl
, FMX.StdCtrls
;
 
type
[ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]
TTabItemWithClose = class(TTabItem)
public type
TCloseEvent = procedure (Sender: TObject; var ioDoClose: Boolean) of object;
private const
STYLE_COLOR_BUTTON = 'closebutton';
STYLE_TEXT = 'text';
STYLE_TABITEM = 'tabitemstyle';
private var
FCloseBtn: TCustomButton;
FTabControl2: TTabControl;
FOnClose: TCloseEvent;
protected
procedure ChangeParent; override;
procedure ApplyStyle; override;
procedure FreeStyle; override;
procedure DoCloseBtnClick(Sender: TObject);
function DoSetWidth(
var ioValue: Single;
iNewValue: single;
var ioLastValue: Single): boolean; override;
public
class function Make(const iParent: TTabControl): TTabItemWithClose;
property TabControl: TTabControl read FTabControl2;
published
property OnClose: TCloseEvent read FOnClose write FOnClose;
end;
一番最初の「[ComponentPlatformsAttribute」はこのコンポーネントがどのプラットフォームで動作するのかを示すモノです。
ここでは、Win32, Win64, OSX32 で動作するとしています。

あとは、閉じるボタンが押されたときのイベントとか、必要な変数・メソッドを定義しています。

ちなみに、StyleLookup をクリックすると出てくるデフォルトの Style は TStyledControl.GetDefaultStyleLookupName で取得します。
なので、ここを Override すると、デフォルトの名前も変わります。
今回の TTabItemWithClose は GetDefaultStyleLookupName を Override しないので、

TabItemWithCloseStyle

という名前のスタイルがデフォルトになり、このスタイルを StyleBook から探すようになります。
なので、先ほど作った Style の名前を TabItemWithCloseStyle とする必要があります。

それでは、まず、DoSetWidth というメソッドを見てみます。
ここを修正すると Tab の大きさを変更できます。

function TTabItemWithClose.DoSetWidth(var ioValue: Single; iNewValue: single;
var ioLastValue: Single): boolean;
begin
if (FCloseBtn <> nil) then
iNewValue := iNewValue + FCloseBtn.Width * 1.5;
 
Result := inherited;
end;

このように変更すると CloseButton の幅の 1.5 倍が足された幅が新しい Tab の幅になります。
それでは、CloseButton はどこで取得するかというと ApplyStyle で取得します。

procedure TTabItemWithClose.ApplyStyle;
var
CloseBtn: TFmxObject;
begin
inherited;
 
CloseBtn := FindStyleResource(STYLE_COLOR_BUTTON);
if (CloseBtn <> nil) and (CloseBtn is TCustomButton) then begin
FCloseBtn := TCustomButton(CloseBtn);
FCloseBtn.OnClick := DoCloseBtnClick;
end;
end;

ApplyStyle は、スタイルを適用するときに呼ばれるメソッドです。
そして、FindStyleResource を使うことで、指定したスタイルを「コントロールとして」取得できます。
なので、ソースのように TCustomButton にキャストしてやって、閉じるボタンのインスタンスを保存します。

あとは、FreeStyle メソッドが呼ばれると Style が無効になるので、ここで FCloseButton に nil を代入しています。
また、initialization 部でコンポーネントを登録します。

initialization
begin
RegisterFmxClasses([TTabItemWithClose], [TTabControl]);
end;

登録しないと、IDE で作成された TTabItemWithClose が起動時やプロジェクト読み込み時にエラーになります。

基本的には、これでできあがりです。

他のメソッドは、僕が Style を一々作り直すのがメンドクサイので、そのための機構が入っています。
これについては、ソースをご覧ください。

そして、最後に、コンポーネントエディタを作らなくてはなりません。
作らないと、IDE で編集すると、TTabItemWithClose は作成されず TTabItem しか作成されません!

ということで、コンポーネントエディタを作りますが……これも DEKO さんが Advent Calendar で発表されているので、そちらをご覧ください!
僕が書くより、よっぽど詳しいです!!
コンポーネントとして登録する方法なども、リンクがあります!

では、できたコンポーネントが登録されたとして、これを使うためには、先ほど保存した TabItemWithCloseStyle を StyleBook に「追加」を押して、読み込ませます。



それで、適用して閉じたあと、コンポーネントエディタから TTabItemWithClose を作ると……



できました!!!

ちょっと駆け足になったり、はしょったりしましたが、こんな感じで FireMonkey のコンポーネントを作り出せます!
また、記事にすると長いですが、このコンポーネントを作るのに、実質1時間も掛かっていません!

簡単に作れるので、みなさんも、是非 FireMonkey でコンポーネントを作ってみて下さい!

2013年12月19日木曜日

Delphi の Interface

Delphi Advent Calendar 2013 12/19 の記事です。

※本文最後に追記あり(2013-12-20)

Delphi の Interface が使えないとほざいているのは誰だぁっ!

ということで、とりあえずできることを、つらつらっと書いてみましたよ。
詳しくは、コメントを見てください!

program Project1;
 
uses
System.SysUtils;
 
type
// GUID を指定すると Interface と GUID を結びつけることができます。
// これは主に COM をサポートするための機能です。
// (COM は Interface を GUID で管理します)
// にも関わらず GUID を付けることが推奨されています。
// 例えば GUID をキーに Dictionary として管理したりするためです。
// TPlatformServices.AddPlatformService のソースが参考になります。
IFoo = interface
['{174C7089-888D-4B3A-A348-DBAEC0AA70A5}']
// Property も宣言できますが、Interface は変数を宣言できないので
// reader / writer はメソッドのみ指定できます
function GetBar: String;
property Bar: String read GetBar;
end;
 
IDummy = interface
['{7820C3D8-0DBC-4506-81FF-4FB9B21F6959}']
function GetBar: String;
end;
 
// IFoo を実装するクラス
// TAggregatedObject は後述する TInterfacedObject の Reference Counter を
// 共有するクラスです
TFooImpl = class(TAggregatedObject, IFoo)
private
function GetBar: String;
end;
 
// IFoo を実装するクラス2
// IDummy という実験のためのダミークラスも実装してみています。
// 異なる Interface が同じメソッド名を持つ場合は、こんな風に解決できます。
TFooImpl2 = class(TAggregatedObject, IFoo, IDummy)
private
function IFooGetBar: String;
function IDummyGetBar: String;
function IFoo.GetBar = IFooGetBar; // IFoo と IDummy の GetBar に
function IDummy.GetBar = IDummyGetBar; // それぞれの実装を代入している
end;
 
// TFooImpl か TFooImpl2 に IFoo の実装を委譲してるクラス
// 委譲すると自身は IFoo を実装しなくていい!
// TInterfacedObject を継承すると RefCounter によって自動的に破棄されるよ
// 流行りの ARC と同じ仕組みを随分前から実装してたんだよ!
// (COM がそうなんだけど)
TBaz = class(TInterfacedObject, IFoo)
private
FFoo: IFoo;
public
constructor Create; reintroduce;
property FooIntf: IFoo read FFoo implements IFoo;
end;
 
{ TFooImple }
function TFooImpl.GetBar: String;
begin
Result := 'Bar';
end;
 
{ TFooImple2 }
function TFooImpl2.IDummyGetBar: String;
begin
Result := 'Dummy !';
end;
 
function TFooImpl2.IFooGetBar: String;
begin
Result := 'Bar 2!';
end;
 
 
{ TBaz }
constructor TBaz.Create;
begin
inherited;
 
Randomize;
 
// (ここではランダムだけど)目的に応じて委譲先を変更できる!
if (Random(2) = 0) then
FFoo := TFooImpl.Create(Self) // TAggregatedObject は RefCounter を
else // 共有するインスタンスを要求するよ
FFoo := TFooImpl2.Create(Self);
end;
 
{ Main }
var
Foo: IFoo;
GUID: TGUID;
Obj: TObject;
begin
// Inteface に代入, TBaz 自体は IFoo を実装していないのに代入できる!
Foo := TBaz.Create;
Writeln(Foo.Bar);
 
// Inteface を TGUID に代入できる!
GUID := IFoo;
Writeln(GUIDToString(GUID));
 
// Inteface から元の型を調べてみる
Writeln((Foo as TObject).ClassName); // Implements からでも元の型が取れる!
 
// Inteface から元の型を取りだして、再生成したりもできちゃう
// (まあこれは Inteface 関係ないけど…)
Obj := (Foo as TObject).ClassType.Create;
Writeln(Obj.ClassName);
 
Readln;
(* 実行結果 - Bar 2! と出ているところは Bar と出ることもあるよ
 
Bar 2!
{174C7089-888D-4B3A-A348-DBAEC0AA70A5}
TBaz
TBaz
 
*)
end.

個人的に面白いなあと思うのは「委譲」の仕組みと「Interface から元の型を取り出せる」ところかな-。
Java では Interface から元の Class を取り出すなんて不可能だからね!(間違ってました。本文最後に追記)
※ヘルプには「委譲は Win32 のみ」と書いてあるけど、普通に Win/OSX/iOS/Android で動作しました。

あと、今回の iOS / Android 対応で TinterfacedObject の仕組みが非常に活きているのが感慨深い…
COM のために実装した様々なことがここに来てすごく活きている!
同じく COM のために実装した dispinterface は、プラットフォーム依存ですと警告が出るようになってたよ…
ちなみに、Interface は FireMonkey でも使われまくっていてるんですよ!!
各 Platform 依存部と、それを一般化する部分では Interface 無しには実装できませんぜ!

追記:0213-12-20
Java でも、次のようにすれば Interface から元の Class を取り出せるよ!と教えていただきました。
MyInterface intf = new MyClass();
System.out.println(((Object)intf).getClass().getName());
僕の Java スキルもまだまだです……

2013年12月1日日曜日

VCL も地味に進化しているんですよ!

Delphi Advent Calendar 2013 12/01 の記事です。

FireMonkey にばかり目が行きがちですが、VCL も地味に進化しているんですよ!!

ということで、2007 以降に追加された機能で、僕がつい最近まで知らなかった機能をランキングでご紹介!


第3位
TLinkLabel



HTML リンク形式でクリックできるラベル!
みんな自分で作っていたよね!!
いつ追加されたのか、ちょっと判りませんでしたが……

使い方はすごく簡単で、Caption プロパティに A タグを使ってリンク先を書くだけです。
例えば…
" 右をクリック→ <a href="http://www.serialgames.co.jp/">株式会社シリアルゲームズ</a>"
こんな感じです。
下線部をクリックすると OnLinkClick イベントが発生するので、そこに↓こんな感じの処理を記述してやればOKです。
procedure TForm1.LinkLabel1LinkClick(
Sender: TObject;
const Link: string;
LinkType: TSysLinkType);
begin
// Link は id か href の中身
// LinkType は Link の種類
// sltID は id 属性が指定されていた場合
// sltURL は id 以外
 
ShellExecute(
Handle,
'open',
PChar(Link),
nil,
nil,
SW_SHOW);
end;
ここでは、ブラウザを開くようにしましたが、もちろんアプリケーションのナビゲートにも使えるわけです!

DEKO 氏よりご指摘を頂きましたので、追記いたします!
TLinkLabel が追加されたのは Delphi 2009 からとのこと!
そして、Xp でも使えるけど、テーマが有効である必要があるということです。
テーマは、プロジェクトオプション→アプリケーション→ランタイムテーマ→ランタイムテーマを有効にする、ですね!


第2位
TButton 驚愕の進化!



VCL のボタンは色が変えられないだとか、画像が載せられないだとか、そんな時代は終わっていました!(色については後述の1位をご覧ください)
むしろ、TBitButton の時代が終わっていた!
上の画像を見ていただければ一目瞭然ですが、色々と機能が拡張されています。

これらは、TButton.Styleプロパティで実現されています。
TButton.Style はTButtonStyle 型になっていて以下の3つがあります。

bsPushButton いわゆる普通のボタン
bsCommandLink  コマンドアイコンが付くボタン(インストーラなんかで見ます)
bsSplitButton 右側をクリックすると TPopupMenu を表示するボタン

そして、その他にも Images プロパティImageIndex プロパティを組み合わせると画像を表示できます!(他のプロパティで画像の位置を指定したり、Disable 時の画像を指定したりできます)
しかも画像をご覧頂くとわかるとおり、きちんとα値(透明度)も効きます!

FireMonkey を使わなくても、かなり美麗なアプリケーションを組めますね。
ただし!Vista 以降で有効!つまり! Xp では使えません!!
あれぇ…じゃあ VCL の機能というより Windows 機能なんじゃあ…


第1位
当然の VCL Style!

以下をご覧ください
えええええー!最後それえええええ!?
知らなかった機能を、って書いてあったのに、知ってる機能だしいいいいい!

そんなこんなで、2013年もあと少し。
今後とも、僕とブログと男と女、Delphi をよろしくお願いいたします。

2013年9月19日木曜日

Hello world maniacs !

CodeIQ の @cielavenir さんからの言語指定の問題「Restricted Words - 出力したい値をどうやって手に入れるか?」に挑戦しました。

問題は
標準出力に
Hello World
と出力するプログラムを作成して下さい。

ただし、数値、文字及び文字列リテラルを解答に含めることはできません。
Perlのqqやqw、Rubyの%Q、%q、%wなども避けたほうが評価が高くなります。
言語仕様をフル活用して下さい!
というものです。
ここで注目したいのが!!
プログラミング言語は
AppleScript(osascript)/C/C++/C#/Clojure/D/Erlang/Fortran/Go/Groovy/Haskell/
Hello Algorithm/HSP/Java/JavaScript(Node.js)/Kuin/Lisp/Lua/OCaml/Pascal/
Perl/PHP/Pike/Python/R/Ruby/Scala/Scheme/Smalltalk/VB.Net
のいずれかを使用して下さい。指定された言語以外での解答は評価されません。

Pascal キター!!!!!
いままで CodeIQ では Pascal / Delphi は全く相手にされてなかったのに!!
ということで、軽く挑戦してみることにしました。

すぐに思いついた方法は3通り

  1. brainf*ck のようなチューリングマシン的な方法
  2. リフレクションを使ってクラスやメソッド名から抽出する方法
  3. 文字コードを列挙型で表す方法

このうち、1の方法は簡単すぎてつまらないので却下。
2の方法もあくまで言語指定が Pascal なので却下。
ということで、3の方法で行くことにしました。

ここで面倒だったのが言語指定が Pascal であること。
Pure Pascal では type とか var といったブロックは位置が決まっているし、Program には input / output を付けないといけないとか、const 指定子が使えないとか色々あります。
ということで、1回 Delphi でコンパイルした後 gpc 使ってコンパイルを試しました……ところが!!
gpc は最早 Pure Pascal ではなく Borland 拡張……つまり Delphi の文法が多分に採り入れられていたのです!!
すごいすんなりコンパイルされちゃう!! \(^o^)/
といっても、これが ISO 標準であり、これこそが Pure Pascal なのかなあなんて思ったりもしたのですが、 Pure Pascal は初版の物だろう!!ファースト以外は認めない!!……ということで、僕の頭の中にある Pure Pascal 文法で書きました。
それが以下になります。

program HelloWorld(Output);
 
type
THex = (
hx00, hx01, hx02, hx03, hx04, hx05, hx06, hx07,
hx08, hx09, hx0a, hx0b, hx0c, hx0d, hx0e, hx0f,
hxCount
);
 
procedure WriteChar(h, l: THex);
begin
Write(Chr(Ord(h) * Ord(hxCount) + Ord(l)));
end;
 
begin
WriteChar(hx04, hx08); // H
WriteChar(hx06, hx05); // e
WriteChar(hx06, hx0c); // l
WriteChar(hx06, hx0c); // l
WriteChar(hx06, hx0f); // o
WriteChar(hx02, hx00); //
WriteChar(hx05, hx07); // W
WriteChar(hx06, hx0f); // o
WriteChar(hx07, hx02); // r
WriteChar(hx06, hx0c); // l
WriteChar(hx06, hx04); // d
end.

まあ、どっちにせよ、あんまり面白くはならなかったのですが……。
特筆すべき事は何もないです。
ちょっと悔やまれるのは、hxCount なんてのをつくったところ。
そうじゃなくて、shl Ord(hx04) ってすれば良かった。

出題者の @cielavenir さんのコードはこちら
その他の言語は一個上に。

1 を取得してから、それを使って他の数を取得、という方法のようですね。
それで、ちょっと疑問なのが、Delphi や gpc ではコンパイル通るんだけど、Integer を Char にキャストして値を得ていること。
Pure Pascal だと、これできないんじゃなかったかなあ……そのための Chr 関数な訳だし……。
C 系で言うところの 1byte を表す型は Byte っていう型があるんですよ-。
2013/09/19 13:10 追記
cielavenir さんに修正していただきました!

後日、解説記事がアップされるそうなので、解説記事がアップされたら、ここに追記します!

2013年7月1日月曜日

constructor 制約について

Facebook の Delphi Talks で「型制約について、疑問があります」というスレッドが立ちました。
内容は「ジェネリクス型で型指定するときに、レコード型と値型と文字列型、のみ指定することは可能か?」という話でした。
これについては、スレッド中で「できない」と、結論が出ました。
ただ、このスレッド中で「constructor 制約がついたジェネリクス型に文字列型や値型が渡せる」という事が判りました(僕が知りました)。
と、いうことで、ちょっと調べてみました。

constructor 制約とは、下記のようにジェネリクスの型指定に constructor と書く事で定義される制約です。

type
TConstructorConstraint<T: constructor> = class
end;

具体的には、この制約を課されると「引数無しの Create を持った型しか指定できない」という制約です。
この制約の最大の特徴は T が 「どんな型か全く知らなくても」インスタンスを 生成できる、ということです。
これによって、何も知らなくても有効なインスタンスの存在を保証できます。

……と、まあ原義はさておき、上述の様にプリミティブ型である String 型や Integer 型を指定できるのです。
当然プリミティブな型なので Create なんてコンストラクタメソッドを持っているわけがありません。
これはどういった事でしょうか。
これを検証するために、下記のコードを書きました。

unit Unit1;
 
interface
 
type
// interface 部に定義すると全員に見える
// 引数無しの Create は持っていないクラス
TBar = class
public
constructor Create(const iDummy: Integer); reintroduce;
end;
 
procedure Test;
 
implementation
 
uses
System.Rtti;
 
type
// constructor 制約を課したジェネリック型クラス
TConstructorConstraint<T: constructor> = class
private
FValue: T;
public
constructor Create; reintroduce;
function ToString: String; override;
end;
 
// 引数無しの Create を持つクラス
TFoo = class
public
constructor Create; reintroduce;
end;
 
// 動的配列型
TStringDynArray = array of String;
 
// 集合型
TFactor = (Windows, MacOSX, Android, iOS, WindowsPhone);
TSet = set of TFactor;
 
{ TConstructorConstraint<T> }
 
constructor TConstructorConstraint<T>.Create;
begin
inherited Create;
 
// T の型は知らないけど Create を呼び出せる!
FValue := T.Create;
end;
 
// T の型情報を出力する
function TConstructorConstraint<T>.ToString: String;
var
Rtti: TRttiContext;
Field: TRttiField;
FieldType: TRttiType;
begin
Result := '';
 
Rtti := TRttiContext.Create;
try
Field := Rtti.GetType(ClassInfo).GetField('FValue');
FieldType := Field.FieldType;
 
Result := Field.Name + ': ' + FieldType.ToString + ';';
 
if (FieldType.IsPublicType) then
Result := Result + ' Public;';
 
if (FieldType.IsManaged) then
Result := Result + ' Manged;';
 
if (FieldType.IsInstance) then
Result := Result + ' Instance;';
 
if (FieldType.IsOrdinal) then
Result := Result + ' Ordinal;';
 
// Record は constructor 制約では指定できないので、ここは表示されない
if (FieldType.IsRecord) then
Result := Result + ' Record;';
 
if (FieldType.IsSet) then
Result := Result + ' Set;';
finally
Rtti.Free;
end;
end;
 
{ TFoo }
 
constructor TFoo.Create;
begin
inherited Create;
 
// 生成時に表示される
Writeln('TFoo Created !');
end;
 
{ TBar }
 
constructor TBar.Create(const iDummy: Integer);
begin
inherited Create;
 
// 引数無しの Create ではないため、表示されない
Writeln('TBar Created !');
end;
 
// 生成して情報を出力する
procedure Test;
var
Foo: TConstructorConstraint<TFoo>;
Bar: TConstructorConstraint<TBar>;
Str: TConstructorConstraint<String>;
Int: TConstructorConstraint<Integer>;
Ary: TConstructorConstraint<TStringDynArray>;
Sets: TConstructorConstraint<TSet>;
begin
Foo := nil;
Bar := nil;
Str := nil;
Int := nil;
Ary := nil;
Sets := nil;
try
Foo := TConstructorConstraint<TFoo>.Create;
Bar := TConstructorConstraint<TBar>.Create;
Str := TConstructorConstraint<String>.Create;
Int := TConstructorConstraint<Integer>.Create;
Ary := TConstructorConstraint<TStringDynArray>.Create;
Sets := TConstructorConstraint<TSet>.Create;
 
Writeln(Foo.ToString);
Writeln(Bar.ToString);
Writeln(Str.ToString);
Writeln(Int.ToString);
Writeln(Ary.ToString);
Writeln(Sets.ToString);
 
Readln;
finally
Sets.Free;
Ary.Free;
Int.Free;
Str.Free;
Bar.Free;
Foo.Free;
end;
end;
 
end.

様々なジェネリック型を定義して、生成、その情報を出力、とするだけのプログラムです。
ここでは、クラス型、文字列型、整数型、動的配列型、集合型、を指定してみました。
重要なのは、クラス型以外、Create なんてメソッドは持っていない!ということです。

では、このプログラムを動かしてみると…

TFoo Created !
FValue: TFoo; Instance;
FValue: TBar; Public; Instance;
FValue: string; Public; Manged;
FValue: Integer; Public; Ordinal;
FValue: TStringDynArray; Manged;
FValue: TSet; Set;

こんな風になりました!
TFoo, TBar はクラスなので "Instance" と表示されています。
また、TBar は、interface 部で定義されているので公開されている型 "Public" と表示されています。
そして、string と動的配列型は "Managed" と表示されています。これはコンパイラがその型の生成と廃棄を担っていることを示します。
つまり、string と動的配列型は、本当は管理されたメモリを持つ参照型であるため、このように表示されています。
また、Integer は Ordinal…順序型, 集合型は Set と出ました。これはそれぞれの型そのものですね。

ということで、本当に値型や文字列型が Create というメソッドで生成されてしまいました。
本来、そのようなメソッドを持たない型にも関わらず、です。

では、これらの型の生成は実際にはどのようなコードになっているのでしょうか?
それを見るために CPU ビューで逆アセンブルされたコードを見てみました。

// TFoo の生成
Project1.dpr.28: FValue := T.Create;
00407D7A B201             mov dl,$01
00407D7C A158724000       mov eax,[$00407258]
00407D81 E85AF6FFFF       call TFoo.Create      // 初期化コード
00407D86 8B55FC           mov edx,[ebp-$04]
00407D89 894204           mov [edx+$04],eax


// TBar の生成
Project1.dpr.28: FValue := T.Create;
00407DCE B201             mov dl,$01
00407DD0 A114734000       mov eax,[$00407314]
00407DD5 E8BACDFFFF       call TObject.Create   // 初期化コード
00407DDA 8B55FC           mov edx,[ebp-$04]
00407DDD 894204           mov [edx+$04],eax


// 文字列の生成
Project1.dpr.28: FValue := T.Create;
00407E22 8B45FC           mov eax,[ebp-$04]
00407E25 83C004           add eax,$04
00407E28 E843DDFFFF       call @UStrClr         // 初期化コード


// 整数型(順序型)の生成
Project1.dpr.28: FValue := T.Create;
00407E6E 8B45FC           mov eax,[ebp-$04]
00407E71 33D2             xor edx,edx           // 初期化コード
00407E73 895004           mov [eax+$04],edx


// 動的配列の生成
Unit1.pas.50: FValue := T.Create;
004D50F6 8B45FC           mov eax,[ebp-$04]
004D50F9 83C004           add eax,$04
004D50FC 8B1500394D00     mov edx,[$004d3900]
004D5102 E87D68F3FF       call @DynArrayClear   // 初期化コード


// 集合の生成
Unit1.pas.50: FValue := T.Create;
004D540E 8B45FC           mov eax,[ebp-$04]
004D5411 8A153C544D00     mov dl,[$004d543c]    // 初期化コード?
004D5417 885004           mov [eax+$04],dl

なんと、コンパイラマジックによって自動的にそれぞれの型の初期化コードが走っていました。
文字列や動的配列であれば、それらの内容をクリアする関数をコールしています。
順序型は 0 が代入されています(同じレジスタを xor するとレジスタの内容は 0 になる)。
集合型については、ちょっと判りませんが……
また、TFoo, TBaz については、それぞれ「引数無しの Create」が呼ばれています。
TFoo は定義されているので良いですが TBaz の場合基底クラスである TObject の Create が呼ばれました。
クラス型は全て TObject から派生しているので、constructor で制限を掛けても全てのクラスが生成できてしまいます。その Create が有効如何に関わらずです。
これは、constructor 制約の意義に関わる注意点です……実質意味が無い気がします……

ということで、 constructor 制約で実際に生成されるコードを見てみました。
結論としては、コンパイラが上手いことやってくれてる、っていうだけのお話でした。

ちなみに <T: class, constructor> というように class の制限も一緒につけると値型や文字列型は指定できなくなります。
また、<T: record, constructor> とすると、プリミティブ型しか指定できなくなります。つまり、クラス型は指定できません。

constructor 制約に値型や文字列型がわたせるのは、上記の "class", "record" のどちらも指定していないため、どっちも通るよ!っていう事なのだと思います。

それと、軽く流してしまいましたがジェネリックで指定された型が何型なのかは拡張 RTTI メソッド群を使えば取得できます。
詳しくは、上記のコード中の TConstructorConstrain クラスの ToString メソッドを参照してください。

2013年6月15日土曜日

XE4 Update 1

2013/06/12 に XE4 Update 1 が発表されました。

XE4 Update 1

XE4 Update 1 リリースノート

これで、FireMonkey の「最小化問題」と「タスクバーのコンテキストメニュー問題」は解決したのですが、まだ問題が発生しているようです。
それは、タスクバーのボタンを押しても、最小化ができない、という問題です。
通常、タスクバーでアプリケーションのボタンを押すと、アプリケーションが最小化し、もう一度押すと元のサイズに戻る、という動作をしますが、今回の Update でも、この問題は治っていないようです。
僕も気づいていませんでしたが…。
というのも、前のバージョンでは先の記事通り、そもそもタスクバーのボタンが上手く動作していなかったためです。

多分、直すのはそんなに難しくないと思われるので、時間があったら FixFMXForm.pas をアップデートしたいと思います。

ちなみに、現状の FixFMXForm を使っても、治ると言えば治ります。

2013年5月28日火曜日

Delphi で iOS を開発するためのマシン構成について。

とても今更ですが、僕がどのような構成で iOS アプリを開発しているか、そのマシン構成図を上げておきます。
VAIO Z は "Power Media Dock" という拡張ドックがあるので、その HDMI / USB ポートと KVM スイッチが常時接続された状態になっています。

VAIO Z シリーズは、どうやら終了のようです。
外付け拡張ドックに GPU / HDMI / USB 3.0 / Blueray を逃すというアイデアは秀逸でした。
個人的には大好きな一台です。

ちなみに、これも Delphi ML で貼った図になります。
図中の Mac mini は、最低ランクの一番安いものです(型番:MD387J/A)。



2013年5月27日月曜日

FireMonkey の最小化問題と右クリック問題に対処する


元々リリースの早い段階から FireMonkey3 を Windows で使うと最小化時にタスクバーに収まらないという問題があることが知られていました。



今回さらに、Delphi ML で『タスクバーの右クリックで出てくるシステムメニューで「ウィンドウを閉じる」を選択してもアプリが終わらない』という問題が指摘されました。



実は2つとも原因は同じです。
原因は、TApplication の設計上のミスです。

このバグが出た背景として、MacOS X 対応が上げられます。
MacOS X は、メインフォームを閉じてもアプリが終了しません。
あくまで、メニューからアプリケーションの終了を選ばないと、終了しないのです!
しかし、Windows では、メインフォームの終了は即ちアプリケーションの終了です。
TApplication は Win と Mac 2つの環境で違う立ち振る舞いをすべきですが、今回は Windows への対応が甘くなっていました。
それは、ベータテスターの主な注目点が iOS 対応だったためだと考えています。
僕自身も Windows でのテストはせずに iOS と MacOS X 部分のみテストしていました。
今後のベータテストでは、Windows もしっかりと見ていく必要がありそうです。

最小化できない問題について


1.TForm の Owner に TApplication が設定されている
2.TForm の WndParent には DesktopWindow が設定されている

という2つの事象から発生しています。
オーナーが設定されている、かつ、拡張ウィンドウスタイルに WS_EX_APPWINDOW が設定されていないので、タスクバーにはオーナーウィンドウ(TApplication)のみが表示されます。
しかし、WndParent(親ウィンドウ)に DesktopWindow が指定されているため、最小化するとデスクトップウィンドウ内の子フォームとして最小化されてしまいます。

システムメニューで閉じない問題について


最小化できない問題のところで、タスクバーにはオーナーウィンドウ(TApplication)が表示されていると記しました。
もうおわかりかと思いますが、タスクバーを右クリックして出てきたシステムメニューは TApplication のモノです。



システムメニューをクリックしても TForm に WM_SYSCOMMAND メッセージは送出されず、TApplication に対して送出されます。
TApplication は、受け取った WM_SYSCOMMAND を、そのまま DefWindowProc に流しているだけなので、TApplication のウィンドウハンドルは閉じてしまい、無効になります。
しかし、プロセスを終了させていないので、プロセスは残り続けます。
この問題を解決するためには TApplication が WM_SYSCOMMAND を受け取った時に メインフォームの Close を呼ぶようにしてやるだけです。

ただ、それだけだと最小化の問題は解決できません。
そこで、今回、下記のユニットを作りました。
ユニット uFixFMXForm.pas は、uses するだけで、上記の2つの問題を解決します。
このユニットは Application のタスクバーボタンを消して、フォームのタスクバーボタンを表示する、という解決方法をとりました。

ただし、副作用があって TApplication がオーナーのウィンドウは全てトップレベルウィンドウになります。
TApplication がオーナーでは無い ShowMessage などのダイアログ系はトップレベルにならないので、実用上の問題にはならないでしょう。

詳細はコード中のコメントを参照してください。

unit uFixFMXForm;
 
interface
 
implementation
 
// Win32 API を使いまくるので Windows 以外ではコンパイルされないようにする
{$IFDEF MSWINDOWS}
uses
System.SysUtils,
Winapi.Messages, Winapi.Windows;
 
var
GHookHandle: HHOOK; // フックハンドル
GAppWnd: HWND = 0; // TApplication のハンドル
 
// SendMessage でメッセージが送られたときに呼ばれる
function CallWndProc(
iNCode: Integer;
iWParam: WPARAM;
iLParam: LPARAM): LRESULT; stdcall;
var
ActiveThreadID: DWORD;
TargetID: DWORD;
begin
// フックチェインの他のフックハンドラを先に呼んでしまう
Result := CallNextHookEx(GHookHandle, iNCode, iWParam, iLParam);
 
// nCode が 0 以下の時は処理してはいけない
if (iNCode < 0) then
Exit;
 
// iLParam には CWPSTRUCT 型へのポインタが格納されている
// この型には SendMessage で送られたメッセージの詳細が入っている
with PCWPStruct(iLParam)^ do begin
case message of
// ウィンドウができるとき
WM_CREATE: begin
with PCREATESTRUCT(lParam)^ do begin
// まだ TApplication が生成されていない、かつ「ウィンドウクラス」が
// TFMAppClass(FireMonkey の TApplication のクラス名)だったとき
if (GAppWnd = 0) and (StrComp(lpszClass, 'TFMAppClass') = 0) then
// hwnd を TApplication のウィンドウハンドルとして保存しておく
GAppWnd := hwnd
else begin
// もしも TApplication が visible(=タスクバーに表示されている)
// なら、非表示にする!
if (GAppWnd <> 0) and (IsWindowVisible(GAppWnd)) then
ShowWindow(GAppWnd, SW_HIDE);
 
// オーナーウィンドウが TApplication なら TForm のインスタンスと
// みなして拡張ウィンドウスタイルに WS_EX_APPWINDOW を設定する
// WS_EX_APPWINDOW が設定されたフォームは、トップレベルウィンドウ
// となるので、タスクバーに表示される
if (GetWindow(hwnd, GW_OWNER) = GAppWnd) then
SetWindowLong(
hwnd,
GWL_EXSTYLE,
GetWindowLong(hwnd, GWL_EXSTYLE) or WS_EX_APPWINDOW);
end;
end;
end;
 
// ウィンドウが表示されるとき
WM_SHOWWINDOW: begin
// オーナーがあるのに拡張スタイルに WS_EX_APPWINDOW を指定していると
// 最前面に表示されない事があるので、ウィンドウが表示されるときは
// 強制的に最前面にする
// 強制最前面化処理は、下記のように AttachThreadInput を使うが
// 詳細は省略
if (GetWindow(hwnd, GW_OWNER) = GAppWnd) then begin
ActiveThreadID := GetWindowThreadProcessId(GetForegroundWindow, nil);
TargetID := GetWindowThreadProcessId(hwnd, nil);
 
AttachThreadInput(TargetID, ActiveThreadID, True);
try
SetForegroundWindow(hwnd);
SetActiveWindow(hwnd);
finally
AttachThreadInput(TargetID, ActiveThreadID, False);
end;
end;
end;
end;
end;
end;
 
initialization
begin
// WH_CALLWNDPROC フックを仕掛ける
// WH_CALLWNDPROC は SendMessage が呼ばれたときに呼ばれるフック
GHookHandle :=
SetWindowsHookEx(WH_CALLWNDPROC, CallWndProc, 0, GetCurrentThreadID);
end;
 
finalization
begin
// フックを解放
UnhookWIndowsHookEx(GHookHandle);
end;
{$ENDIF}
 
end.

と、まあ今回このようなユニットを作りましたが、近日リリースされるであろう XE4 Update1 で、このバグは治っている事でしょう。
ですから、無理してこのユニットを使わず、Update1 を待っても良いかも知れません。

2013年4月13日土曜日

Prezi を使ってみたよ

Prezi を使ってみたよ。

Prezi のサンプルなので中身の説明は超いい加減!


2013年4月3日水曜日

もうすぐ再開します!

もう4月!
この一月以上更新が無かった理由が、もうすぐ終わるので、それに関連した話題とかも上げていきます!
しばし待たれよ!

2013年2月13日水曜日

IME のメッセージを Windows Hook で取得する


Delphi-ML で、IME の変換スタートと終了を知りたい、という投稿がありました。
全ての Edit をサブクラス化して実装しようとされていたのですが、それでは非常に大変だと思い、Windows Hook による方法を投稿しました。

それが、以下のコードです。

unit uIMEStartEnd;
 
interface
 
uses
Winapi.Windows;
 
type
// IME の開始と終了を知らせるイベント
TIMEStartEndNotifyEvent =
procedure(const iWnd: HWND; const iStart: Boolean) of object;
 
// イベントを受け取るイベントリスナを設定・削除する
procedure AddIMEEventListener(const iEvent: TIMEStartEndNotifyEvent);
procedure RemoveIMEEventListener(const iEvent: TIMEStartEndNotifyEvent);
 
implementation
 
uses
Winapi.Messages, Vcl.Controls, System.Generics.Collections;
 
var
// WindowsHook のハンドル
GHookHandle: HHOOK;
// イベントリスナのリスト
GHandlers: TList<TIMEStartEndNotifyEvent>;
// イベントリスナを追加
procedure AddIMEEventListener(const iEvent: TIMEStartEndNotifyEvent);
begin
if (GHandlers.IndexOf(iEvent) < 0) then
GHandlers.Add(iEvent);
end;
 
// イベントリスナを削除
procedure RemoveIMEEventListener(const iEvent: TIMEStartEndNotifyEvent);
begin
if (GHandlers.IndexOf(iEvent) > -1) then
GHandlers.Remove(iEvent);
end;
 
// イベントリスナを呼び出す
// iWnd IME メッセージを受け取ったウィンドウ
// iStart 開始の場合は True
procedure CallEventHandlers(const iWnd: HWND; const iStart: Boolean);
var
Handler: TIMEStartEndNotifyEvent;
begin
for Handler in GHandlers do
Handler(iWnd, iStart);
end;
 
// Hook のメイン関数
function CallWndProc(
iNCode: Integer;
iWParam: WPARAM;
iLParam: LPARAM): LRESULT; stdcall;
begin
// 先に、次のフックチェインを呼び出してしまう
Result := CallNextHookEx(GHookHandle, iNCode, iWParam, iLParam);
 
// iNCode が 0 以下ならフックは作業してはならない
if (iNCode < 0) then
Exit;
 
// lParam は CWPStruct 形式で、メッセージが入っている
with PCWPStruct(iLParam)^ do begin
case message of
WM_IME_STARTCOMPOSITION: begin
// IME 変換開始
CallEventHandlers(hwnd, True);
end;
 
WM_IME_ENDCOMPOSITION: begin
// IME 変換終了
CallEventHandlers(hwnd, False);
end;
end;
end;
end;
 
initialization
begin
// イベントハンドラを管理するリストを作成
GHandlers := TList<TIMEStartEndNotifyEvent>.Create;
 
// WindowsHook
GHookHandle :=
SetWindowsHookEx(WH_CALLWNDPROC, CallWndProc, 0, GetCurrentThreadID);
end;
 
finalization
begin
// Hook を解放
UnhookWIndowsHookEx(GHookHandle);
 
// リストを破棄
GHandlers.Free;
end;
 
end.

具体的にはソースコードのコメントを参照してほしいのですが、一点だけ Windows Hook について説明します。
Windows Hook は Windows の作業に割り込む機構です。
例えば、キーボードの入力があった時や、新しいウィンドウが開くときなど本来アプリケーション側からは見えない Windows の作業に割り込むことができます。
Windows Hook を設定するためには SetWindowsHookEx API を使います。
SetWindowsHookEx の説明を見て頂ければわかるように、様々なフックがあります。
今回は、その中で WH_CALLWNDPROC フックを使う事にしました。
このフックは Window Procedure にメッセージが渡されるタイミングで呼び出されます。
そのタイミングとはいつかというと、具体的には SendMessage API が呼ばれた時です。

PostMessage API を使った場合は、WH_GETMESSAGE フックが使えます。

WH_CALLWNDPROC フックを使うのは IME のメッセージは SendMessage で送られるためです。
そして、今回のソースでは SetWindowsHookEx の3番目の引数に 0 を指定しています。
ここに 0 を指定して、次の引数に現在の Thread ID を指定すると、現在のスレッドで処理される SendMessage についてフックされるます。
この Unit の Initialization 節はメインスレッドから呼ばれるので、メインスレッド(GUI の操作・表示をするスレッド)がメッセージを受け取る度に、CallWndProc 関数が呼ばれることになります。
その結果、Edit などで IME の処理が行われると、それを感知してイベントを発行できます。

また、SetWindowsHookEx の3番目の引数に HInstance を指定してフックする DLL を作ると、全プロセスに結びつくフックを作る事ができます。
これによって、他のプログラムのメッセージを見ることもできます。

これをグローバルフック DLL と呼びます。
グローバルフック DLL の作成については、また次回!


2013年1月31日木曜日

ColorCheckbox を StyleElements で実装できるかどうか

DEKO さんの「TCheckBox の文字色と背景色を変えたい (Delphi) 」で、XE3 であれば StyleElements があるので VCL Style 適用時であれば比較的簡単に実装できるのではないかと思い、やってみました。

結論からいうと、そうでもなかったです。

まず、VCL Style を設定しているアプリケーションのメインフォームに、次の画像のように CheckBox1, CheckBox2 を置きました。
そして、CheckBox2 の StyleElements を [] にしました。



これを実行すると以下のようになりました。



CheckBox2 は、VCL Style ではなく、Windows のデフォルトで表示されています。
全ての Style を無効にしたので、当然の結果です。

次に、StyleElements に [seClient, seBorder] を指定して、フォントにはスタイルが要りません!宣言をします。
そして、Font.Color プロパティに clAqua を入れ、実行すると次のようになりました。



このように、フォント色は簡単に変更できることが判ります。

では、ここで StyleElements から seClient を抜いて、Color プロパティに clRed を指定してやれば、クライアント領域が赤で塗りつぶされそうな気がします。

しかし、結果は、下図のようになり、期待した動作にはなりませんでした。



実はクライアント領域は TStyleHook の方で seClient が入っていなければ、元々の動作をするように組まれているのです。

そのため、seClient を抜いても、Color プロパティで背景は描画されません。

TLabel の場合、元々背景色を塗りつぶす機能があるため、StyleElements から seClient を抜き、Transparent プロパティを False に設定すると、指定した色で背景が描画できます。



これを解決するためには、TCheckBox 用の新しい StyleHook を作る他ありません。

そこで、作ってみました。
できあがった StyleHook のソースは以下のようになります。

unit uCheckBoxStyleHookEx;
 
interface
 
uses
System.Types, Winapi.Messages, System.Classes, Vcl.Graphics, Vcl.Controls,
Vcl.StdCtrls, Vcl.Themes;
 
type
TCheckBoxStyleHookEx = class(TCheckBoxStyleHook)
protected
procedure PaintBackground(Canvas: TCanvas); override;
function AcceptMessage(var Message: TMessage): Boolean; override;
end;
 
implementation
 
{ TCheckBoxStyleHookEx }
 
function TCheckBoxStyleHookEx.AcceptMessage(var Message: TMessage): Boolean;
begin
// StyleElements が、どのような値であっても描画処理はこちらで行う
Result := True;
end;
 
procedure TCheckBoxStyleHookEx.PaintBackground(Canvas: TCanvas);
var
tmpRect: TRect;
ElementSize: TElementSize;
BoxSize: TSize;
begin
// 元の描画処理を呼び出して、チェックボックスの図形などを書いて貰う
inherited;
 
// クライアント領域の描画が入っていない場合
if not (seClient in Control.StyleElements) then begin
// チェックボックス図形の大きさを求める
tmpRect := Rect(0, 0, 20, 20);
ElementSize := esActual;
 
with StyleServices do
if
not GetElementSize(
Canvas.Handle,
GetElementDetails(tbCheckBoxCheckedNormal),
tmpRect,
ElementSize,
BoxSize)
then begin
BoxSize.cx := 13;
BoxSize.cy := 13;
end;
 
// チェックボックス図形の分を矩形から取り除く
tmpRect := Control.ClientRect;
Inc(tmpRect.Left, BoxSize.cx);
 
// Color プロパティの色で背景を塗りつぶす
Canvas.Brush.Color := TCheckBox(Control).Color;
Canvas.FillRect(tmpRect);
end;
end;
 
initialization
begin
// TCheckBoxStyleHookEx を TCheckBox の Style Hook とする
TCustomStyleEngine.RegisterStyleHook(TCheckBox, TCheckBoxStyleHookEx);
end;
 
finalization
begin
 
end;
 
end.

ポイントは、AcceptMessage で返す値を必ず True にして、描画処理をこちらで受け持つ所です。
これにより、必ず PaintBackground が呼び出されるため、背景色を自由に設定できます。
また、元々の描画処理も呼び出しているので、TFont.Color も何もしなくても効きます。
この TCheckBoxStyleHookEx を uses して実行した結果が次の画像です。



期待通り、TForm.Color と Font.Color が効いています。

結局、StyleHook を使わないと簡単にはできないんだね、という結論でした。

上記の例では StyleElements を [seBorder] にして実行しました。
もしも StyleElements を [] にすると、どうなるでしょうか?
StyleElements を [] にして実行すると、素の Windows のコントロールが描画されます。
AcceptMessage が True を返しているにも関わらず、です。
これは、TWinControl.WndProc の中で、StyleElements が [] だったら、スタイル処理を実行しない、という部分(Vcl.Controls.pas 9892 行目)があるためです。
そのため、StyleElements が [] の状態だと、スタイル処理が実行されず、素の Windows のコントロールが描画されてしまうのです。
個人的には、この if 文は要らないと思います(※)が、仕様ともいえるため QuolityCentral には報告していません。

※変更する手段が無いため。
Control.WindowProc でウィンドウプロシージャを変更しても、その時点では StyleHook を設定できない。

2013年1月21日月曜日

管理者権限で起動する CMD


開発していると、結構コマンドプロンプト(CMD.exe)を実行することがあります。
普通に CMD.exe を起動すると、普通の権限で起動します。
しかし、管理者権限でのみ動作するようなプログラムなどを起動したい場合に、一々 UAC が開くのは煩わしいものです。
かといって「管理者としてこのプログラムを起動する」っていうチェックをいれるというのも、いまいちです。
というのも、もしも顧客に対して提供するコマンドラインツールがあったとすると、「このコマンドを実行して下さい。このコマンドは管理者権限で~云々」と説明しなくてはならないためです(しかも正しく伝わる確率の方が低い!)。
そこで、管理者権限で起動する CMD.exe を作ってみます。

ポイントは3つ。

1つ目は、CMD.exe のパスの取得です。
CMD.exe のパスの取得はいくつかやり方があります。
まずは SHGetSpecialFolderLocation を使って「Windows\System32」のパスを取得し、そのパスに CMD.exe を結合して実行する方法です。
とても真っ当な方法ですが ItemIDList を取得したりと、何かと面倒です。
そこで、もう1つの方法「環境変数」から取得することにします。
環境変数「ComSpec」は、CMD.exe のパスを示す環境変数です。
取得した環境変数を展開して有効なパスに変換する API が ExpandEnvironmentStrings です。
これを使って「%ComSpec%」という環境変数を「C:\Windows\System32\cmd.exe」に変換します。

2つ目は、管理者権限での実行です。
とても有名なので既にご存じかも知れませんが、ShellExecuteEx の lpVerb に 'runas' を指定して、プログラムを実行すると UAC が開いて管理者権限で実行できます。
これについては過去のデベロッパーキャンプでエンバカデロの高橋さんが説明(pdf)されています。

3つ目は、起動しても自分自身は見せずに CMD.exe だけを実行する方法です。
プログラムを一個起動するだけなので {$APPTYPE CONSOLE} で、コンソールアプリとして実装すれば良さそうに見えますが、そうするとコンソールが開いてしまいます。
そこで、今回は何も指定しない、つまり {$APPTYPE GUI} としてアプリケーションを作る事にします。
こうすることで、開く Window(TForm)が存在しないため、何も表示せずにアプリケーションを実行可能です。

これらを踏まえたコードが下記です。

program AdminCMD;
 
// 自分を表示したくないので指定しない
//{$APPTYPE CONSOLE}
 
uses
Winapi.Windows, Winapi.ShellApi, System.SysUtils;
 
// 管理者権限で実行する
function RunAsAdmin(const iExeName, iParam: String): Boolean;
var
SEI: TShellExecuteInfo;
begin
Result := False;
 
// runas は、Vista 以降のみ動作する
if (CheckWin32Version(6)) then begin
ZeroMemory(@SEI, SizeOf(SEI));
 
with SEI do begin
cbSize := SizeOf(SEI);
Wnd := 0;
fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
lpVerb := 'runas';
lpFile := PChar(iExeName);
lpParameters := PChar(iParam);
nShow := SW_SHOW;
end;
 
Result := ShellExecuteEx(@SEI);
end;
end;
 
var
CmdPath: String;
begin
// 環境変数から CMD.exe のパスを取得する
CmdPath := StringOfChar(#0, MAX_PATH);
ExpandEnvironmentStrings(
PChar('%ComSpec%'),
PChar(CmdPath),
Length(CmdPath));
 
CmdPath := Trim(CmdPath);
 
// 管理者権限で実行
RunAsAdmin(CmdPath, '');
end.

このコードを実行すると……



UAC の確認ダイアログが出た後に



コマンドプロンプトが開きます。
使いどころを誤らなければ、便利なコマンドプロンプトだと思います。

2013年1月17日木曜日

IME が ATOK か見分ける

ごくごく希に IME をいじる時があります。
そして、MS-IME と ATOK で違う動作をさせたいなーという事が、すごっく希にあります。

そんなとき、Screen.ImesScreen.DefaultIme で IME の名前を取れば、ATOK かそうでないかが見分けられます。

たとえば、次のような関数で ATOK かどうかを見分けられます。

function IsATOK: Boolean;
begin
Result := (Screen.DefaultIme.IndexOf('ATOK') > -1);
end;

また、Screen.Imes.Objects[] プロパティには「入力ロケール識別子」(旧名:キーボードレイアウト)が入っています。 あるエディットコントロールでは、この識別子、また別の時には別の識別子、を指定して ActiveKeyboardLayout API を呼び出して、IME を指定したりすることもできます。

Screen.DefaultKbLayout というデフォルトの入力ロケール識別子を返すプロパティもあります。)