Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2010年10月31日] [更新 2015年10月04日] Delphi サンプルプログラム集
   
814_コンテキストメニュー コンポーネント
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro
コンポーネントは Delphi 6, 7, 2007, 2009, 2010, XE (全て Pro 版) で動作確認
814_ContextMenu_DropSource.zip [2,300 KB] 2015年10月04日版(EXE同梱)



  • 2010年11月07日
  • 操作対象がドライブ直下の場合に例外が発生する現象を修正
  • 2010年12月07日
  • [新規作成] メニューが表示されたりしなかったりする現象を修正
  • 処理対象フォルダが正確に取得できない現象を修正
  • 操作中に例外が発生する現象を修正
  • ドロップ開始の DoDrop メソッドの引数に ListView 等のハンドルを指定した場合,画が表示されていれば,ドラッグ中にその画像を表示するようにした ( Delphi 2007 以上でコンパイルした場合のみ)
  • 項目識別子の操作関係関数を追加
  • 2010年12月08日
  • Windows Vista 以降の場合は,新規作成メニューだけの表示はしないようにした
  • 2010年12月15日
  • [コンテキストメニューのカスタマイズ]の記事を追加
  • 2010年12月19日
  • [新規作成] メニューのカスタマイズ (削除のみ),メニュー編集,デフォルト動作中止等の機能を外部から可能にするために,イベントを3つ追加
  • 実行したコマンドID取得用に VerbCmdID プロパティを追加 (読出し専用)
  • 上記の変更に伴い,コマンド実行部のコードを修正
  • 2010年12月27日
  • コンテキストメニューコンポの一部のイベント用コードが,とんでもないところに書いてあったのを修正.動作そのものには影響はなし.
  • 2011年01月02日
  • ドロップソースの IDropSource インターフェイスをコンポのメンバーにした
  • 2015年01月10日
  • Delphi 7 で UINT_PTR が未定義になる現象を修正
    (以前の更新で UINT_PTR にしてしまったらしい)
  • 各記事の項目に番号を付けた.それに伴い,UP したフォルダの構成も変更.ただし,添付のテストプログラムの変更は一切なし
  • 2015年10月04日
  • Windows 7 U64(SP1) + Delphi XE(UP1) Pro で動作再確認
  • 記事とテストプログラムのコードを整備




コンテキストメニューコンポーネント


