Explorer への Drop

ソースはこちら（GitHub）

流行りに乗っかったわけではないですが、必要に駆られて OLE Drag and Drop （アプリケーションからエクスプローラーへデータをドロップ）を実装しようとしました。

しかし！
「仮想ファイル（存在しないファイル）」を「IStream」で書き出していく IDataObject の良いサンプルが無く、非常に悩みました。

ちなみに、どんな時に存在しないファイルの書き出しが必要かというと、例えば FTP でファイル名だけ判っているファイルをエクスプローラにドロップする時です。
選択されているファイルを先にダウンロードする訳にもいかないので、IDataObject.GetData が来たときに IStream インターフェースを実装しているストリームを返してやります。

そんな実装がしたかっただけなのですが、さっぱり上手く行きません。
そこで、サンプルを探していたら

The Drag and Drop Component Suite for Delphi

というコンポーネントを発見したので、早速導入してみました。

……しかし、コンパイルが通りません。
Delphi 2010 用で更新が止まってるため、いくつか不整合が起きたようです。

まず DragDrop.pas の 2483 行目の

const
  sClipNames: array[CF_TEXT..CF_MAX-1] of string =
    ('CF_TEXT', 'CF_BITMAP', 'CF_METAFILEPICT', 'CF_SYLK', 'CF_DIF', 'CF_TIFF',
    'CF_OEMTEXT', 'CF_DIB', 'CF_PALETTE', 'CF_PENDATA', 'CF_RIFF', 'CF_WAVE',
    'CF_UNICODETEXT', 'CF_ENHMETAFILE', 'CF_HDROP', 'CF_LOCALE');

を

const
  sClipNames: array[CF_TEXT..CF_MAX-1] of string =
    (
      'CF_TEXT',
      'CF_BITMAP',
      'CF_METAFILEPICT',
      'CF_SYLK',
      'CF_DIF',
      'CF_TIFF',
      'CF_OEMTEXT',
      'CF_DIB',
      'CF_PALETTE',
      'CF_PENDATA',
      'CF_RIFF',
      'CF_WAVE',
      'CF_UNICODETEXT',
      'CF_ENHMETAFILE',
      'CF_HDROP',
      '',
      'CF_LOCALE'
    );

と変えてやります。

次に DragDropContext の101 行目

    function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
      pszName: LPSTR; cchMax: UINT): HResult; stdcall;
 
    { IContextMenu2 }
    function HandleMenuMsg(uMsg: UINT; WParam, LParam: Integer): HResult; stdcall;
 
    { IContextMenu3 }
    function HandleMenuMsg2(uMsg: UINT; wParam, lParam: Integer;
      var lpResult: Integer): HResult; stdcall;

を

    function GetCommandString(idCmd: UINT_PTR; uFlags: UINT; pwReserved: PUINT;
      pszName: LPSTR; cchMax: UINT): HResult; stdcall;
 
    { IContextMenu2 }
    function HandleMenuMsg(uMsg: UINT; WParam: WPARAM; LParam: LPARAM): HResult; stdcall;
 
    { IContextMenu3 }
    function HandleMenuMsg2(uMsg: UINT; wParam: WPARAM; lParam: LPARAM; var lpResult: LRESULT): HResult; stdcall;

と変更します。
実装部も同じように引数を変更します。

次に DragDropSource, DragDropTarget の中で TThread.Resume を使っている部分があるので

{$ifndef VER21_PLUS}
procedure TDropSourceThread.Start;
begin
  {$WARNINGS OFF}
  Resume;
  {$WARNINGS ON}
end;
{$endif}

{$ifndef VER21_PLUS}
procedure TDropTargetTransferThread.Start;
begin
  {$WARNINGS OFF}
  Resume;
  {$WARNINGS ON}
end;
{$endif}

こんな風に {$WARNINGS} で囲ってやります。

これで、コンパイルが通るので同梱の DragDropD2011.dpk を開いてビルド＆インストールします。
すると、これらのコンポーネントが登録されます。



