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イベントの使用例
//  上から1番目と2番目のメニューを削除
//=============================================================================
procedure TForm1.plContextMenu1BeforeContextShowMenu(Sender: TObject;
  MenuHandle: HWND);
begin
  RemoveMenu(MenuHandle, 0, MF_BYPOSITION);
  RemoveMenu(MenuHandle, 0, MF_BYPOSITION);
end;

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;

//=============================================================================
//  コントロールの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;

//=============================================================================
//  コントロールの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;

//=============================================================================
//  コントロールの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;

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.

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.

//=============================================================================
//  コントロールの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;

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.

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.

//=============================================================================
//  ファイルシステムのファイル名の場合のドライブは，親が仮想フォルダなので，ド
//  ライブ名を調整してもコンテキストメニューは表示されない
//=============================================================================
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;

unit plContextMenu;

interface

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

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.30';
  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)
          and (Info.fType=MFT_STRING) then begin
          //まれに取得できない文字列がある(何が入っているのか? Vista以降)
          if Info.dwTypeData <> nil then begin
            try
              StrNewMenu := Info.dwTypeData;
              if (Pos(StrNewConst1, StrNewMenu) > 0) or
                 (Pos(StrNewConst2, StrNewMenu) > 0) then begin
                g_SubMenuNewHandle := Info.hSubMenu;
              end;
            except
            end;
          end;
        end;
        Application.ProcessMessages;
      end;
      //最後が区切り文字だったら削除
      ItemCount := GetMenuItemCount(Handle);
      // レコード型の初期化処理なしで実行していたので修正
      // 利用者からの指摘 (2019/11/3 - 実際の修正は 2020/02/07
      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, 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が戻ってくるので両方実行
            // 2020/02/07 の確認ては Windows 7 では修正されたようなので2 行目は削除
            // 2 行目があると例外が発生する
            // Windows Vists / 8 / 8.1 /10 では未確認
            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;

//=============================================================================
//  内部で使用する関数
//
//  指定したフォルダ，ファイルからフォルダのシェルオブジェクトを取得
//  取得できたらコンテキストメニューも取得
//  操作対象不可のフォルダやファイルが１つでもあると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)を返す
    //操作対象不可のフォルダやファイルが１つでもあると表示しない
    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.40';
  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.