エクスプローラでマウスの右ボタンクリックで表示されるコンテキストメニューを,自作のファイルリストやフォルダーツリー等のアプリケーションに実装するためのコンポーネントです.エクスプローラへのドラッグ・ドロップの機能のためのコンポーネントも含まれています.
コンテキストメニューのコンポーネントは,旧Nifty の FDELPHI フォーラムの [16番会議室「玉石混淆み んなで作るSample蔵],Atelier Macchan 氏の [ContextMenu の表示 (コンポーネント編] のコードを元に作成しました.またドロップソースコンポーネントは,同じく旧 Nifty の FDELPHI フォーラムでヒシアマゾン氏が提供していた TDropSource コンポーネントのソースを改変したものです.

エクスプローラが表示するコンテキストメニューに,独自のメニューを追加する方法が Delphi 小技の [Delphi で作るシェル拡張 (ShellExtention)・・・コンテキストメニューの追加] と [ファイルの関連付けで「開く」以外の動作を追加する] にあります.





01_インストール・使用方法・仕様


添付の plContextMenu.pas をコンポーネントとしてインストール (登録) します.コンポーネントのアイコンは用意していません.以下の手順で使用します.
  • (1) コンポーネントをコントロールに配置
  • (2) コントロールの PopupMenuプ ロパティに本コンポを指定
    Popup メソッドを使用する場合は不要
  • (3) OnPopup イベントで Directory (操作対象フォルダ)と Files (操作対象ファイル) を設定,またはコントロールの OnKeyDown イベント内等で Popup メソッド実行前にこれらのプロパティを設定
主な仕様,特徴は,
  • コントロールの PopupMenu プロパティに設定して利用できる
  • [送る] と [新規作成] のメニューも表示する
  • メニューの削除や追加ができる (新規作成のサブメニューは削除のみ)
  • メニューを表示しないでコマンドを実行するメソッドを実装
  • OnPopup イベント内でフォルダやファイルの設定ができる
  • メニューの種類 (デフォルト,新規作成を非表示等) をいくつか選択できる
  • 仮想フォルダ等は,GUID 文字列で指定しないと操作対象にはならない
となっています.当然ですが,存在しないフォルダやファイルを指定するとコンテキストメニューは表示しません.[名前の変更] は,エクスプローラを直接操作するわけではないので実際には機能しません.利用者がコーディングする必要があります.[貼り付け] 等の際に確認ダイアログが表示されますが,Vista 以降では [削除] の確認ダイアログは表示しません.
表示されるコンテキストメニューの内容は,必ずしもエクスプローラと一致するとは限りません.特にデスクトップは違います.




02_プロパティ


このコンポーネントは TPopupMenu コンポーネントの継承コンポーネントです.オブジェクト・インスペクタに元のコンポーネントのプロパティが表示されますが,設定してもほとんど無効です.追加のメニューに対しての設定に使用することになります.
以下はこのコンポーネントのプロパティ等の説明です.



凡例  published
 public
 ReadOnly

 Directory String 操作対象のフォルダ (ディレクトリ)
空の場合はデスクトップが操作対象
仮想フォルダは GIUD 文字列,ドライブはD:\のように指定する

Files プロパティを空にして特殊フォルダだけの場合は動作不可
 Files TStrings Directory 内の操作対象のファイル名を格納する
ファイル名にはディレクトリを含めない
仮想フォルダは GUID 文字列,ドライブは D:\ のように指定する

空の場合は Directory 値そのものが操作対象となる
 MenuOptions - 表示するメニューの種類を指定する集合型プロパティ
これらを全て False にすると追加のメニューのみを表示
 VerbNameStr String 実行した copy, paste, rename 等のコマンド文字列
[新規作成] 等のサブメニューの場合は空文字,または正確ではないことがある
OnContextMenuClose イベント内で取得できる
 VerbCmdID Integer 実行した copy, paste, rename 等に対応するコマンド ID
[新規作成] 等のサブメニューでは重複する場合あり
Vista 以降では [新規作成] も各メニュー固有値があるようだ
OnContextMenuClose イベント内で取得できる




03_メソッド


以下のメソッドがあります.


Popup(X,Y:);

継承元の TPopupMenu コンポのメソッドと同じです.指定座標にコンテキストメニューを表示します.

引数 説明
X Integer 表示位置のスクリーン X 座標値
Y Integer 表示位置のスクリーン Y 座標値


InvokeCommand(CmdIDNo):Boolean

引数で指定したコマンドを実行します.実行に成功すると True を失敗するとFalseを返します.どんなファイル,フォルダに対してもこれらのコマンドが実行できるとは限りません.また Windows のバージョンによっては動作内容に違いがある場合があります.

引数 説明
CmdIDNo Integer 以下の値のどれか 1 つ

IDCMDSTR_PREVIEW     [プレビュー]
IDCMDSTR_PRINT       [印刷]
IDCMDSTR_EDIT        [編集]
IDCMDSTR_CUT         [切り取り]
IDCMDSTR_COPY        [コピー]
IDCMDSTR_PASTE       [貼り付け]
IDCMDSTR_DELETE      [削除]
IDCMDSTR_PROPERTIES  [プロパティ]
IDCMDSTR_EXPLORE     [エクスプローラ]
IDCMDSTR_OPEN        [開く]
IDCMDSTR_FIND        [検索]




04_イベント


以下のイベントがあります.


OnPopup(Sender)

継承元の TPopupMenu コンポのイベントと同じです.AutoPopup プロパティが Ture の時は,マウスの右ボタンクリックで,このイベントが自動的に発生します.

引数 説明
Sender TObject コンポーネント自身


OnContextMenuClose(Sender)

本コンポーネントで追加したイベントです.コンテキストメニューを閉じた時に発生します.主に [名前の変更] を検出するために実装しています.このイベント内で,実行したコマンドの VerbNameStr プロパティの値が取得できます.

引数 説明
Sender TObject コンポーネント自身


OnBeforeContextAddSubItem(Sender,ItemCaption,ItemID,AddFlag)

本コンポーネントで追加したイベントです.
[新規作成] のサブメニューの各アイテムが作成される度に発生します.このイベント内で,[新規作成] の各メニュー項目の表示・非表示を設定できます.

引数 説明
Sender TObject コンポーネント自身
ItemCaption String 項目の表示文字列
ItemID Integer 項目の ID 値
Windows XP では重複する値があるが,Vista 以降は項目ごとに固有の値のようである
var AddFlag Boolean この値を False にすると,その項目を表示しない
デフォルトは True で表示


[新規作成] のサブメニューの内,[フォルダ],[Microsoft Word],[Microsoft Excel] の文字列があるメニューだけを表示する例です.


図1
イベント利用前の [新規作成] メニュー
図2
イベント処理後の [新規作成] メニュー

リスト1
指定のメニュー項目だけを表示するようにする例
procedure TForm1.FormShow(Sender: TObject);
var
  LDir : String;
begin
  //操作対象のフォルダ指定
  LDir := ExtractFileDir(Application.ExeName);
  plContextMenu1.Directory := LDir;
end;

procedure TForm1.plContextMenu1BeforeContextAddSubItem(Sender: TObject;
  ItemCaption: string; ItemID: Integer; var AddFlag: Boolean);
begin
  if CheckBox1.Checked then begin
    if (Pos('フォルダ',        ItemCaption) > 0) or
       (Pos('Microsoft Word',  ItemCaption) > 0) or
       (Pos('Microsoft Excel', ItemCaption) > 0) then begin
      AddFlag := True;
    end else begin
      AddFlag := False;
    end;
  end;
end;



OnBeforeContextShowMenu(Sender,MenuHandle)

本コンポーネントで追加したイベントです.
コンテキストメニューが表示される直前に発生します.このイベント内で,メニューの追加や削除または変更ができます.ただし,カスタム描画を必要とする変更はできません.

引数 説明
Sender TObject コンポーネント自身
MenuHandle HWND メニューのハンドル


リスト2
指定のメニュー項目を削除する例
//=============================================================================
//  OnBeforeContextShowMenuイベントの使用例
//  上から1番目と2番目のメニューを削除
//=============================================================================
procedure TForm1.plContextMenu1BeforeContextShowMenu(Sender: TObject;
  MenuHandle: HWND);
begin
  RemoveMenu(MenuHandle, 0, MF_BYPOSITION);
  RemoveMenu(MenuHandle, 0, MF_BYPOSITION);
end;


図3
[フォーマット] 項目を無効にしたメニュ

リスト3
[フォーマット] メニューを無効にして,表示文字列を変更する例
procedure TForm1.FormShow(Sender: TObject);
begin
  //操作対象のフォルダ指定
  plContextMenu1.Directory := 'D:\';
end;

procedure TForm1.plContextMenu1BeforeContextShowMenu(Sender: TObject;
  MenuHandle: HWND);
var
  LItemInfo : TMenuItemInfo;
  LCaption  : array [0 .. MAX_PATH - 1] of Char;
begin
  FillChar(LCaption, SizeOf(LCaption), #0);
  LItemInfo.cbSize     := SizeOf(LItemInfo);
  LItemInfo.cch        := Length(LCaption);
  LItemInfo.fState     := MFS_DISABLED or MFS_GRAYED;
  LItemInfo.fMask      := MIIM_STATE or MIIM_STRING;
  LItemInfo.dwTypeData := 'フォーマット禁止';

  SetMenuItemInfo(MenuHandle, 36, False, LItemInfo);
end;



OnBeforeContextInvoke(Sender,CmdIndex,VerbNameStr,InvokeFlag)

本コンポーネントで追加したイベントです.
コンテキストメニューのメニューを実行する直前に発生します.このイベント内でコマンドの実行を中止し,別のプログラム等を実行するため実装しました.

引数 説明
Sender TObject コンポーネント自身
CmdIndex Integer これから実行するコマンドの ID 番号
VerbNameStr String これから実行するコマンドの文字列
コマンドによっては空文字や,正確でない場合がある
var InvokeFlag Boolean この値をFalseにすると,コマンドを実行しない
デフォルトは True




05_基本動作のテストプログラム


既にイベントの説明でテストコードを提示していますが,改めて基本的な操作のテストです.
添付しているプロジェクト内のフォルダを操作対象にしています.


図4
設計時画面
図5
コンテキストメニュー表示
  • [新規作成] のサブメニューも表示
  • Files プロパティが空の場合のみ表示
    Directory プロパティのディレクトリが対象
    (エクスプローラと同じ動作)

リスト4
基本動作テスト用プログラム
//=============================================================================
//  コントロールのPopupMenuプロパティを指定
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Self.PopupMenu := plContextMenu1;
end;

//=============================================================================
//  TplContextMenuコンポのOnPopupイベントで表示
//=============================================================================
procedure TForm1.plContextMenu1Popup(Sender: TObject);
var
  LDir : String;
begin
  plContextMenu1.Files.Clear;
  //操作対象のフォルダ指定
  LDir := ExtractFilePath(Application.ExeName) + 'AAA';
  plContextMenu1.Directory := LDir;
end;


プロパティ MenuOptions に csf_DEFAULTONLY が含まれているとシンプルなメニューとなります.


図6
シンプルなメニュー

リスト5
シンプルなメニュー表示
//=============================================================================
//  コントロールのPopupMenuプロパティを指定
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Self.PopupMenu := plContextMenu1;
  plContextMenu1.MenuOptions := [csf_DEFAULTONLY];
end;

//=============================================================================
//  TplContextMenuコンポのOnPopupイベントで表示
//=============================================================================
procedure TForm1.plContextMenu1Popup(Sender: TObject);
var
  LDir : String;
begin
  plContextMenu1.Files.Clear;
  //操作対象のフォルダ指定
  LDir := ExtractFileDir(Application.ExeName);
  plContextMenu1.Directory := LDir;
end;


同様に,プロパティ MenuOptions を csf_CREATENEW だけにすると [新規作成] のメニューだけを表示することができます.ただし,Windows Vista 以降では無効で,何も表示しません.


リスト6
[新規作成] 関係のメニューのみ表示
//=============================================================================
//  コントロールのPopupMenuプロパティを指定
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Self.PopupMenu := plContextMenu1;
  plContextMenu1.MenuOptions := [csf_CREATENEW];
end;

//=============================================================================
//  TplContextMenuコンポのOnPopupイベントで表示
//=============================================================================
procedure TForm1.plContextMenu1Popup(Sender: TObject);
var
  LDir : String;
begin
  plContextMenu1.Files.Clear;
  //操作対象のフォルダ指定
  LDir := ExtractFileDir(Application.ExeName);
  plContextMenu1.Directory := LDir;
end;




06_コマンドのテストプログラム


コマンドのテストプログラムです.添付のフォルダ内を操作対象にしています.もちろん,コピーした内容をエクスプローラへ貼り付けたり,エクスプローラでコピーした内容を貼り付けることもテストできます.


図7
設計時画面
図8
[コピー] を実行
  • [貼り付け] を実行すると...
図9
[貼り付け] 実行
  • ここに貼り付けされる
  • [削除] はこれらを削除する

リスト7
コマンドの実行.InvokeCommand メソッドのテスト
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    plContextMenu1: TplContextMenu;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  コントロールのPopupMenuプロパティを指定しない
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Self.PopupMenu := nil;
end;

//=============================================================================
//  コピー
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LDir : String;
begin
  plContextMenu1.Files.Clear;
  //操作対象のフォルダ指定
  LDir := ExtractFilePath(Application.ExeName) + 'CCC';
  plContextMenu1.Directory := LDir;

  plContextMenu1.Files.Add('DDD');
  plContextMenu1.Files.Add('CC2.txt');

  plContextMenu1.InvokeCommand(IDCMDSTR_COPY);
end;

//=============================================================================
//  貼り付け
//  すでに同名のフォルダやファイルが存在する場合は,確認のダイアログ表示
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LDir : String;
begin
  plContextMenu1.Files.Clear;
  //操作対象のフォルダ指定
  LDir := ExtractFilePath(Application.ExeName) + 'AAA';
  plContextMenu1.Directory := LDir;

  plContextMenu1.InvokeCommand(IDCMDSTR_PASTE);
end;

//=============================================================================
//  削除
//  Vista以降では確認のダイアログを表示しない
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  LDir : String;
begin
  plContextMenu1.Files.Clear;
  //操作対象のフォルダ指定
  LDir := ExtractFilePath(Application.ExeName) + 'AAA';
  plContextMenu1.Directory := LDir;

  plContextMenu1.Files.Add('DDD');
  plContextMenu1.Files.Add('CC2.txt');

  plContextMenu1.InvokeCommand(IDCMDSTR_DELETE);
end;

end.




07_コンテキストメニューのカスタマイズ


[新規作成]のサブメニューは,OnBeforeContextAddSubItem イベントで,指定項目の表示・非表示の設定だけができます.その他のメニューは,OnBeforeContextShowMenu イベント内でカスタマイズ可能です.カスタマイズには,RemoveMenu,DeleteMenu,SetMenuItemInfo 等の操作用の関数を使用します.追加位置は,メニューを識別する数値か,上からの相対位置で行います.
メニューを識別する値は,実行コマンドに対応する値ですが,この値は,結果のコマンド文字列が同じであっても,表示するメニューの種類,どのフォルダ内で表示するかで変わります.また,相対位置も表示されるメニューによって異なります.筆者が確認したところ,Windows XP,7 では,下表の値は固定となっているようです.

これらの設定をしても,エクスプローラが表示するコンテキストメニューは変更できません.このコンポーネントを使用するアプリケーションだけで有効な設定となります.

このコンポーネントは,TPopupMenu の継承コンポーネントです.Items プロパティを設定することによりメニューの追加編集ができますが,これらはメニューの最後の方に追加されます.追加したメニューの実行は,各 Item の OnClick イベントで行います.追加のイベントは発生しません.



識別子 コマンド文字列 表示名(Windows XP)
17 link ショートカットの作成
18 delete 削除
19 rename 名前の変更
20 properties プロパティ
25 cut 切り取り
26 copy コピー
27 paste 貼り付け
36 なし フォーマット
2048 なし 区切り線


次のコードは,メニューを2つ追加し,[コピー] を選択しても,本来のコマンドを禁止して,コンテキストメニューを閉じた後に別のコードを実行する例です.


図10
メニューの追加例
  • 赤枠が追加したメニュー
図11
[コピー] を選択した場合

リスト8
メニューのカスタマイズ例
implementation

uses
  ShellAPI;

{$R *.dfm}

//=============================================================================
//  コントロールのPopupMenuプロパティを指定
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Self.PopupMenu := plContextMenu1;
  plContextMenu1.MenuOptions := [csf_DEFAULTONLY];
end;

//=============================================================================
//  OnBeforeContextShowMenuイベントの使用例
//  新しいメニューの追加例
//  Info.wID(コマンドID)は600以上が良(500番台は内部で使用済み)
//  200番台以下はシステムが使用している可能性あり
//
//  メニューの操作関係関数は以下を参照
//  http://msdn.microsoft.com/ja-jp/library/cc430229.aspx(日本語)
//  http://msdn.microsoft.com/en-us/library/ff468865%28v=VS.85%29.aspx(英文)
//  TMenuItemInfo構造体の説明
//  http://msdn.microsoft.com/ja-jp/library/ms647578%28v=VS.85%29.aspx(英文)
//=============================================================================
procedure TForm1.plContextMenu1BeforeContextShowMenu(Sender: TObject;
  MenuHandle: HWND);
var
  LItemInfo : TMenuItemInfo;
  LCaption  : array [0 .. MAX_PATH - 1] of Char;
begin
  FillChar(LCaption, SizeOf(LCaption), #0);
  LItemInfo.cbSize     := SizeOf(LItemInfo);
  LItemInfo.cch        := Length(LCaption);
  LItemInfo.dwTypeData := '解説記事のサイト表示';
  LItemInfo.wID        := 701;
  LItemInfo.fMask      := MIIM_STRING or MIIM_ID;

  //[プロパティ(ID=20)]の前に挿入
  InsertMenuItem(MenuHandle, 20, False, LItemInfo);

  //今作成したID=701の前に挿入
  LItemInfo.dwTypeData := '解説記事のサイトのトップページ表示';
  LItemInfo.wID        := 702;
  InsertMenuItem(MenuHandle, 701, False, LItemInfo);

  //区切り線を挿入
  InsertMenu(MenuHandle, 20, MF_BYCOMMAND or MF_MENUBREAK, 0, nil);
end;

//=============================================================================
//  OnBeforeContextInvokeイベントの使用例
//  指定したメニューは実行しない
//  ContextMenuCloseイベントで処理する
//=============================================================================
procedure TForm1.plContextMenu1BeforeContextInvoke(Sender: TObject;
  CmdIndex: Integer; VerbNameStr: string; var InvokeFlag: Boolean);
begin
  if UpperCase(VerbNameStr) = 'COPY' then begin
    InvokeFlag := False;
  end;
end;

//=============================================================================
//  OnContextMenuCloseイベント
//  追加メニューと,デフォルト動作を中止したメニューの処理
//=============================================================================
procedure TForm1.plContextMenu1ContextMenuClose(Sender: TObject);
var
  LURL : String;
begin
  if plContextMenu1.VerbCmdID = 701 then begin
    LURL := 'http://mrxray.on.coocan.jp/Delphi/plSamples/814_ContextMenu_DropSource.htm';
    ShellExecute(Handle, 'open', PChar(LURL), nil, nil, SW_SHOW);
  end else
  if plContextMenu1.VerbCmdID = 702 then begin
    LURL := 'http://mrxray.on.coocan.jp/';
    ShellExecute(Handle, 'open', PChar(LURL), nil, nil, SW_SHOW);
  end;

  if UpperCase(plContextMenu1.VerbNameStr) = 'COPY' then begin
    MessageBox(Handle, '[コピー] の機能は準備中です.', '情報', MB_ICONINFORMATION);
  end;
end;

end.


サブメニューを追加する例です.ここでは,サブメニューにビットマップ画像を表示しています.フォームに配置した TImage のビットマップを使用していますが,実際にはリソースから読み込んだり,EXEに埋め込んだビットマップを使用することになるでしょう.


図12
ビットマップ画像付きのサブメニュー
  • ビットマップのサイズは 16 × 16
    Windows XPの場合は 11 × 11 とする
    エクスプローラのビットマップが大きいのはカスタマイズ描画しているため
  • チェックマーク付き等も作成可能

リスト9
ビットマップ画像付きのサブメニュー
//=============================================================================
//  コントロールのPopupMenuプロパティを指定
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Self.PopupMenu := plContextMenu1;
  plContextMenu1.MenuOptions := [csf_DEFAULTONLY];
end;

//=============================================================================
//  OnBeforeContextShowMenuイベントの使用例
//  サブメニューの追加例
//=============================================================================
procedure TForm1.plContextMenu1BeforeContextShowMenu(Sender: TObject;
  MenuHandle: HWND);
var
  LItemInfo      : TMenuItemInfo;
  LCaption       : array [0 .. MAX_PATH - 1] of Char;
  LSubMenuHandle : HMENU;
begin
  //サブメニューのハンドルを作成
  LSubMenuHandle := CreatePopupMenu;

  //サブメニューを持つメニューを作成
  //fMaskにMIIM_SUBMENUを指定し,hSubMenuにサブメニューのハンドルを設定する
  FillChar(LCaption, SizeOf(LCaption), #0);
  LItemInfo.cbSize     := SizeOf(LItemInfo);
  LItemInfo.cch        := Length(LCaption);
  LItemInfo.fMask      := MIIM_TYPE or MIIM_ID or MIIM_SUBMENU;
  LItemInfo.fType      := MFT_STRING;
  LItemInfo.wID        := 700;
  LItemInfo.dwTypeData := 'サブメニューを持つメニューの例';
  LItemInfo.hSubMenu   := LSubMenuHandle;

  //[プロパティ(ID=20)]の前に挿入
  InsertMenuItem(MenuHandle, 20, False, LItemInfo);

  //今作成したメニューにサブメニューを追加
  FillChar(LCaption, SizeOf(LCaption), #0);
  LItemInfo.cbSize     := SizeOf(LItemInfo);
  LItemInfo.cch        := Length(LCaption);
  LItemInfo.fMask      := MIIM_TYPE or MIIM_ID or MIIM_STATE;
  LItemInfo.fType      := MFT_STRING;
  LItemInfo.fState     := MFS_ENABLED;
  LItemInfo.wID        := 701;
  LItemInfo.dwTypeData := 'サブメニューA';

  //挿入してビットマップを表示
  InsertMenuItem(LSubMenuHandle, 0, True, LItemInfo);
  SetMenuItemBitmaps(LSubMenuHandle,
                     701,
                     MF_BYCOMMAND,
                     Image1.Picture.Bitmap.Handle,
                     Image1.Picture.Bitmap.Handle);

  //もう1つサブメニューを追加
  FillChar(LCaption, SizeOf(LCaption), #0);
  LItemInfo.cbSize     := SizeOf(LItemInfo);
  LItemInfo.cch        := Length(LCaption);
  LItemInfo.fMask      := MIIM_TYPE or MIIM_ID or MIIM_STATE;
  LItemInfo.fType      := MFT_STRING;
  LItemInfo.fState     := MFS_ENABLED;
  LItemInfo.wID        := 702;
  LItemInfo.dwTypeData := 'サブメニューB';

  //挿入してビットマップを表示
  InsertMenuItem(LSubMenuHandle, 1, True, LItemInfo);
  SetMenuItemBitmaps(LSubMenuHandle,
                     702,
                     MF_BYCOMMAND,
                     Image2.Picture.Bitmap.Handle,
                     Image2.Picture.Bitmap.Handle);

  //区切り線を挿入
  InsertMenu(MenuHandle, 20, MF_BYCOMMAND or MF_MENUBREAK, 0, nil);
end;




08_新規作成メニューのカスタマイズ


このコンテキストメニューコンポーネントは [新規作成] のメニューリストは表示・非表示の制御しかできません.
[新規作成のメニュー] のカスタマイズはレジストリを操作することで可能ですが,Windows XP であれば,手動になりますが,マイクロソフトが提供している TweakUI ツールをインストールすると GUI で設定することができます.これは英語版のみの提供ですが,使用上問題になることはないでしょう.
TweakUI は,下記の [Windows XP のダウンロード] のページからダウンロードできます.



図13
TweakUI の設定画面
図14
設定後のコンテキストメニュー




09_ドロップソースコンポーネントのテスト


エクスプローラからのドラッグ & ドロップは,当サイトのサンプルプログラム集にいくつかサンプルがあります.本ページのコンテキストメニューコンポーネントに含まれているドロップソースコンポーネントは,その逆の操作用のコンポーネントです.ドロップ先はエクスプローラとは限りません.ドラッグ & ドロップを受け付けることが可能なアプリが対象です.

そのドロップソースコンポーネントのテストプログラムです.
このコンポーネントのプロパティ Directory と Files の意味は上記のコンテキストメニューコンポーネントとほぼ同じですが,Directory が空かドライブを指定した場合は動作しません.デスクトップとドライブはドラッグ・ドロップできないようにしています.また特殊フォルダのみを操作対象とすることはできません.
Directory と Files プロパティに値を設定して,DoDrop メソッドを実行するとドロップ動作を開始します.DoDrop メソッドの引数にはコンポーネントのオーナーのハンドルを指定します.DoDrop は実行すると Integer 型の下表のどれかの値を返します.これらは ActiveX.pas 内で定義されています.

このテストプログラムでは,ドロップソースとして添付のフォルダ内のファイルを設定しています.

[821_アプリケーション間のドラッグアンドドロップ] で紹介しているコンポーネントを使用すれば,比較的簡単に,アプリケーション間でいろいろなオブジェクトに対してドラッグ・アンド・ドロップ機能能を実装できます.



[備考]
本コンポーネントに限らず,アプリケーション間の通信では,メッセージの送受信が行われます.したがって,ユーザーインターフェイス特権の分離 (UIPI) による影響を受けます.





DROPEFFECT_NONE 0 キャンセル
対象のフォルダやファイルが存在しない場合もこの値
DROPEFFECT_COPY 1 コピー
DROPEFFECT_MOVE 2 移動
マウス左ボタンでドラッグ・ドロップした場合はこの値
DROPEFFECT_LINK 4 ショートカットの作成


図15
設計時画面

下図が実行結果です.
マウスの左ボタンでドラッグしてドロップすると,移動になります.右ボタンでドラッグしてドロップすると,コピー,移動,ショートカットの作成,キャンセルの項目があるポップアップメニューが現れます.[ESC] キーでもキャンセルできます.
ドラッグ中は [ESC] キーでキャンセルできます.


図15
実行してドロップ開始
  • エクスプローラへドロップ
図16
実行結果
  • ドロップソースのファイルやフォルダが追加される
  • マウスの左ボタンで操作した場合は移動になるので,元のファイルがなくなる.そのため,次回はドラッグできなくる
  • 再度テストするにはエクスプローラで [元に戻す] の操作を実行してから

リスト10
ドロップソースコンポーネントのテストプログラム
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    plDropSource1: TplDropSource;
    Label1: TLabel;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  マウスの右または左ボタンでドロップ開始
//=============================================================================
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  LDir : String;
begin
  if (Button = mbRight) or (Button = mbLeft) then begin
    plDropSource1.Files.Clear;
    //操作対象のフォルダ指定
    //実用的にはフォルダやファイルの存在を確認した方が良い
    LDir := ExtractFilePath(Application.ExeName) + 'CCC';
    plDropSource1.Directory := LDir;

    plDropSource1.Files.Add('CC1.txt');
    plDropSource1.Files.Add('DDD');

    plDropSource1.DoDrop(Handle);
  end;
end;

end.




10_Delphi 付属のシェルコンポーネントでの使用例と注意


Delph 付属のシェルコンポーネント (Shell Component) での使用例です.
このシェルコンポーネントは元々コンテキストメニューを表示する機能を持っています.また,変更を監視するためにスレッド処理を行っています.そのため,利用するには多少注意が必要です.テストコード内のコメントをお読みください.

このテストコードでは,本コンポーネント内で定義している,GetFullPathFromAbsPItemID という,フルパスに相当する項目識別子 (完全 PIDL ) からファイルシステムのフルパスを取得する関数を使用しています.この関数は,仮想フォルダを GUID 文字列として出力します.この GUID の文字列は,本コンポーネントの Directory と Files プロパティの値として使用できます.Files プロパティにセットするには,フォルダ名 (ディレクトリ名) 部分を除く必要があります.



図17
設計時画面
  • コンテキストメニューコンポを 2 つ配置
    ListView と TreeView 用
図18
コンテキストメニュー表示
図19
エクスプローラへドラッグ
  • ドラッグ中の画像を表示
    ( Delphi 2007 以降のみ)

リスト11
Delphi 付属の Shell コンポでの使用例
仮想フォルダ内でもコンテキストメニューを表示するようにする場合 ( ListView 部のみ)
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, ComCtrls, ShellCtrls, ExtCtrls, StdCtrls, plContextMenu;

type
  TForm1 = class(TForm)
    Panel2: TPanel;
    ShellTreeView1: TShellTreeView;
    ShellListView1: TShellListView;
    plContextMenu1: TplContextMenu;
    Panel1: TPanel;
    Edit1: TEdit;
    Splitter1: TSplitter;
    plDropSource1: TplDropSource;
    plContextMenu2: TplContextMenu;
    Button1: TButton;
    procedure plContextMenu1Popup(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure ShellListView1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure plContextMenu2Popup(Sender: TObject);
    procedure plContextMenu1ContextMenuClose(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ShlObj, ActiveX;

{$R *.dfm}

//=============================================================================
//  TShellListView.AutoContextMenusがTrueの場合,TShellListView内蔵のコンテキス
//  トメニューが使用される
//  AutoRefreshは,このコンテキストメニューの操作を監視するスレッドを使用して
//  いるため,本コンポ操作中に実行していると,スレッドエラーで,スレッドが終了
//  できなくなる
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  ShellListView1.AutoRefresh      := True;
  ShellListView1.AutoContextMenus := False;

  ShellTreeView1.AutoRefresh      := False;
  ShellTreeView1.AutoContextMenus := False;
end;

//=============================================================================
//  [戻る]ボタン
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellListView1.Back;
end;

//=============================================================================
//  TplContextMenuコンポのOnPopupイベント
//  ShellListView用
//  AutoRefreshをFalseにして,TShellListViewの監視スレッドを無効にする
//
//  GetFullPathFromAbsPItemIDはコンポ内で定義している関数で,フルパス相当の項
//  目識別子(完全PIDL)からファイルシステムのフルパスを求める関数
//  この関数で求めたフルパスであれば,対象フォルダが仮想フォルダであっても,コ
//  ンテキストメニューを表示する
//
//  [注意]
//  このコードで取得したpidlはコード内で解放しないこと
//  Itemから取得して代入しているので,メモリは同じ場所となっている,ILClone関
//  数でコピーした場合は解放する
//=============================================================================
procedure TForm1.plContextMenu1Popup(Sender: TObject);
var
  LDirectory : String;
  LFullPath  : String;
  Lpidl      : PItemIDList;
  LSelItem   : TListItem;
  LFileName  : String;
begin
  ShellListView1.AutoRefresh := False;
  plContextMenu1.Files.Clear;

  //Directoryプロパティの設定
  LDirectory := GetFullPathFromAbsPItemID(ShellListView1.RootFolder.AbsoluteID);
  Edit1.Text := LDirectory;
  plContextMenu1.Directory := LDirectory;

  //選択中のItemから順番にフルパス名を取得していく
  LSelItem := ShellListView1.Selected;
  while LSelItem <> nil do begin
    Lpidl := ShellListView1.Folders[LSelItem.Index].AbsoluteID;

    if Lpidl <> nil then begin
      //ドライブ名は'D:\'のように指定する必要があるのでチェック
      LFullPath  := GetFullPathFromAbsPItemID(Lpidl);
      LDirectory := IncludeTrailingPathDelimiter(LFullPath);
      if LDirectory = ExtractFileDir(LDirectory) then begin
        LFileName := LDirectory;
      end else begin
        LFileName := ExtractFileName(LFullPath);
      end;

      plContextMenu1.Files.Add(LFileName);
      LSelItem := ShellListView1.GetNextItem(LSelItem, sdAll, [isSelected]);
    end;
  end;
end;

//=============================================================================
//  TplContextMenuコンポのOnvContextMenuCloseイベント
//  ShellListView用
//=============================================================================
procedure TForm1.plContextMenu1ContextMenuClose(Sender: TObject);
begin
  ShellListView1.AutoRefresh := True;
end;

//=============================================================================
//  TSellListViewのOnMouseDownイベント
//  ドロップソースコンポのテスト
//  選択中のファイルのドラッグ開始
//=============================================================================
procedure TForm1.ShellListView1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  LSelItem  : TListItem;
  LFileName : String;
begin
  ShellListView1.AutoRefresh := False;

  if (Button = mbRight) or (Button = mbLeft) then begin
    plDropSource1.Files.Clear;

    plDropSource1.Directory := ShellListView1.RootFolder.PathName;

    //選択中のItemから順番にフルパス名を取得していく
    //ItemのCaptionだと,拡張子を表示していないファイルが正しく取得できない
    LSelItem := ShellListView1.Selected;
    while LSelItem <> nil do begin
      LFileName := ExtractFileName(ShellListView1.Folders[LSelItem.Index].PathName);
      plDropSource1.Files.Add(LFileName);
      LSelItem := ShellListView1.GetNextItem(LSelItem, sdAll, [isSelected]);
    end;
    plDropSource1.DoDrop(ShellListView1.Handle);
    ShellListView1.AutoRefresh := True;
  end;
end;

//=============================================================================
//  TplContextMenuコンポのOnPopupイベント
//  ShellTreeView用
//
//  ここではファイルシステムのフォルダ名をDirectoryプロパティにセット
//  GetFullPathFromAbsPItemIDを使用して,項目識別子から取得していないので,仮
//  想フォルダではコンテキストメニューを表示しない
//=============================================================================
procedure TForm1.plContextMenu2Popup(Sender: TObject);
var
  LDirectory : String;
begin
  plContextMenu2.Files.Clear;

  if ShellTreeView1.Selected <> nil then begin
    LDirectory := ShellTreeView1.SelectedFolder.PathName;
    Edit1.Text := LDirectory;
    plContextMenu2.Directory := LDirectory;
  end;
end;

end.


仮想フォルダ,仮想フォルダ内のファイルでは,コンテキストメニューを表示したくないのであれば,ファイルシステムのフォルダ名とファイル名を使用します.下のリストはその参考コードです.


リスト12
Delphi 付属の Shell コンポでの使用例
ファイルシステムのファイル名を使用すると,仮想フォルダではコンテキストメニューは非表示
//=============================================================================
//  ファイルシステムのファイル名の場合のドライブは,親が仮想フォルダなので,ド
//  ライブ名を調整してもコンテキストメニューは表示されない
//=============================================================================
procedure TForm1.plContextMenu1Popup(Sender: TObject);
var
  LFullPath : String;
  LSelItem  : TListItem;
  LFileName : String;
begin
  plContextMenu1.Files.Clear;

  plContextMenu1.Directory := ShellListView1.RootFolder.PathName;

  LSelItem := ShellListView1.Selected;
  while LSelItem <> nil do begin
    LFullPath := ShellListView1.Folders[LSelItem.Index].PathName;
    LFileName := ExtractFileName(LFullPath);
    plContextMenu1.Files.Add(LFileName);

    LSelItem := ShellListView1.GetNextItem(LSelItem, sdAll, [isSelected]);
  end;
end;




11_コンポーネントのソースコード


コンテキストメニューコンポーネントとドロップソースコンポーネントのソースコードです.
ドラッグソースコンポーネントと同様な動作をするコードが [OLE Drag&Drop エクスプローラにファイル名を受け渡す] にもあります.
メニュー関係の関数は,MSDN のメニューの記事,Shell Interfaces の IContextMenu Interface の記事等を参考にしてください.



リスト13
コンテキストメニューとドロップソースコンポーネントのソースコード
unit plContextMenu;

interface

uses
  SysUtils, Windows, Messages, ShellAPI, ShlObj, ActiveX, Menus, Classes,
  Forms, ComObj;

const
  IDCMDSTR_PREVIEW    = 510; // プレビュー
  IDCMDSTR_PRINT      = 520; // 印刷
  IDCMDSTR_EDIT       = 530; // 編集
  IDCMDSTR_CUT        = 540; // 切取り
  IDCMDSTR_COPY       = 550; // コピー
  IDCMDSTR_PASTE      = 560; // 貼付け
  IDCMDSTR_DELETE     = 570; // 削除
  IDCMDSTR_PROPERTIES = 580; // プロパティ
  IDCMDSTR_EXPLORE    = 590; // エクスプローラ
  IDCMDSTR_OPEN       = 600; // 開く
  IDCMDSTR_FIND       = 610; // 検索

type
  TplContextSubItemEvent = procedure(Sender: TObject; ItemCaption: String;
                                     ItemID: Integer;
                                     var AddFlag: Boolean) of object;
  TplContextModifyEvent  = procedure(Sender: TObject;
                                     MenuHandle: HWND) of object;
  TplContextInvokeEvent  = procedure(Sender: TObject; CmdIndex: Integer;
                                     VerbNameStr: String;
                                     var InvokeFlag: Boolean) of object;

  TplContextShowFlag = (csf_NORMAL,
                        csf_DEFAULTONLY,
                        csf_EXPLORE,
                        csf_CANRENAME,
                        csf_CREATENEW);

  TplContextShowFlags = set of TplContextShowFlag;
  TplDropPItemIDs     = array of PItemIDList;

  TplContextMenu = class(Menus.TPopupMenu)
  private
    FAboutVCL       : String;
    FFiles          : TStrings;
    FDirectory      : String;
    FShellDesktop   : IShellFolder;
    FShellFolder    : IShellFolder;
    FpidlDesktop    : PItemIDList;
    FpidlFolder     : PItemIDList;
    FMenuOptions    : TplContextShowFlags;
    FVerbNameStr    : String;
    FVerbCmdID      : Integer;
    FInputCommndStr : AnsiString;

    FOnContextMenuClose        : TNotifyEvent;
    FOnBeforeContextAddSubItem : TplContextSubItemEvent;
    FOnBeforeContextShowMenu   : TplContextModifyEvent;
    FOnBeforeContextInvoke     : TplContextInvokeEvent;

    procedure SetFiles(const Value: TStrings);
    function DoCommand(CmdIDNo: Integer; X, Y: Integer): Boolean;
    function GetShellFolderFromPath(Dir: String; Files: TStrings;
      var CTMenu: IContextMenu2): Boolean;
  protected
    FIsOSBeforeVista : Boolean; // OSがVistaより前のバージョンか
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Popup(X, Y: Integer); override;
    function InvokeCommand(CmdIDNo: Integer): Boolean;
    property VerbNameStr : String  read FVerbNameStr;
    property VerbCmdID   : Integer read FVerbCmdID;
  published
    property AboutVCL    : String   read FAboutVCL;
    property Directory   : String   read FDirectory write FDirectory;
    property Files       : TStrings read FFiles     write SetFiles;
    property MenuOptions : TplContextShowFlags read FMenuOptions
                                               write FMenuOptions;
    property OnContextMenuClose        : TNotifyEvent
                                         read  FOnContextMenuClose
                                         write FOnContextMenuClose;
    property OnBeforeContextAddSubItem : TplContextSubItemEvent
                                         read  FOnBeforeContextAddSubItem
                                         write FOnBeforeContextAddSubItem;
    property OnBeforeContextShowMenu   : TplContextModifyEvent
                                         read  FOnBeforeContextShowMenu
                                         write FOnBeforeContextShowMenu;
    property OnBeforeContextInvoke     : TplContextInvokeEvent
                                         read  FOnBeforeContextInvoke
                                         write FOnBeforeContextInvoke;
  end;

  TplDropSource = class(TComponent, IDropSource)
  private
    FAboutVCL     : String;
    FDirectory    : String;
    FFiles        : TStrings;
    FpidlDesktop  : PItemIDList;
    FpidlFolder   : PItemIDList;
    FShellDesktop : IShellFolder;
    FShellFolder  : IShellFolder;
    procedure SetFiles(const Value: TStrings);
    function GetShellFolderAndDataFromPath(Dir: String; AFiles: TStrings;
      var PItemIDs: TplDropPItemIDs): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function DoDrop(OwnerHandle: HWND): Integer;
    function QueryContinueDrag(fEscapePressed: BOOL;
      grfKeyState: Longint): HResult; stdcall;
    function GiveFeedback(dwEffect: Longint): HResult; stdcall;
  published
    property AboutVCL  : String   read FAboutVCL;
    property Directory : String   read FDirectory write FDirectory;
    property Files     : TStrings read FFiles     write SetFiles;
  end;

procedure Register;

function GetPItemIDFromFileName(ShFolder: IShellFolder;
  Path: String): PItemIDList;
function GetFullPathFromAbsPItemID(pidlFull: PItemIDList): String;

{$IF CompilerVersion < 21.0}
//---------------------------------------------------------------------------
//  Delphi 2010よりも前のバージョンではShlObj.pasに定義がない関数があるのでこ
//  こで定義
//  これらの関数類はWindows 2000以降のShell32.dllで提供されている
//  Windows 2000では,これらの関数は非公開APIとなっている
//---------------------------------------------------------------------------
function ILClone(pidl: PItemIDList): PItemIDList; stdcall;
function ILCreateFromPath(pszPath: LPCTSTR): PItemIDList; stdcall;
function SHBindToParent(pidl: PItemIDList; const riid: TIID; var ppv: Pointer;
  var ppidlLast: PItemIDList): HResult; stdcall;
//---------------------------------------------------------------------------
{$IFEND}

implementation

type
  {$IF CompilerVersion < 18.00}
  UINT_PTR = Cardinal;
  {$IFEND}

  // http://msdn.microsoft.com/ja-jp/library/kb145b0a.aspx参照
  PAppendMenuItemData = ^TAppendMenuItemData;
  tagAppendMenuItemData = packed record
    nFlags      : UINT;
    nIDNewItem  : UINT_PTR;
    lpszNewItem : LPCTSTR;
  end;
  TAppendMenuItemData = tagAppendMenuItemData;
  AppendMenuItemData = tagAppendMenuItemData;

const
  CMF_CREATENEW = $80000001;

  // CLSID_NewMenuはDelphi 6にないので追加
  CLSID_NewMenu: TGUID = '{D969A300-E7FF-11D0-A93B-00A0C90F2719}';

  ContextShowFlags: array [TplContextShowFlag] of Cardinal = (
                                                  CMF_NORMAL,
                                                  CMF_DEFAULTONLY,
                                                  CMF_EXPLORE,
                                                  CMF_CANRENAME,
                                                  CMF_CREATENEW);
  {$IF CompilerVersion < 21.0}
  Shell32DLL = 'shell32.dll';
  function ILClone; external Shell32DLL index 18;
  function ILCreateFromPath; external Shell32DLL index 189;
  function SHBindToParent; external Shell32DLL;
  {$IFEND}

var
  g_plContextMenu    : TplContextMenu;
  g_ContextMenu      : IContextMenu2; // [新規作成]以外のメニューインターフェイス
  g_ContextMenuNew   : IContextMenu2; // [新規作成]のメニューのインターフェイス
  g_OriginWinProc    : TFarProc;
  g_SubMenuNewHandle : HMENU;
  g_CreateNewOnly    : Boolean;
  g_ItemNumber       : Integer;
  g_Malloc           : IMalloc;

// -----------------------------------------------------------------------------
//  ファイル名を項目識別子に変換する関数
//  フルパスから取得する場合はShFolderにデスクトップオブジェクトを指定する
//  指定フォルダ内のフォルダ,相対項目識別子を取得する場合はそのファイルが格納
//  されているフォルダのシェルオブジェクトをShFoldorに与える
// -----------------------------------------------------------------------------
function GetPItemIDFromFileName(ShFolder: IShellFolder;
  Path: String): PItemIDList;
var
  Len   : Cardinal;
  Flags : Cardinal;
begin
  Flags := 0;
  Len   := Length(Path);
  ShFolder.ParseDisplayName(Application.Handle,
                            nil,
                            PWideChar(StringToOleStr(Path)),
                            Len,
                            Result,
                            Flags);
end;

//-----------------------------------------------------------------------------
//  フルパス相当の項目識別子(完全PIDL)を,ファイルシステムのフルパスに変換
//  この関数を使用するにはusesにShlObjが必要
//-----------------------------------------------------------------------------
function GetFullPathFromAbsPItemID(pidlFull: PItemIDList): String;
var
  pShFolder : IShellFolder;
  pidl      : PItemIDList;
  StrRet    : TStrRet;
begin
  Result := '';

  //該当ファイルのフォルダオブジェクト(pShFolder)と,相対項目識別子をpidlに取得
  SHBindToParent(pidlFull,
                 IShellFolder,
                 Pointer(pShFolder),
                 pidl);
  FillChar(StrRet, SizeOf(StrRet), 0);
  if pShFolder.GetDisplayNameOf(pidl, SHGDN_FORPARSING, StrRet) = S_OK then begin
    Result := StrRet.pOleStr;
  end;
end;

{ TplContextMenu }

//-----------------------------------------------------------------------------
//  このウィンドウプロシージャーはメニュー,サブメニューの描画時に呼ばれる
//  Windows Vista以降では,WM_MEASUREITEMとWM_DRAWITEMが発生しない
//  WM_INITMENUPOPUPメッセージは発生する
//  winspectorによる調査では0x00000094のメッセージを通過している
//  (非公開の内容なので,Windowsのマイナーチェンジで使用不可になる可能性あり)
//-----------------------------------------------------------------------------
function SendToProc(Wnd: HWND; Msg: UINT; WParam, LParam: Integer): LRESULT;
  stdcall;
var
  lpData      : PAppendMenuItemData;
  ItemCaption : String;
  AddFlag     : Boolean;
  ARect       : TREct;
  VerbName    : array [0 .. MAX_PATH - 1] of Char;
  Info        : TMenuItemInfo;
  pDrawStruct : PDrawItemStruct;
  pItemStruct : PMeasureItemStruct;
  ItemID      : Integer;
begin
  case Msg of
  WM_INITMENUPOPUP:
    begin
      g_ItemNumber := 0;
      if g_SubMenuNewHandle <> 0 then begin
        if g_CreateNewOnly then begin
          g_ContextMenuNew.HandleMenuMsg(Msg, WParam, LParam);
        end else begin
          g_ContextMenuNew.HandleMenuMsg(Msg, g_SubMenuNewHandle, LParam);
        end;
      end;
      if g_ContextMenu <> nil then begin
        g_ContextMenu.HandleMenuMsg(Msg, WParam, LParam);
      end;
      Result := 0;
    end;
  $00000094:
    //for Vista and Windows 7
    begin
      FillChar(VerbName, SizeOf(VerbName), #0);
      Info.cbSize     := SizeOf(Info);
      Info.fMask      := MIIM_STRING or MIIM_ID;
      info.dwTypeData := VerbName;
      Info.cch        := Length(VerbName);

      GetMenuItemInfo(g_SubMenuNewHandle, g_ItemNumber, True, Info);
      ItemCaption := Info.dwTypeData;
      ItemID      := Info.wID;

      AddFlag := True;
      if Assigned(g_plContextMenu.FOnBeforeContextAddSubItem) then begin
        if ItemCaption <> '' then begin
          g_plContextMenu.FOnBeforeContextAddSubItem(g_plContextMenu,
                                                     ItemCaption,
                                                     ItemID,
                                                     AddFlag);
          if AddFlag = False then begin
            RemoveMenu(g_SubMenuNewHandle, ItemID, MF_BYCOMMAND);
          end;
        end;
      end;

      Result := CallWindowProc(g_OriginWinProc, Wnd, Msg, WParam, LParam);
      g_ItemNumber := g_ItemNumber + 1;
    end;
  WM_MEASUREITEM:
    begin
      //[新規作成]のサブメニュー
      pItemStruct := nil;
      if g_SubMenuNewHandle <> 0 then begin
        pItemStruct := PMeasureItemStruct(LParam);
        lpData      := PAppendMenuItemData(pItemStruct^.itemData);
        ItemCaption := lpData.lpszNewItem;
        ItemID      := pItemStruct^.itemID;

        g_ContextMenuNew.HandleMenuMsg(Msg, WParam, LParam);
      end;
      if g_ContextMenu <> nil then begin
        AddFlag := True;
        if Assigned(g_plContextMenu.FOnBeforeContextAddSubItem) then begin
          if ItemCaption <> '' then begin
            g_plContextMenu.FOnBeforeContextAddSubItem(g_plContextMenu,
                                                       ItemCaption,
                                                       ItemID,
                                                       AddFlag);
            if AddFlag = False then begin
              pItemStruct^.itemHeight := 0;
              pItemStruct^.itemWidth  := 10;
              LParam := Integer(pItemStruct);
            end;
          end;
        end;
        g_ContextMenu.HandleMenuMsg(Msg, WParam, LParam);
      end;
      Result := 0;
    end;
  WM_DRAWITEM:
    begin
      pDrawStruct := PDrawItemStruct(LParam);
      ARect       := pDrawStruct^.rcItem;

      if g_SubMenuNewHandle <> 0 then begin
        if (ARect.Bottom - ARect.Top) > 0 then begin
          g_ContextMenuNew.HandleMenuMsg(Msg, WParam, LParam);
        end;
      end;
      if g_ContextMenu <> nil then begin
        g_ContextMenu.HandleMenuMsg(Msg, WParam, LParam);
      end;
      Result := 0;
    end;
  else
    Result := CallWindowProc(g_OriginWinProc, Wnd, Msg, WParam, LParam);
  end;
end;

//=============================================================================
//  Create処理
//  ファイル名を格納するリストの生成
//  OSのバージョンを取得して,Vista以降かをチェック
//=============================================================================
constructor TplContextMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FAboutVCL       := 'Version 1.10';
  FFiles          := TStringList.Create;
  FMenuOptions    := [csf_EXPLORE, csf_CANRENAME, csf_CREATENEW];
  g_plContextMenu := Self;

  //OSのバージョン値を取得しておく
  //ただしここではVista以降に対する判定なのでこれだけ
  FIsOSBeforeVista := (Win32MajorVersion <= 5) and (Win32MinorVersion <= 1);
end;

//=============================================================================
//  Destroy処理
//=============================================================================
destructor TplContextMenu.Destroy;
begin
  FShellDesktop := nil;
  FShellFolder  := nil;
  FreeAndNil(FFiles);
  inherited;
end;

//=============================================================================
//  ファイルまたはフォルダのリストのプロパティ設定メソッド
//=============================================================================
procedure TplContextMenu.SetFiles(const Value: TStrings);
begin
  FFiles.Assign(Value);
end;

//=============================================================================
//  メニューのポップアップメソッド(公開メソッド)
//  このメソッドは
//  (1) この関数を直接実行した時
//  (2) マウスで右ボタンクリックした時
//  (3) OnPopupイベントを実行した時
//  に呼び出される
//=============================================================================
procedure TplContextMenu.Popup(X, Y: Integer);
begin
  FInputCommndStr := '';
  if Assigned(OnPopup) then OnPopup(Self);

  DoCommand(0, X, Y);
end;

//=============================================================================
//  メニューを表示しないでコマンドを実行するメソッド(公開メソッド)
//=============================================================================
function TplContextMenu.InvokeCommand(CmdIDNo: Integer): Boolean;
begin
  Result := False;

  FInputCommndStr := '';
  case CmdIDNo of
    IDCMDSTR_PREVIEW    : FInputCommndStr := 'preview';
    IDCMDSTR_PRINT      : FInputCommndStr := 'print';
    IDCMDSTR_EDIT       : FInputCommndStr := 'edit';
    IDCMDSTR_CUT        : FInputCommndStr := 'cut';
    IDCMDSTR_COPY       : FInputCommndStr := 'copy';
    IDCMDSTR_PASTE      : FInputCommndStr := 'paste';
    IDCMDSTR_DELETE     : FInputCommndStr := 'delete';
    IDCMDSTR_PROPERTIES : FInputCommndStr := 'properties';
    IDCMDSTR_EXPLORE    : FInputCommndStr := 'explore';
    IDCMDSTR_OPEN       : FInputCommndStr := 'open';
    IDCMDSTR_FIND       : FInputCommndStr := 'find';
  end;
  if FInputCommndStr <> '' then Result := DoCommand(CmdIDNo, 0, 0);
end;

//=============================================================================
//  内部で使用する実行関数
//  CmdIDNo = 0の時はコンテキストメニューの表示
//  0以外はコンテキストメニューを表示しないで,コマンドを実行
//=============================================================================
function TplContextMenu.DoCommand(CmdIDNo: Integer; X, Y: Integer): Boolean;
const
  StrNewConst1  = '新規作成(&W)';
  StrNewconst2  = '新規作成(&X)';
  ReductionLine = 2048;
var
  ContextMenu    : IContextMenu2;
  ContextMenuNew : IShellExtInit;
  ici            : TCMInvokeCommandInfo;
  i              : Integer;
  Command        : BOOL;
  CmdIndex       : Integer;
  VerbName       : array [0 .. MAX_PATH - 1] of Char;
  Info           : TMenuItemInfo;
  ShowFlag       : Cardinal;
  StrNewMenu     : String;
  AddItemCnt     : Integer;
  IsLine         : Boolean;
  InvokeFlag     : Boolean;
  ItemCount      : Integer;
begin
  Result             := False;
  g_ContextMenu      := nil;
  g_ContextMenuNew   := nil;
  g_OriginWinProc    := nil;
  g_SubMenuNewHandle := 0;
  FVerbNameStr       := '';
  g_CreateNewOnly    := FMenuOptions = [csf_CREATENEW];

  if g_CreateNewOnly and (FIsOSBeforeVista = False) then exit;
  if g_CreateNewOnly then Items.Clear;

  //ContextMenuがコンテキスト用のメニューハンドル
  //[新規作成]には別のハンドルが必要
  if GetShellFolderFromPath(FDirectory, FFiles, ContextMenu) = False then exit;

  if (CmdIDNo = 0) and (g_CreateNewOnly = False) then begin
    //送るメニューを取得してウィンドウプロシージャーを設定
    if FAILED(ContextMenu.QueryInterface(IID_IContextMenu2,
                                         g_ContextMenu)) then exit;

    g_OriginWinProc := Pointer(SetWindowLong(WindowHandle,
                                             GWL_WNDPROC,
                                             Integer(@SendToProc)));
  end;

  try
    if (CmdIDNo = 0) and (FFiles.Count = 0) and
                         (Pos('::', FDirectory) = 0) and
                         (csf_CREATENEW in FMenuOptions) then begin

      //新規作成の取得
      //新規作成のリストはデスクトップからのフルパスに相当する項目識別子が必要
      CoCreateInstance(CLSID_NewMenu,
                       nil,
                       CLSCTX_INPROC_SERVER,
                       IID_IShellExtInit,
                       ContextMenuNew);
      ContextMenuNew.Initialize(FpidlFolder, nil, 0);

      if FIsOSBeforeVista then begin
        AddItemCnt := 2;
      end else begin
        AddItemCnt := 1;
      end;

      if Succeeded(ContextMenuNew.QueryInterface(IID_IContextMenu2,
                                                 g_ContextMenuNew)) then begin
        //[新規作成]コンテキストメニューをポップアップメニューへ設定
        if Succeeded(g_ContextMenuNew.QueryContextMenu(Handle,
                                                       0,
                                                       Items.Count + AddItemCnt,
                                                       $7FFF,
                                                       CMF_EXPLORE)) then begin
          if g_OriginWinProc = nil then begin
            g_OriginWinProc := Pointer(SetWindowLong(WindowHandle,
                                                     GWL_WNDPROC,
                                                     Integer(@SendToProc)));
          end;
        end;
      end;
    end;

    //[新規作成]以外のコンテキストメニューをポップアップメニューへ設定
    if (g_CreateNewOnly = False) and (FMenuOptions <> []) then begin
      ShowFlag := 0;
      if csf_DEFAULTONLY in FMenuOptions then ShowFlag := ShowFlag or CMF_DEFAULTONLY;
      if csf_NORMAL in FMenuOptions      then ShowFlag := ShowFlag or CMF_NORMAL;
      if csf_EXPLORE in FMenuOptions     then ShowFlag := ShowFlag or CMF_EXPLORE;
      if csf_CANRENAME in FMenuOptions   then ShowFlag := ShowFlag or CMF_CANRENAME;

      if FAILED(ContextMenu.QueryContextMenu(Handle,
                                             0,
                                             Items.Count + 1,
                                             $7FFF,
                                             ShowFlag)) then exit;
    end;

    Command := False;
    if (CmdIDNo = 0) then begin
      //OnBeforeContextMenuPopupイベント.追加,編集,削除などはここで実行
      if Assigned(FOnBeforeContextShowMenu) then begin
        FOnBeforeContextShowMenu(Self, Handle);
      end;

      //メニュー項目の調査(新規メニュの調査,項目削除で区切り線の重複調査)
      ItemCount := GetMenuItemCount(Handle);
      IsLine    := False;

      for i := ItemCount - 1 downto 0 do begin
        FillChar(VerbName, SizeOf(VerbName), #0);
        Info.cbSize     := SizeOf(Info);
        Info.fMask      := MIIM_SUBMENU or MIIM_TYPE;
        info.dwTypeData := VerbName;
        Info.cch        := Length(VerbName);

        GetMenuItemInfo(Handle, i, True, Info);
        //前の項目がリダクション(区切り線)だったら今回の分を削除
        if Info.fType = ReductionLine then begin
          if IsLine then begin
            DeleteMenu(Handle, i, MF_BYPOSITION);
          end else
          if i = 0 then DeleteMenu(Handle, i, MF_BYPOSITION);
        end;
        IsLine := Info.fType = ReductionLine;

        //新規作成サブメニューのハンドルを調査
        //このハンドルはサブメニューの描画に使用する
        //新規メニューのハンドルを取得.日本語版のみ対応
        if (csf_CREATENEW in FMenuOptions) and (ContextMenuNew <> nil) then begin
          //まれに取得できない文字列がある(何が入っているのか? Vista以降)
          try
            StrNewMenu := Info.dwTypeData;
            if (Pos(StrNewConst1, StrNewMenu) > 0) or
               (Pos(StrNewConst2, StrNewMenu) > 0) then begin
              g_SubMenuNewHandle := Info.hSubMenu;
            end;
          except
          end;
        end;
        Application.ProcessMessages;
      end;
      //最後が区切り文字だったら削除
      ItemCount := GetMenuItemCount(Handle);
      GetMenuItemInfo(Handle, ItemCount - 1, True, Info);
      if Info.fType = ReductionLine then begin
        DeleteMenu(Handle, ItemCount - 1, MF_BYPOSITION);
      end;

      // コンテキストメニューを開く
      Command := TrackPopupMenu(Handle,
                                TPM_LEFTALIGN   or
                                TPM_LEFTBUTTON  or
                                TPM_RIGHTBUTTON or
                                TPM_RETURNCMD,
                                X,
                                Y,
                                0,
                                WindowHandle,
                                nil);
    end;

    //メニュー表示失敗
    if (Command = False) and (CmdIDNo = 0) then begin
      Result := False;
    end else begin
      FVerbCmdID := Integer(Command);
      CmdIndex   := Integer(Command) - 1;
      //TPopupMenuに追加したメニューの場合(常に下)
      if (CmdIndex < Items.Count) and (CmdIDNo = 0) then begin
        Items[CmdIndex].Click;
      end else begin
        if CmdIDNo = 0 then CmdIDNo := CmdIndex - Items.Count;

        //OnBeforeContextMenuInvoke
        //このイベントで,特定のメニューは,別のプログラムの実行等の実行が可能
        //例えば[検索]は自作のアプリで実行する等
        FillChar(VerbName, SizeOf(VerbName), 0);
        ContextMenu.GetCommandString(CmdIDNo,
                                     GCS_VERB,
                                     nil,
                                     @VerbName,
                                     SizeOf(VerbName));
        FVerbNameStr := VerbName;
        if CmdIDNo > 500 then FVerbNameStr := FInputCommndStr;

        InvokeFlag := True;
        if Assigned(FOnBeforeContextInvoke) then begin
          FOnBeforeContextInvoke(Self, Integer(Command), FVerbNameStr, InvokeFlag);
        end;

        //選択されたコマンドを実行
        //fMaskにCMIC_MASK_FLAG_NO_UI(確認ダイアログを非表示)を指定しているが
        //Vista以降ではこのフラグを指定しないと[削除]が失敗する
        //ただし,Vista以降では[削除]の確認ダイアログを表示しない
        //[参照]http://support.microsoft.com/kb/327569/ja

        if InvokeFlag then begin
          FillChar(ici, SizeOf(ici), 0);
          ici.cbSize := SizeOf(ici);
          ici.fMask  := CMIC_MASK_FLAG_NO_UI;
          ici.HWND   := Handle;
          if CmdIDNo < 500 then begin
            ici.lpVerb := PAnsiChar(MAKEINTRESOURCE(CmdIDNo));
          end  else begin
            ici.lpVerb := PAnsiChar(FInputCommndStr);
          end;
          ici.lpParameters := nil;
          ici.lpDirectory  := nil;
          ici.dwHotKey     := 0;
          ici.hIcon        := 0;
          ici.nShow        := SW_SHOWNORMAL;

          //コマンド実行部
          //MDSNの記事では成功すればS_OK,それ以外ではエラーコードが検出できる
          //ことになっているが,実際には例外が発生する
          if FIsOSBeforeVista then begin
            try
              //サブメニューを先に実行しないとWindows 2000ではデフォルト動作も
              //実行されてしまう
              if Succeeded(g_ContextMenuNew.InvokeCommand(ici)) then begin
                Result := True;
              end else begin
                Result := Succeeded(ContextMenu.InvokeCommand(ici));
              end;
            except
              try
                Result := Succeeded(ContextMenu.InvokeCommand(ici));
              except
              end;
            end;
          end else begin
            //Vist以降では失敗してもS_OKが戻ってくるので両方実行
            try
              Result := Succeeded(ContextMenu.InvokeCommand(ici));
              Result := Succeeded(g_ContextMenuNew.InvokeCommand(ici));
            except
            end;
          end;
        end;
      end;
    end;
  finally
    for i := GetMenuItemCount(Handle) - Items.Count - 1 downto 0 do begin
      DeleteMenu(Handle, i, MF_BYPOSITION);
    end;
  end;

  if Assigned(g_OriginWinProc) then begin
    SetWindowLong(WindowHandle, GWL_WNDPROC, Integer(g_OriginWinProc));
  end;
  if Assigned(FOnContextMenuClose) then FOnContextMenuClose(Self);

  FShellDesktop := nil;
  FShellFolder  := nil;
  CoTaskMemFree(FpidlFolder);
end;

//=============================================================================
//  内部で使用する関数
//
//  指定したフォルダ,ファイルからフォルダのシェルオブジェクトを取得
//  取得できたらコンテキストメニューも取得
//  操作対象不可のフォルダやファイルが1つでもあるとFalseを返す
//=============================================================================
function TplContextMenu.GetShellFolderFromPath(Dir: String; Files: TStrings;
  var CTMenu: IContextMenu2): Boolean;
var
  PItemIDs    : array of PItemIDList;
  ADirectory  : String;
  DesktopPath : String;
  IsDesktop   : Boolean;
  i           : Integer;
begin
  FpidlDesktop := nil;
  FpidlFolder  := nil;

  Result := False;

  // デスクトップ関係の値取得
  if FAILED(SHGetDesktopFolder(FShellDesktop)) then exit;

  SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, FpidlDesktop);
  DesktopPath := GetFullPathFromAbsPItemID(FpidlDesktop);
  ADirectory  := IncludeTrailingPathDelimiter(Dir);

  if Files.Count = 0 then begin
    SetLength(PItemIDs, 1);
  end else begin
    SetLength(PItemIDs, Files.Count);
  end;

  for i := 0 to Length(PItemIDs) - 1 do PItemIDs[i] := nil;

  IsDesktop := False;

  // デスクトップ
  if Dir = '' then begin
    PItemIDs[0]  := ILClone(FpidlDesktop);
    FpidlFolder  := ILClone(FpidlDesktop);
    FShellFolder := FShellDesktop;
    IsDesktop    := True;
    Result       := True;
  end else begin
    FpidlFolder := ILCreateFromPath(PChar(Dir));
    if FpidlFolder <> nil then begin
      if GetFullPathFromAbsPItemID(FpidlFolder) = DesktopPath then begin
        PItemIDs[0]  := ILClone(FpidlDesktop);
        FShellFolder := FShellDesktop;
        IsDesktop    := True;
        Result       := True;
      end else begin
        if (SHBindToParent(FpidlFolder,
                           IShellFolder,
                           Pointer(FShellFolder),
                           PItemIDs[0])) = S_OK then begin
          Result := True;
        end;
      end;
    end;
  end;

  if Result and (Files.Count > 0) then begin
    if (IsDesktop = False) then begin
      if FAILED(FShellDesktop.BindToObject(FpidlFolder,
                                           nil,
                                           IID_IShellFolder,
                                           Pointer(FShellFolder))) then begin
        Result := False;
      end;
    end;
    if Result then begin
      for i := 0 to Files.Count - 1 do begin
        PItemIDs[i] := GetPItemIDFromFileName(FShellFolder, Files[i]);
        if PItemIDs[i] = nil then begin
          PItemIDs[i] := GetPItemIDFromFileName(FShellFolder, '::' + Files[i]);
          if PItemIDs[i] = nil then begin
            Result := False;
            break;
          end;
        end;
      end;
    end;
  end;

  if Result then begin
    Result := False;
    //コンテキストメニューの取得
    //成功したら引数にCTMenu(IContextMenu2)を返す
    //操作対象不可のフォルダやファイルが1つでもあると表示しない
    if Succeeded(FShellFolder.GetUIObjectOf(WindowHandle,
                                            Length(PItemIDs),
                                            PItemIDs[0],
                                            IID_IContextMenu,
                                            nil,
                                            Pointer(CTMenu))) then begin
      Result := True;
    end;
  end;
end;



//=============================================================================
//
//                 以下,ドラッグソースコンポーネント関係
//
//=============================================================================

{ TplDropSource }

//=============================================================================
//  Create処理
//=============================================================================
constructor TplDropSource.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FAboutVCL := 'Version 1.10';
  FFiles    := TStringList.Create;
end;

// =============================================================================
// 終了処理
// =============================================================================
destructor TplDropSource.Destroy;
begin
  FShellDesktop := nil;
  FShellFolder  := nil;
  FreeAndNil(FFiles);
  inherited;
end;

//=============================================================================
//  Filesプロパティ設定メソッド
//  ファイルリストのセット
//=============================================================================
procedure TplDropSource.SetFiles(const Value: TStrings);
begin
  FFiles.Assign(Value);
end;

//=============================================================================
//  ドロップ開始メソッド(公開メソッド)
//  この部分がコンポの本体
//  これ以外は,単に対象となるファイルの項目識別子を,GetUIObjectOfのPItemIDsに
//  セットするためのもの
//=============================================================================
function TplDropSource.DoDrop(OwnerHandle: HWND): Integer;
var
  PItemIDs    : TplDropPItemIDs;
  ACount      : Integer;
  IDataObj    : IDataObject;
  prgfInOut   : Pointer;
  dwEffect    : Longint;
  AMousePoint : TPoint;
  {$IF CompilerVersion > 18.49}
  pDragSourceHelper: IDragSourceHelper;
  {$IFEND}
begin
  Result := DROPEFFECT_NONE;

  if (OwnerHandle = 0) then exit;
  if (FFiles.Count = 0) and (FDirectory = '') then exit;

  if GetShellFolderAndDataFromPath(FDirectory, FFiles, PItemIDs) then begin

    ACount    := Length(PItemIDs);
    prgfInOut := nil;

    //セットしたPItemIDsのファイルリストからIDataObjを取得する
    if Succeeded(FShellFolder.GetUIObjectOf(OwnerHandle, ACount, PItemIDs[0],
        IDataObject, prgfInOut, Pointer(IDataObj))) then begin

      //Delphi2007以上
      {$IF CompilerVersion > 18.49}
      //IDragSourceHelper実装
      //OwnerHandleがListView,TreeView等であって,画像が表示されていれば,ドラ
      //ッグ開始と同時にその画像を表示
      CoCreateInstance(CLSID_DragDropHelper,
                       nil,
                       CLSCTX_INPROC_SERVER,
                       IID_IDragSourceHelper,
                       pDragSourceHelper);
      GetCursorPos(AMousePoint);
      //ここでは画像(イメージ)を表示中のWindowから取得する
      pDragSourceHelper.InitializeFromWindow(
                       OwnerHandle,
                       AMousePoint,
                       IDataObj);
      {$IFEND}

      //ドラッグ開始
      DoDragDrop(IDataObj,
                 Self,
                 DROPEFFECT_COPY or DROPEFFECT_MOVE or DROPEFFECT_LINK, dwEffect);
      IDataObj    := nil;
      {$IF CompilerVersion > 18.49}
      pDragSourceHelper := nil;
      {$IFEND}
    end;
  end;
  CoTaskMemFree(FpidlDesktop);
  CoTaskMemFree(FpidlFolder);

  //何を実行したかの結果を返す
  //内容はDoDragDrop関数の第3引数の値のどれか
  Result := dwEffect;
end;

//=============================================================================
//  内部で使用する関数
//
//  プロパティDirectoryとFilesからフォルダのシェルオブジェクトとファイルまたは
//  ファイルの項目識別子のリストPItemIDsを返す
//
//  この処理はTplContextMenuとほとんど同じで,項目識別子関係
//  項目識別子の処理関係を別にして共通に使用してもいいが,このファイルの2つの
//  コンポでは別々にした.この方が利用者にとっては本コンポ類の改変がしやすいと
//  考えた
//=============================================================================
function TplDropSource.GetShellFolderAndDataFromPath(Dir: String;
  AFiles: TStrings; var PItemIDs: TplDropPItemIDs): Boolean;
var
  DesktopPath     : String;
  ADirectory      : String;
  IsDesktop       : Boolean;
  IsSpecialFolder : Boolean;
  i               : Integer;
begin
  Result := False;
  FpidlDesktop := nil;
  FpidlFolder := nil;
  IsDesktop := False;

  // デスクトップ関係の値取得
  if FAILED(SHGetDesktopFolder(FShellDesktop)) then exit;

  SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, FpidlDesktop);
  DesktopPath := GetFullPathFromAbsPItemID(FpidlDesktop);

  ADirectory := IncludeTrailingPathDelimiter(Dir);

  if Files.Count = 0 then begin
    SetLength(PItemIDs, 1);
  end else begin
    SetLength(PItemIDs, Files.Count);
  end;

  for i := 0 to Length(PItemIDs) - 1 do PItemIDs[i] := nil;

  IsSpecialFolder := (ADirectory = ExtractFileDir(ADirectory)) or
                     (Pos('::', ADirectory) > 0);
  // デスクトップ
  if Dir = '' then begin
    if Files.Count > 0 then begin
      PItemIDs[0]  := ILClone(FpidlDesktop);
      FShellFolder := FShellDesktop;
      IsDesktop    := True;
      Result       := True;
    end;
  end else begin
    FpidlFolder := ILCreateFromPath(PChar(Dir));
    if FpidlFolder <> nil then begin
      if GetFullPathFromAbsPItemID(FpidlFolder) = DesktopPath then begin
        if Files.Count > 0 then begin
          PItemIDs[0]  := ILClone(FpidlDesktop);
          FShellFolder := FShellDesktop;
          IsDesktop    := True;
          Result       := True;
        end;
      end else begin
        if (SHBindToParent(FpidlFolder,
                           IShellFolder,
                           Pointer(FShellFolder),
                           PItemIDs[0])) = S_OK then begin
          if (Files.Count > 0) and (IsSpecialFolder = False) then begin
            Result := True;
          end;
        end;
      end;
    end;
  end;

  if Result and (Files.Count > 0) then begin
    if (IsDesktop = False) then begin
      if FAILED(FShellDesktop.BindToObject(FpidlFolder,
                                           nil,
                                           IID_IShellFolder,
                                           Pointer(FShellFolder))) then begin
        Result := False;
      end;
    end;
    if Result then begin
      for i := 0 to Files.Count - 1 do begin
        PItemIDs[i] := GetPItemIDFromFileName(FShellFolder, Files[i]);
        if PItemIDs[i] = nil then begin
          Result := False;
          break;
        end;
      end;
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  IDropSourceインターフェイス
//  マウスカーソルの形状を設定
//  DRAGDROP_S_USEDEFAULTCURSORSは標準のマウスカーソル
//-----------------------------------------------------------------------------
function TplDropSource.QueryContinueDrag(fEscapePressed: BOOL;
  grfKeyState: Integer): HResult;
begin
  //[ESC]では終了
  if fEscapePressed then begin
    Result := DRAGDROP_S_CANCEL;
  end else begin
    //右または左ボタンの場合のみ許可
    if not(grfKeyState and MK_LBUTTON <> 0) and
                       not (grfKeyState and MK_RBUTTON <> 0) then begin
      Result := DRAGDROP_S_DROP;
    end else begin
      Result := NOERROR;
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  IDropSourceインターフェイス
//  ドラッグアンドドロップ処理を継続するか終了するかを返す
//-----------------------------------------------------------------------------
function TplDropSource.GiveFeedback(dwEffect: Integer): HResult;
begin
  Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;

//=============================================================================
//  コンポーネント登録情報
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplContextMenu]);
  RegisterComponents('plXRAY', [TplDropSource]);
end;

//----------------------------------------------------------------------------
//  初期化と終了処理(古いDelphiバージョン用?)
//----------------------------------------------------------------------------
initialization
  SHGetMalloc(g_Malloc);
  OleInitialize(nil);

finalization
  OleUninitialize;
  g_Malloc := nil;

end.