では、元々やりたかった仮想ファイルのコピーを実装します。
Demo も入っている（\Demos\AsyncSource）のですが、プロジェクト規模が無駄に大きくて判りづらいです。
「AsyncSource with Filestreams」にいたっては Indy を使って FTP を実装しています……
必要なところが見えなくて非常に判りづらい！

ということで、最も簡単なデモを作りました。

まず、Form に、TDataFormatAdapter と TDropEmptySource を置きます。



次にオブジェクトインスペクタで TDataFormatAdapter と TDropEmptySource を結びつけます。



画像の様に DataFormatName は TVirtualFileStreamDataFormat とし、Enabled を True にしておきます。

Enabled プロパティは DataFormatName と DragDropComponent が設定されていないと変更できません。

そして DataFormatAdapter1 にイベントハンドラを設定し、その中身を作ります。

procedure TForm1.FormCreate(Sender: TObject);
begin
  // イベントハンドラを設定する
  (DataFormatAdapter1.DataFormat as TVirtualFileStreamDataFormat).OnGetStream
    := OnGetStream;
end;
 
procedure TForm1.OnGetStream(
  Sender: TFileContentsStreamOnDemandClipboardFormat;
  Index: integer;
  out AStream: IStream);
var
  Data: TVirtualFileStreamDataFormat;
begin
  // ここは非同期で別スレッドから呼ばれるので、
  // ここでファイルのダウンロードなどをし、ファイルを一旦生成する
  // 生成した一時ファイルは TDropEmptySource.OnAfterDrop イベントなどの
  // タイミングで適宜削除する
 
  // 追加しておいたファイルを取り出す
  Data := TVirtualFileStreamDataFormat(DataFormatAdapter1.DataFormat);
 
  // 追加してある何番目のファイルかが Index に入っている
  if (Index < Data.FileNames.Count) then
    AStream :=
      // TStreamAdapter を使うと IStream の実装が得られる
      TStreamAdapter.Create(
        TFileStream.Create(
          Data.FileNames[Index],
          fmOpenRead or fmShareDenyNone),
        soOwned
      );
end;

これで、非同期にファイルをコピーする仕組みは整いました。
実際にファイルの Drop を実行するためには TDropEmptySource.Execute を使います。

procedure TForm1.DropExecute;
var
  Data: TVirtualFileStreamDataFormat;
begin
  // OnMouseMove から呼ばれる（煩雑になるため機能を分けた）
 
  // TVirtualFileStreamDataFormat.FileNames にコピーするファイル名を追加する
  Data := TVirtualFileStreamDataFormat(DataFormatAdapter1.DataFormat);
  Data.FileNames.Clear;
 
  // 今回は自分をコピーしてみる
  Data.FileNames.Add(Application.ExeName);
 
  if (Data.FileNames.Count > 0) then
    DropEmptySource1.Execute(True); // True を渡すと非同期で実行する
end;

ここでは「存在しないファイル」を用意するのが面倒なので「自分自身」をコピーするようにしました。
サンプルでは、フォームのどこでもドラッグすると、エクスプローラーにドロップできます。



是非お試しあれ。

deprecated 指令

Delphi-ML で紹介したテクニックなんですけど、たまに役に立つのでご紹介。

Delphi は言語仕様として一度広げた可視性を狭めることはできません。
つまり、

type
  TFoo = class
  public
    procedure Test; virtual;
  end;
 
  TBar = class(TFoo)
  protected
    procedure Test; override;
  end;

XE3 で確認した所、可視性が低くなった事を示すヒントが出なくなっていました。
ヒントのデフォルトスイッチが変わった可能性があります。
……と思ったら、このヒントは「unit」の「interface 部」にのみ出力されるとリンク先にありました。

としても、Test メソッドは依然として public のままです。

そのため、クラスを継承した際に不都合がでる場合があります。
例えば、既存のライブラリクラスを継承して、新たに配布するためのクラスを作る場合などです。
自分やチームだけが使うクラスなら「このメソッドではなく、こちらを使ってください」と伝えるだけで済みます。
しかし、広範に配布するライブラリなどを作る場合では、利用者全員が利用方法を読んでくれる訳ではありません。

では、どうすれば良いかというと、使って欲しくないメソッドを Override しつつ deprecated を付けてしまえ、という事です。

deprecated 指令を付けると、コンパイラは「非推奨」という警告を出すようになります。
警告を一切気にしないユーザーには効果がありませんが、一般的なユーザーは、この警告に気づくでしょう。

具体的には以下のようにします。

type
  TFoo = class
  public
    procedure Test; virtual;
  end;
 
  TBar = class(TFoo)
  public
    // TFoo.Test を override しつつ 非推奨化
    procedure Test; override; deprecated 'Test2 メソッドを使って下さい';
    procedure Test2;
  end;
 
{ TFoo }
 
procedure TFoo.Test;
begin
  Writeln('Hello, TFoo !');
end;
 
{ TBar }
 
procedure TBar.Test;
begin
  inherited; // 元の TFoo.Test を呼ぶようにする
end;
 
procedure TBar.Test2;
begin
  Writeln('Hello, TBar !');
end;
 
var
  Baz: TBar;
begin
  Baz := TBar.Create;
  try
    //「W1000 シンボル 'Test' を使用することは推奨されていません」が発生する
    // 追加メッセージ 'Test2 メソッドを使って下さい' も表示される
    Baz.Test;
  finally
    Baz.Free;
  end;
 
  Readln;
end.

ただし、静的メソッドの場合と final が指定されている場合は対処できません。
隠蔽で対策できる様に思いますが、下記の様に継承元の型が指定されている場合に隠蔽の効果が無くなるためです。

type
  TFoo2 = class
  public
    procedure Sample; // 静的メソッド
  end;
 
  TBar2 = class(TFoo2)
  public
    // TFoo2.Sample を隠蔽する
    procedure Sample; deprecated 'Sample2 メソッドを使って下さい';
    procedure Sample2;
  end;
 
var
  Baz: TFoo2; // TFoo2 型で定義する
begin
  Baz := TBar2.Create; // TBar2 を生成する
  try
    // Baz の中身は TBar2 のインスタンスなのに TFoo2.Sample が呼ばれる！
    Baz.Sample;
  finally
    Baz.Free;
  end;
 
  Readln;
end.

Delphi 言語では、継承元と同じメソッド名を定義することで、継承元のメソッドを見ることができなくなります。
これを「隠蔽」と呼びます。
virtual, dynamic を隠蔽する場合 reintroduce 指令が必要です。

final 指定はまだしも、静的メソッドに deprecated を付けられないので汎用性は下がりますが、依然として有効な時もあるのでは無いでしょうか？

なお、静的メソッドや final を隠したい場合は、ラッパークラスを作る事で回避します。

小ネタでした。

クラス宣言でのネスト

TStyleProvider で、さらりとクラス内レコードを使ってみました。

type
  TStyleProvider = class(TObject)
  strict private
    type
      TStyleData = record
      private
      （略）
      end;

    var
      FStyles: TList<TStyleData>;
  （略）
  end;
  

以前の Delphi ではクラス内でクラス・構造体を宣言できなかったため、クラスが内部で管理する特に外に見せる必要の無いクラスまで、クラスの宣言は見えていました。

上の例で言えば

type
  TStyleData = record
  private
   （略）
  end;

  TStyleProvider = class(TObject)
  private
    FStyles: TList<TStyleData>;
   （略）
  end;
  

となっていました。
TStyleProvider だけが必要な他のコードから、TStyleData も見えていたわけです。

クラス内でレコードやクラスを宣言できるようになった（Delphi 2007 から？）ことや、strict private が導入された（Delphi 2005 から？）おかげで見せたくないデータを断固見せないように実装できるので、すっきりしますね。

クラスを for in do に対応させる

TStyleProvider を作成する過程で、やったことの無かった for in do に対応させてみようとコードを組んでみました。

IEnumerator や IEnumerable の２つを実装しようとして、はまってしまいました。
それぞれに同じ名前の GetCurrent メソッドがあるためのようです。

そこで、とりあえずインターフェースを継承しないことにしました。
というのは docwiki に

実際に IEnumerator をクラスに実装することは要求されません。単に必要なメソッドをクラスに実装するだけで十分です

という記述があり、必ずしもインターフェースを実装しなくても良いからです。
この場合、コンパイラはメソッドの名前から判断しているようです。

つまり、クラスを for in do に対応させるためには

1. GetEnumerator メソッドの実装
2. GetCurrent メソッドの実装
3. MoveNext メソッドの実装
4. Current プロパティの実装

という４つの実装が必要で、場合によってはさらに Reset メソッドの実装も必要です。

このうち、１は実際に for in に渡されるクラスで実装します。
２以降は、通常別のクラスに記載します。

TStyleProvider で言うと１は

  TStyleProvider = class(TObject)
  （省略）
  public
    function GetEnumerator: TStyleEnumerator;
  end;

  （省略）

function TStyleProvider.GetEnumerator: TStyleEnumerator;
begin
  Result := TStyleEnumerator.Create(Self);
end;

のように TStyleProvider で実装しています。
ここで返している TStyleEnumerator が２以降を実装しています。

TStyleEnumerator の宣言と実装は以下のようになっています。

TStyleEnumerator = class(TObject)
private
  FProvider: TStyleProvider;
  FIndex: Integer;
public
  constructor Create(const iProvider: TStyleProvider);
  function GetCurrent: String;
  function MoveNext: Boolean;
  procedure Reset;
  property Current: String read GetCurrent;
end;

implementation

{ TStyleProvider.TStyleEnumerator }

constructor TStyleProvider.TStyleEnumerator.Create(
  const iProvider: TStyleProvider);
begin
  inherited Create;

  FProvider := iProvider;
  FIndex := -1;
end;

function TStyleProvider.TStyleEnumerator.GetCurrent: String;
begin
  Result := FProvider[FIndex];
end;

function TStyleProvider.TStyleEnumerator.MoveNext: Boolean;
begin
  Inc(FIndex);
  Result := (FIndex < FProvider.Count);
end;

procedure TStyleProvider.TStyleEnumerator.Reset;
begin
  FIndex := -1;
end;

つまり、MoveNext でインデックスを1つ進め、GetCurrent で、そのインデックスが示すデータを返す、というだけです。
ただ注意しないといけないのは、インデックスの初期値は -1 にしておくということです。
それは、

1. Create
2. MoveNext
3. GetCurrent

という順番でメソッドが呼ばれるからです。

つまり最初の要素の取得だとしても MoveNext が呼ばれてから GetCurrent が呼ばれるので、インデックスの初期値を -1 にしておくと、都合が良い、ということです。

また、もう一つ疑問点があります。
GetEnumerator で渡す TStypleEnumerator は TInterfacedObject などにして解放する必要があるのではないか？ということです。

しかし、TStringList の IEnumerator の実装である System.Classes.TStringsEnumerator のコードを見てみると、特に解放している様子はありませんでした。
コンパイラが自動的にやっているようです。

TStringsEnumerator のようにデフォルトで用意されている Enumerator もありますし、自前で Enumerator を実装するのも簡単なので、これから作成するクラスでは対応すると良いかも知れません。

Style を外部ファイルから読み込む

ソースはこちら（GitHub）

VCL / FireMonkey の Style は、非常に簡単に見目麗しいアプリケーションを制作できます。
その反面、Style を Exe ファイルに入れるとファイルサイズが大きくなってしまいます。
Style はアプリケーションの本質とは関係ないため、Style によってファイルサイズが大きくなるのは避けたい所です。

すぐに思いつく簡単な解決策は、Style ファイルを外部に持つ、ということです。
こうすれば、Exe ファイルに取り込まれないのでファイルサイズが大きくなるのを防ぐ事ができる上、新しいスタイルの配布も簡単です。

しかし、デフォルトの vsf ファイルを配布しても良いのか？という懸念があります。
そこで、dockwiki を見てみると下記のようにあり

また、これらのスタイル（VCL スタイルまたは FireMonkey スタイル）はどれも、作成したアプリケーションと一緒に再配布することができます。この再配布可能なスタイル ファイルは、作成した製品のインストール ディレクトリ内の次の場所に置きます。
\Redist\styles

デフォルトの vsf ファイルも再配布可能なようです。

では、実際に外部の Style ファイルを読むコードは、どうするかというと…次のようにします。

TStyleManager.LoadFromFile('VSFファイル');
TStyleManager.TrySetStyle('スタイルの名前');

非常に簡単です。
とはいえ、毎回このコードを書くのは面倒なので StyleProvider というクラスを作ってみました。

このクラスを使うと指定のディレクトリにあるファイルを全部読み取り、スタイルをリストとして持ちます。
後は、Apply / ApplyByName メソッドを呼ぶだけです。

下記は、簡単な使用例です。

procedure TForm1.FormCreate(Sender: TObject);
var
  Name: String;
begin
  // ディレクトリを指定して生成する
  // ここでは Exe と同じディレクトリを指定しているので
  // Debug / Release それぞれに style ファイルを置かねばならない
  StyleProvider :=
    TStyleProvider.Create(
      ExtractFilePath(Application.ExeName) + '\Redist\styles');

  // スタイルの名前を ListBox1 に追加
  for Name in StyleProvider do
    ListBox1.Items.Add(Name);
end;

procedure TForm1.ListBox1Click(Sender: TObject);
var
  Index: Integer;
begin
  Index := ListBox1.ItemIndex;

  // ListBox1 がクリックされたとき、スタイルを変える
  if (Index > -1) and (Index < ListBox1.Items.Count) then
    StyleProvider.ApplyByName(ListBox1.Items[Index]);
end;

良かったら使ってみてください。

interface と implementation

割と知られている事だと思いますが、メソッドの宣言がしてあれば、メソッドの実装では、引数リストと戻値の型は省略できます。

01 type
02   TForm1 = class(TForm)
03     procedure FormCreate(Sender: TObject);
04   private
05     procedure Test(const iMsg: String);
06     function Test2(const iMsg: String): Boolean;
07   public
08   end;
09 
10 var
11   Form1: TForm1;
12 
13 implementation
14 
15 {$R *.dfm}
16 
17 { TForm1 }
18 
19 procedure TForm1.Test;
20 begin
21   ShowMessage(iMsg);
22 end;
23 
24 function TForm1.Test2;
25 begin
26   Result := True;
27   ShowMessage(iMsg);
28 end;

上記のリスト 5, 6 行目のように宣言さえしておけば、19, 24 の実現部では引数リストと戻値の型は省略できます。

ただ、普段は Shift + Ctrl + C を使って自動的に宣言部⇔実現部を作っていると思いますので、このような書き方は「できる」というだけで、使ってる人は居ないのではないでしょうか？
そもそもメリットが特に思いつかないし……

ちなみに、下記の様にメソッドだけではなく普通の手続きや関数でも同じ事ができます。

01 var
02   Form1: TForm1;
03 
04 function Test3(const iMsg: String): Boolean;
05 
06 implementation
07 
08 function Test4(const iMsg: String): Boolean; forward;
09 
10 function Test3;
11 begin
12   Result := Test4(iMsg);
13 end;
14 
15 function Test4;
16 begin
17   Result := True;
18   ShowMessage(iMsg);
19 end;

TEdit に数字のみ入れる

TEdit に数字だけ入力だけしたい、そんな時がきっとあるはず！
だからといって、TMaskEdit や TUpDown とか TNumberBox を使うまでもないって時に、下のような関数を用意して使っています。

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if (not CharInSet(Key, [#8, '0'.. '9'])) then
    Key := #0;
end;

一般的すぎるテクニックで記事を更新！

簡単に解説すると、'0'.. '9' は、普通に数字を表しているだけなので判ると思います。
#8 は、バックスペースです。
これがないと、バックスペースで文字を消せなくなるので注意が必要です。