Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2010年11月19日] [更新 2015年10月04日]　Delphi サンプルプログラム集
947_エクスプローラをフォームに表示
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro
Delphi 2010 以降専用，Windows Vista 以降専用
947_ExplorerBrowser.zip　[2,194 KB]　2015年10月04日版 (EXE 同梱)



  • 2010年11月21日
  • サンプル[03]を追加
  • 2010年11月23日
  • サンプル[04]を追加
  • サンプル [04] の作成用に，サンプル [02] [03] のコードを変更
  • 2010年11月25日
  • ILFree を CoTaskMemFree に変更
  • 2010年12月27日
  • フォルダツリーのサンプルコードの変更
    インターフェイス部分を TCustomPanel のメンバーにして，Delphi らしいコードに変更
  • 2011年01月03日
  • 他のコードもインターフェイス部分を TCustomPanel のメンバーにした
  • 2011年09月20日
  • [1] [2] [3] インターフェイスを実行時に生成するコードに変更
  • [2] [3] Delphi 2010 での参照カウンタの問題を修正 (Delphi XE, XE2 ではこの修正は不要)
  • [1] [2] [3] スレッドの使用を止めて，OnIdle イベント処理に変更
  • [2] Delphi 2010 での ShlObj.pas の修正方法をコメントに追加
  • [2] [3] [4] Delphi XE2 (32 ビット, 64 ビットで動作確認
  • 2015年10月04日
  • Windows 7 U64(SP1) + Delphi XE(UP1) Pro で動作を再確認



エクスプローラ関係オブジェクト


[945_エクスプローラのテスト] では Windows の Shell32.dll の機能を利用して，エクスプローラの表示や表示フォルダの取得等のテストをしています．
フォルダのツリー表示やフォルダ内のファイルリストをアプリケーションに実装する場合，エクスプローラそのものを表示できれば，[814_コンテキストメニュー コンポ] や，ファイルリストの更新目的のための [815_フォルダの監視コンポーネント] は必要なくなります．これらは，エクスプローラそのものが持っている機能です．

Windows の shlwapi.dll が提供しているシェル名前空間関係のインターフェイスや関数を利用すると，エクスプローラそのものをフォーム上に直接表示して制御できます．

そこで，これらのインターフェイスを使用して，Windows Vista 以降の OS で機能をテストしてみました．サンプルコードが Microsoft の SDK にもありますが，ここでは [EternalWindows] と言うサイトの管理者に承諾を頂きましたので，[シェル / ExplorerBrowser] の記事のコードを Delphi に移植してみました．この参考サイトの記事に詳しい説明があります．各インターフェイスや関数類の機能は，コード内にMSDN の記事へのリンク先を書いておきました．参考にしてください．

参考サイトのコードでは，ウィンドウを生成し，そこにエクスプローラーのオブジェクトを表示するようになっていますが，このページのサンプルは，TCustomPanel を生成し，そこにエクスプローラのオブジェクトを表示するようにしています．フォームにはこの TCustomPanel を配置して表示します．

マイクロソフトでは，このページで使用しているインターフェイスを始め，いくつかのインターフェイスを提供していますが，筆者が確認したところでは，インターフェイスの組み合わせによっては正常に機能しなかったりすることがありました．つまり，カスタマイズは結構面倒でしょう．したがって，このページのサンプルは，あくまでも，このようなことが出来るという見本です．
これらのサンプルの機能，仕様のままで十分だ，と言うのであれば利用価値はあります．

これらのインターフェイスに，IShellBrowser というのがあります．このインターフェイスは，エクスプローラの右ペインのフォルダビューと呼ばれる部分で，指定フォルダ内のファイルのリスト表示するものです．残念ながら，Windows XP では下図のように，各ペインの表示制御ができないようです．


図1
IShellBrowser による表示
  • 表示ペインの制御ができない
  • フォルダツリー表示ができない
[注意]
このサンプルのコードは添付していない




01_エクスプローラをフォーム上に表示 ( Delphi XE 以降のみ)


[ExplorerBrowser の作成] の記事のコードを Delphi に移植したものです．コンポーネントとして利用する場合は，plExplorerBrowser.pas をコンポーネントとして登録してください．コンポーネントのアイコンは用意していません．下表のプロパティがあります．
アクセレーターキー操作が十分に機能しません．何かインターフェイスを追加して処理すれば可能かも知れませんが，調査していません．



凡例 ■ published
□ public
▲ ReadOnly

■ SelectFolder String エクスプローラを表示した時に，選択状態にするフォルダの指定
右のフォルダビュー(ファイルリスト)にこのフォルダ内のファイルを表示する
空文字の時はデスクトップ
仮想フォルダは GUID 文字列で指定する

仮想フォルダの場合，取得は空文字となる

この値を設定しないと表示しない
■ ViewMode Cardinal 表示モードの値で，FVM_DETAILS (詳細表示-デフォルト) 等
この値を設定するには uses に ShlObj が必要


図2
テストプログラムの設計時画面
  • TplExplorerBrowser は実行時生成
図3
[デスクトップ] ボタンクリック
  • コードで各ペインの表示・非表示の設定が可能
  • コンテキストメニューも表示できる
  • ファイル類のドラッグ・ドロップも当然できる
図4
[ネットワーク] ボタンクリック
図5
Windows Vista の場合
  • 右ペインのフォルダを開くと別窓で表示されてしまう

リスト1
コンポーネント TplExplorerBrowser のテストプログラム		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, plExplorerBrowser;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    plExplorerBrowser1: TplExplorerBrowser;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//-============================================================================
//  表示開始
//  デスクトップを選択
//-============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  plExplorerBrowser1.SelectFolder := '';
end;

//-============================================================================
//  ドライブD:\を選択
//-============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  plExplorerBrowser1.SelectFolder := 'D:\';
end;

//-============================================================================
//  コンピュータ(CSIDL_DRIVE)を選択
//-============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  plExplorerBrowser1.SelectFolder := '::{20D04FE0-3AEA-1069-A2D8-08002B30309D}';
end;

//-============================================================================
//  ネットワーク(CSIDL_NETWORK)を選択
//-============================================================================
procedure TForm1.Button4Click(Sender: TObject);
begin
  plExplorerBrowser1.SelectFolder := '::{F02C1A0D-BE21-4350-88B0-7367FC96EF3C}';
end;

//-============================================================================
//  現在選択中のフォルダを表示
//  仮想フォルダは空白
//-============================================================================
procedure TForm1.Button5Click(Sender: TObject);
begin
  ShowMessage(plExplorerBrowser1.SelectFolder);
end;

end.


リスト2
実行時に生成して利用する場合の参考コード例 
unit Unit1;

interface

uses
  {$IF CompilerVersion < 23.0}
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, plExplorerBrowser;
  {$ELSE}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
  plExplorerBrowser, Vcl.StdCtrls;
  {$IFEND}

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  private
    { Private 宣言 }
    FExlploer : TplExplorerBrowser;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//-============================================================================
//  表示開始
//  デスクトップを選択
//-============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if not Assigned(FExlploer) then begin
    FExlploer := TplExplorerBrowser.Create(Self);
    with FExlploer do begin
      Parent   := Self;
      Width    := Self.Width - 120;
      Align    := alRight;
      Anchors  := Anchors + [akLeft];
    end;
  end;

  FExlploer.SelectFolder := '';
end;

//-============================================================================
//  ドライブD:\を選択
//-============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if not Assigned(FExlploer) then exit;
  FExlploer.SelectFolder := 'D:\';
end;

//-============================================================================
//  コンピュータ(CSIDL_DRIVE)を選択
//-============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  if not Assigned(FExlploer) then exit;
  FExlploer.SelectFolder := '::{20D04FE0-3AEA-1069-A2D8-08002B30309D}';
end;

//-============================================================================
//  ネットワーク(CSIDL_NETWORK)を選択
//-============================================================================
procedure TForm1.Button4Click(Sender: TObject);
begin
  if not Assigned(FExlploer) then exit;
  FExlploer.SelectFolder := '::{F02C1A0D-BE21-4350-88B0-7367FC96EF3C}';
end;

//-============================================================================
//  現在選択中のフォルダを表示
//  仮想フォルダは空白
//-============================================================================
procedure TForm1.Button5Click(Sender: TObject);
begin
  if not Assigned(FExlploer) then exit;
  ShowMessage(FExlploer.SelectFolder);
end;

end.


リスト3
コンポーネント TplExplorerBrowser のソースコード		 
unit plExplorerBrowser;

interface

uses
  {$IF CompilerVersion < 23.0}
  Windows, Messages, SysUtils, Variants, Classes, Controls, ShlObj, ActiveX,
  ExtCtrls, Graphics, Types, Forms;
  {$ELSE}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Controls, Winapi.ShlObj, Winapi.ActiveX, Vcl.ExtCtrls, Vcl.Graphics,
  System.Types, Vcl.Forms;
  {$IFEND}

type
  TplExplorerBrowser = class(TCustomPanel,
                             IServiceProvider,
                             IExplorerPaneVisibility, IFolderFilter)
  private
    FSelectFolder      : String;
    FViewMode          : Cardinal;
    m_pExplorerBrowser : IExplorerBrowser;
    procedure SetFSelectFolder(const Value: String);
  protected
    procedure WndProc(var Message: TMessage); override;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure SetParent(AParent: TWinControl); override;
    procedure Paint; override;
    procedure OnIdleEvent(Sender: TObject; var Done: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function QueryService(const rsid, iid: TGuid; out Obj): HResult; stdcall;
    function GetPaneState(const ep: EXPLORERPANE;
      var peps: TExplorerPaneState): HRESULT; stdcall;
    function ShouldShow(const psf: IShellFolder; pidlFolder: PItemIDList;
      pidlItem: PItemIDList): HRESULT; stdcall;
    function GetEnumFlags(const psf: IShellFolder; pidlFolder: PItemIDList;
      var phwnd: HWND; var pgrfFlags: DWORD): HRESULT; stdcall;
  published
    property Caption;
    property Align;
    property Anchors;
    property SelectFolder : String   read FSelectFolder write SetFSelectFolder;
    property ViewMode     : Cardinal read FViewMode     write FViewMode;
  end;

  fIUnknown_SetSite = function (punk: IUnknown; punkSite: IUnknown): HRESULT;
                      stdcall;
procedure Register;

implementation

var
  IUnknown_SetSite : fIUnknown_SetSite;

{ TplExplorerBrowser }

//-============================================================================
//  クラス(コンポーネント)の生成
//  DLLとDLL内の関数のアドレスを取得
//-============================================================================
constructor TplExplorerBrowser.Create(AOwner: TComponent);
var
  DLLHandle : THandle;
begin
  inherited Create(AOwner);

  DLLHandle := LoadLibrary('shlwapi.dll');
  if DLLHandle <> 0 then begin
    @IUnknown_SetSite := GetProcAddress(DLLHandle,'IUnknown_SetSite');
  end;

  m_pExplorerBrowser := nil;
  BevelOuter         := bvNone;
  FViewMode          := FVM_DETAILS;

  Width  := 650;
  Height := 420;
end;

//-============================================================================
//  クラス(コンポーネント)終了処理
//-============================================================================
destructor TplExplorerBrowser.Destroy;
begin
  inherited;
end;

//-============================================================================
//  ここでエクスプローラのインターフェイスオブジェクトを生成し初期化
//
//  IExplorerBrowserインタフェイスオブジェクトは，ビジュアルなオブジェクトなの
//  でOnCreateだと失敗する可能性がある．オーバライドしたSetPrentメソッド内
//  で生成する
//  SetPrentメソッドは，コンポの生成時，破棄の際等，複数回呼出されるので注意
//
//  FOLDERSETTINGSのViewModeの値
//  FOLDERVIEWMODE Enumeration
//  http://msdn.microsoft.com/en-us/library/bb762510%28VS.85%29.aspx
//-============================================================================
procedure TplExplorerBrowser.SetParent(AParent: TWinControl);
var
  rc                : TRect;
  fs                : FOLDERSETTINGS;
  ARect             : TRect;
  pFolderFilterSite : IFolderFilterSite;
  punk              : IInterface;
  {$IF CompilerVersion < 23.0}
  phdwp : Cardinal;
  {$ELSE}
  phdwp : NativeUInt;
  {$IFEND}
begin
  inherited;

  if Parent = nil then exit;
  if csDesigning in ComponentState then exit;

  if m_pExplorerBrowser = nil then begin
    //IExplorerBrowserインターフェイスのオブジェクトを生成して取得
    if Failed(CoCreateInstance(CLSID_ExplorerBrowser,
                               nil,
                               CLSCTX_INPROC_SERVER,
                               IExplorerBrowser,
                               m_pExplorerBrowser)) then exit;

    fs.ViewMode := FViewMode;
    fs.fFlags   := 0;
    SetRectEmpty(rc);
    if Failed(m_pExplorerBrowser.Initialize(Handle, rc, fs)) then exit;

    m_pExplorerBrowser.SetOptions(EBO_SHOWFRAMES or EBO_ALWAYSNAVIGATE);
    IUnknown_SetSite(m_pExplorerBrowser, Self);

    //ShouldShowメソッドで表示フィルタを有効にするために必要
    m_pExplorerBrowser.QueryInterface(IID_IFolderFilterSite, pFolderFilterSite);

    //MDSNではSetFilterの引数は[in]であるがDelphi 2010ではvarとなっているので
    //その対策.Delphi XEではconstになっている
    punk := IFolderFilter(Self);
    pFolderFilterSite.SetFilter(punk);

    phdwp := 0;
    ARect := Rect(0, 0, Width, Height);
    m_pExplorerBrowser.SetRect(phdwp, ARect);

    Application.OnIdle := OnIdleEvent;
  end;
end;

//-============================================================================
//  透明だとコントロールの配置がしにくいのでclWhiteで塗りつぶす
//  (コンポーネントとして登録して使用する場合の対策)
//-============================================================================
procedure TplExplorerBrowser.Paint;
var
  ARect : TRect;
  Flags : Longint;
begin
  inherited Paint;

  with Canvas do begin
    Brush.Color := clWhite;
    FillRect(ClientRect);

    if Caption <> '' then begin
      ARect       := ClientRect;
      Brush.Style := bsClear;
      Font        := Self.Font;
      Flags       := DT_SINGLELINE or DT_CENTER or DT_VCENTER;
      DrawText(Handle, Caption, -1, ARect, Flags);
    end;
  end;
end;

//-============================================================================
//  本コントロール自身には何も描画しないのでバックグラウンド消去はしない
//-============================================================================
procedure TplExplorerBrowser.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 0;
end;

//-============================================================================
//  本コントロールのウィンドプロシージャー
//-============================================================================
procedure TplExplorerBrowser.WndProc(var Message: TMessage);
var
  ARect : TRect;
  {$IF CompilerVersion < 23.0}
  phdwp : Cardinal;
  {$ELSE}
  phdwp : NativeUInt;
  {$IFEND}
begin
  inherited WndProc(Message);

  if Message.Msg = WM_SIZE then begin
    if m_pExplorerBrowser <> nil then begin
      phdwp := 0;
      ARect := Rect(0, 0, Width, Height);
      m_pExplorerBrowser.SetRect(phdwp, ARect);
    end;
  end;
end;

//-============================================================================
//  選択フォルダの設定
//  プロパティSelectFolderの設定メソッド
//
//  ここで設定したフォルダを選択状態にする．フォルダビュー(ファイルリスト)部に
//  このフォルダ内のファイルをリストする
//-============================================================================
procedure TplExplorerBrowser.SetFSelectFolder(const Value: String);
var
  pidl : PItemIDList;
begin
  if @IUnknown_SetSite = nil then exit;
  if (Value <> '') and (Value = FSelectFolder) then exit;

  FSelectFolder := Value;

  //空白ならデスクトップ
  if FSelectFolder = '' then begin
    if Failed(SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, pidl)) then exit;
  end else begin
    pidl := ILCreateFromPath(PChar(FSelectFolder));
    if pidl = nil then exit;
  end;
  //表示開始
  m_pExplorerBrowser.BrowseToIDList(pidl, SBSP_ABSOLUTE);

  CoTaskMemFree(pidl);
end;

//-============================================================================
//  キー操作監視開始
//  フォルダビュー(ファイルリスト)部では一部機能しないようである
//  また，アクセレーターキー操作は機能しない
//-============================================================================
procedure TplExplorerBrowser.OnIdleEvent(Sender: TObject; var Done: Boolean);
var
  Amsg : Msg;
begin
  if csDesigning in ComponentState then exit;

  while True do begin
    if GetMessage(AMsg, 0, 0, 0) = False then begin
      PostQuitMessage(0);
      break;
    end;
    TranslateMessage(Amsg);
    DispatchMessage(Amsg);
  end;
end;



//------------------ 以下インターフェイス関係関数類 ---------------------------


//-----------------------------------------------------------------------------
//  IServiceProvider::QueryService
//  http://msdn.microsoft.com/en-us/library/cc678966%28VS.85%29.aspx
//-----------------------------------------------------------------------------
function TplExplorerBrowser.QueryService(const rsid, iid: TGuid;
  out Obj): HResult;
begin
  Result := QueryInterface(iid, Obj);
end;

//-----------------------------------------------------------------------------
//  IExplorerPaneVisibility::GetPaneState
//  http://msdn.microsoft.com/en-us/library/bb761856%28VS.85%29.aspx
//
//  このメソッド内で表示するペインの表示・非表示の変更が可能
//  表示するにはpepsの値をEPS_DEFAULT_ONにする
//  非表示で状態の変更不可にするにはEPS_DEFAULT_OFF or EPS_FORCEを代入する
//  検出は以下のようにできる
//  if IsEqualGUID(ep, EP_NavPane) then begin
//
//  --------------------------------------------------
//  |     EP_Commands                                |
//  --------------------------------------------------
//  |             |                 |                |
//  |             |                 |                |
//  |             |                 |                |
//  | EP_NavPane  |                 | EP_PreviewPane |
//  | ナビゲータ  |    常に表示     | ファイルの     |
//  | ペイン      |                 | プレビュー領域 |
//  |             |                 |                |
//  |             |                 |                |
//  |             |                 |                |
//  --------------------------------------------------
//  |     EP_DetailsPane                             |
//  --------------------------------------------------
//
//-----------------------------------------------------------------------------
function TplExplorerBrowser.GetPaneState(const ep: EXPLORERPANE;
  var peps: TExplorerPaneState): HRESULT;
begin
  peps   := EPS_DEFAULT_ON;
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
//  IFolderFilter::ShouldShow
//  http://msdn.microsoft.com/en-us/library/bb775628%28v=VS.85%29.aspx
//
//  選択したフォルダ(フォルダビュー ファイルリストするフォルダ)のフルパス取得
//  して，SelectFolderプロパティに代入
//  ここでは隠し属性のファイルを非表示設定
//-----------------------------------------------------------------------------
function TplExplorerBrowser.ShouldShow(const psf: IShellFolder; pidlFolder,
  pidlItem: PItemIDList): HRESULT;
var
  pFullPath : array [0..MAX_PATH - 1] of Char;
  Attrib    : Cardinal;
begin
  SHGetPathFromIDList(pidlFolder, pFullPath);
  FSelectFolder := pFullPath;

  psf.GetAttributesOf(1, pidlItem, Attrib);
  if ((SFGAO_HIDDEN and Attrib) > 0) or ((SFGAO_GHOSTED and Attrib) > 0) then begin
    Result := S_FALSE;
  end else begin
    Result := S_OK;
  end;
end;

//-----------------------------------------------------------------------------
//  IFolderFilter::GetEnumFlags
//  http://msdn.microsoft.com/en-us/library/bb775624%28v=VS.85%29.aspx
//-----------------------------------------------------------------------------
function TplExplorerBrowser.GetEnumFlags(const psf: IShellFolder;
  pidlFolder: PItemIDList; var phwnd: HWND; var pgrfFlags: DWORD): HRESULT;
begin
  Result := S_OK;
end;

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

end.



02_フォルダビュー ( ファイルリスト ) ペインをフォーム上に表示


[フォルダの切り替え] の記事のコードを Delphi に移植したものです．指定フォルダで，エクスプローラのフォルダビュー (ファイルリスト) ペインを表示します．ルートフォルダの設定機能を追加しています．コンポーネントとして利用する場合は，plExplorerFolderView.pas をコンポーネントとして登録してください．コンポーネントのアイコンは用意していません．下表のプロパティがあります．


凡例 ■ published
□ public
▲ ReadOnly

■ RootFolder String ルートフォルダ
本コンポを利用する際の参照用の値
空文字の時はデスクトップ(デフォルト)
ルートフォルダはこの値か pidlRootFolder で指定する
■ ExpandFolder String 表示フォルダ
戻り値は現在展開しているフォルダのフルパスであるが，仮想フォルダの場合は空文字となる

この値か pidlExpandFolder を設定しないと表示しない
□ pidlRootFolder PItemIDList ルートフォルダで，デスクトップからの項目識別子
ルートフォルダは，この値か RootFolder で指定する
□ pidlExpandFolder PItemIDList 表示フォルダ
デスクトップからの絶対値相当の項目識別子

この値か ExpandFolder を設定しないと表示しない
■ ViewMode Cardinal 表示モードの値で，FVM_DETAILS (詳細表示-デフォルト) 等
この値を設定するには uses に ShlObj が必要



以下のメソッドとイベントがあります． 


function NavigateBack: Boolean

フォルダのダブルクリックまたは [Enter] で下の階層に移動した場合，[戻る] 動作を実行します．戻れるのは最初に表示したフォルダまでです．関数の実行に成功すると True を返します． 


function NavigateForward: Boolean

[進む] 動作を実行します．関数の実行に成功すると True を返します． 


OnExpandFolderChanged(Sender, pidlFolder, AFullPath)

フォルダを展開すると発生するイベントです．

引数 型 説明
Sender TObject コンポーネント自身
pidlFolder PItemIDList 展開したフォルダの項目識別子
デスクトップからの絶対値相当
AFullPath String 展開したフォルダのフルパス
仮想フォルダの場合は空文字


図6
テストプログラムの設計時画面
図7
実行例
  • コンテキストメニューもエクスプローラで表示されるものと同じ
  • [デスクトップ] をルートにした時の [コントロールパネル] には反応しない

リスト4
コンポーネント TplExplorerFolderView のテストプログラム		 
unit Unit1;

interface

uses
  {$IF CompilerVersion < 23.0}
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, plExplorerFolderView;
  {$ELSE}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
  plExplorerFolderView, Vcl.StdCtrls;
  {$IFEND}

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    plExplorerFolderView1 : TplExplorerFolderView;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }

  end;

var
  Form1: TForm1;

implementation

uses ShlObj;

{$R *.dfm}

//-============================================================================
//  ドライブDを表示
//-============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  plExplorerFolderView1.RootFolder   := 'D:\';
  plExplorerFolderView1.ExpandFolder := 'D:\';
end;

//-============================================================================
//  [戻る]ボタン
//-============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  plExplorerFolderView1.NavigateBack;
end;

//-============================================================================
//  [進む]ボタン
//-============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  plExplorerFolderView1.NavigateForward;
end;

//-============================================================================
//  表示形式の変更
//  FVM_ICON等を使用するにはusesにShlObjが必要
//-============================================================================
procedure TForm1.Button4Click(Sender: TObject);
begin
  plExplorerFolderView1.ViewMode := FVM_ICON;
end;

end.


リスト5
コンポーネント TplExplorerFolderView のソースコード		 
unit plExplorerFolderView;

interface

uses
  {$IF CompilerVersion < 23.0}
  Windows, Messages, SysUtils, Variants, Classes, Controls, ShlObj, ActiveX,
  ExtCtrls, Graphics, Types, Forms;
  {$ELSE}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Controls, Winapi.ShlObj, Winapi.ActiveX, Vcl.ExtCtrls, Vcl.Graphics,
  System.Types, Vcl.Forms;
  {$IFEND}

type
  TpExplorerFolderViewChanged = procedure(Sender: TObject; pidlFolder: PItemIDList;
                                          AFullPath: String) of object;

  TplExplorerFolderView = class(TCustomPanel, IExplorerBrowserEvents)
  private
    FExpandFolder          : String;
    FRootFolder            : String;
    FpidlRootFolder        : PItemIDList;
    FpidlExpandFolder      : PItemIDList;
    FViewMode              : Cardinal;
    FOnExpandFolderChanged : TpExplorerFolderViewChanged;

    m_dwCookie         : DWORD;
    m_pShellView       : IShellView;
    m_pExplorerBrowser : IExplorerBrowser;

    procedure SetFExpandFolder(const Value: String);
    procedure SetFRootFolder(const Value: String);
    procedure SetFViewMode(const Value: Cardinal);
    procedure SetFpidlExpandFolder(const Value: PItemIDList);
    procedure SetFpidlRootFolder(const Value: PItemIDList);
  protected
    procedure WndProc(var Message: TMessage); override;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure Paint; override;
    procedure SetParent(AParent: TWinControl); override;
    procedure OnIdleEvent(Sender: TObject; var Done: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function NavigateBack: Boolean;
    function NavigateForward: Boolean;
    property pidlRootFolder   : PItemIDList read  FpidlRootFolder
                                            write SetFpidlRootFolder;
    property pidlExpandFolder : PItemIDList read  FpidlExpandFolder
                                            write SetFpidlExpandFolder;

    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function OnNavigationPending(pidlFolder: PItemIDList): HRESULT; stdcall;
    function OnViewCreated(const psv: IShellView): HRESULT; stdcall;
    function OnNavigationComplete(pidlFolder: PItemIDList): HRESULT; stdcall;
    function OnNavigationFailed(pidlFolder: PItemIDList): HRESULT; stdcall;
  published
    property Caption;
    property Align;
    property Anchors;
    property ExpandFolder : String   read FExpandFolder write SetFExpandFolder;
    property RootFolder   : String   read FRootFolder   write SetFRootFolder;
    property ViewMode     : Cardinal read FViewMode     write SetFViewMode;
    property OnExpandFolderChanged : TpExplorerFolderViewChanged
                                     read  FOnExpandFolderChanged
                                     write FOnExpandFolderChanged;
  end;

procedure Register;

implementation

{ TplExplolreFolderView }

//-============================================================================
//  クラス(コンポーネント)の生成
//-============================================================================
constructor TplExplorerFolderView.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  BevelOuter        := bvNone;
  FViewMode         := FVM_THUMBNAIL;
  FRootFolder       := '';
  FpidlRootFolder   := nil;
  FpidlExpandFolder := nil;

  m_dwCookie         := 0;
  m_pShellView       := nil;
  m_pExplorerBrowser := nil;

  Width  := 400;
  Height := 300;
end;

//-============================================================================
//  クラス(コンポーネント)終了処理
//-============================================================================
destructor TplExplorerFolderView.Destroy;
begin
  if m_dwCookie <> 0 then m_pExplorerBrowser.Unadvise(m_dwCookie);

  if FpidlRootFolder   <> nil then CoTaskMemFree(FpidlRootFolder);
  if FpidlExpandFolder <> nil then CoTaskMemFree(FpidlExpandFolder);

  inherited;
end;

//-============================================================================
//  ここでエクスプローラのインターフェイスオブジェクトを生成し初期化
//
//  ここで使用するインタフェイスオブジェクトは，ビジュアルなオブジェクトなので
//  OnCreateだと失敗する可能性があるので．オーバライドしたSetPrentメソッド内で
//  生成する
//  SetPrentメソッドは，コンポの生成時，破棄の際等，複数回呼出されるので注意
//
//  FOLDERSETTINGS構造体のViewModeとfFlagsの値によって表示形式の変更ができる
//
//  FOLDERSETTINGSのViewModeの値
//  FOLDERVIEWMODE Enumeration
//  http://msdn.microsoft.com/en-us/library/bb762510%28VS.85%29.aspx
//-============================================================================
procedure TplExplorerFolderView.SetParent(AParent: TWinControl);
var
  rc    : TRect;
  hr    : HRESULT;
  fs    : FOLDERSETTINGS;
  ARect : TRect;
  {$IF CompilerVersion < 23.0}
  phdwp : Cardinal;
  {$ELSE}
  phdwp : NativeUInt;
  {$IFEND}
  psbe  : IExplorerBrowserEvents;
begin
  inherited;

  if Parent = nil then exit;
  if csDesigning in ComponentState then exit;

  if m_pExplorerBrowser = nil then begin

    //ExplorerBrowserを作成するには，CoCreateInstanceにCLSID_ExplorerBrowserを指
    //定して，ExplorerBrowserを識別するIExplorerBrowserを取得する
    if Failed( CoCreateInstance(CLSID_ExplorerBrowser,
                                nil,
                                CLSCTX_INPROC_SERVER,
                                IExplorerBrowser,
                                m_pExplorerBrowser)) then exit;

    //Initializeを呼び出して取得したExplorerBrowserを初期化
    fs.ViewMode := FViewMode;
    fs.fFlags   := FWF_NOHEADERINALLVIEWS;
    SetRectEmpty(rc);
    if Failed(m_pExplorerBrowser.Initialize(Handle, rc, fs)) then exit;

    //MDSNではAdviseの第1引数は[in]であるがDelphi 2010ではvarとなっているので
    //その対策.Delphi XEではconstになっている
    //Delphi 2010でど動作しない場合は，ShlObj.pasをLibフォルダにコピーして，Advise
    //関数の第1引数をconstにする
    psbe := IExplorerBrowserEvents(Self);
    hr   := m_pExplorerBrowser.Advise(psbe, m_dwCookie);
    if Failed(hr) then exit;

    phdwp := 0;
    ARect := Rect(0, 0, Width, Height);
    m_pExplorerBrowser.SetRect(phdwp, ARect);

    Application.OnIdle := OnIdleEvent;
  end;
end;

//-============================================================================
//  透明だとコントロールの配置がしにくいのでclWhiteで塗りつぶす
//  (コンポーネントとして登録して使用する場合の対策)
//-============================================================================
procedure TplExplorerFolderView.Paint;
var
  ARect : TRect;
  Flags : Longint;
begin
  inherited Paint;

  with Canvas do begin
    Brush.Color := clWhite;
    FillRect(ClientRect);

    if Caption <> '' then begin
      ARect       := ClientRect;
      Brush.Style := bsClear;
      Font        := Self.Font;
      Flags       := DT_SINGLELINE or DT_CENTER or DT_VCENTER;
      DrawText(Handle, Caption, -1, ARect, Flags);
    end;
  end;
end;

//-============================================================================
//  ルートフォルダの設定
//  このフォルダより上の階層のフォルダは表示しない
//-============================================================================
procedure TplExplorerFolderView.SetFRootFolder(const Value: String);
var
  pidl : PItemIDList;
begin
  if (FRootFolder <> Value) or (FpidlRootFolder = nil) then begin
    FRootFolder := Value;

    //空白ならデスクトップ
    if FRootFolder = '' then begin
      SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, pidl);
    end else begin
      pidl := ILCreateFromPath(PChar(FRootFolder));
    end;

    SetFpidlRootFolder(pidl);
    if pidl <> nil then CoTaskMemFree(pidl);
  end;
end;

//-============================================================================
//  ルートフォルダの項目識別子による設定
//  pidlRootFolderプロパティの設定メソッド
//  このフォルダより上の階層のフォルダは表示しない
//-============================================================================
procedure TplExplorerFolderView.SetFpidlRootFolder(const Value: PItemIDList);
var
  pFullPath : array [0..MAX_PATH - 1] of Char;
begin
  if Value = nil then exit;

  if ILIsEqual(Value, FpidlRootFolder) = False then begin
    SHGetPathFromIDList(Value, pFullPath);
    FpidlRootFolder   := ILClone(Value);
    FRootFolder       := pFullPath;
  end;
end;

//-============================================================================
//  表示するフォルダの設定
//  ExpandFolderプロパティの設定メソッド
//  実際の値は，実装したインターフェイス関数で取得する
//-============================================================================
procedure TplExplorerFolderView.SetFExpandFolder(const Value: String);
var
  pidl : PItemIDList;
begin
  if (Value <> '') and (Value = FExpandFolder) then exit;

  //空白ならデスクトップ
  if Value = '' then begin
    if Failed(SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, pidl)) then exit;
  end else begin
    pidl := ILCreateFromPath(PChar(Value));
    if pidl = nil then exit;
  end;

  //項目識別子で表示フォルダ設定
  SetFpidlExpandFolder(pidl);

  if pidl <> nil then CoTaskMemFree(pidl);
end;

//-============================================================================
//  表示するフォルダの設定(項目識別子による設定)
//  pidlExpandFolderプロパティの設定メソッド
//-============================================================================
procedure TplExplorerFolderView.SetFpidlExpandFolder(const Value: PItemIDList);
begin
  if Value = nil then exit;

  if FpidlRootFolder = nil then SetFRootFolder('');

  //表示開始
  if ILIsEqual(Value, FpidlExpandFolder) = False then begin
    m_pExplorerBrowser.BrowseToIDList(Value, SBSP_ABSOLUTE);
  end;
end;

//-============================================================================
//  戻るメソッド
//  戻れるのは最初に表示したフォルダまで
//-============================================================================
function TplExplorerFolderView.NavigateBack: Boolean;
var
  hr : HRESULT;
begin
  Result := False;
  if FpidlExpandFolder = nil then exit;

  hr := m_pExplorerBrowser.BrowseToIDList(nil, SBSP_NAVIGATEBACK);
  Result := hr = S_OK;
end;

//-============================================================================

//  進むメソッド
//-============================================================================
function TplExplorerFolderView.NavigateForward: Boolean;
var
  hr : HRESULT;
begin
  Result := False;
  if FpidlExpandFolder = nil then exit;

  hr := m_pExplorerBrowser.BrowseToIDList(nil, SBSP_NAVIGATEFORWARD);
  Result := hr = S_OK;
end;

//-============================================================================
//  表示形式の変更
//  ViewModeプロパティの設定メソッド
//  アイコン表示の際に，カラムを非表示にするにはfFlagsを設定値を変更する
//  http://msdn.microsoft.com/en-us/library/bb762510%28VS.85%29.aspx
//  http://msdn.microsoft.com/en-us/library/bb762508%28VS.85%29.aspx
//-============================================================================
procedure TplExplorerFolderView.SetFViewMode(const Value: Cardinal);
var
  fs : FOLDERSETTINGS;
begin
  if FViewMode <> Value then begin
    FViewMode := Value;
    if m_pExplorerBrowser <> nil then begin
      fs.ViewMode := FViewMode;
      fs.fFlags   := FWF_NOCOLUMNHEADER;
      m_pExplorerBrowser.SetFolderSettings(fs);
      if m_pShellView <> nil then m_pShellView.Refresh;
    end;
  end;
end;

//-============================================================================
//  本コントロール自身には何も描画しないのでバックグラウンド消去はしない
//-============================================================================
procedure TplExplorerFolderView.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 0;
end;

//-============================================================================
//  ウィンドプロシージャー
//-============================================================================
procedure TplExplorerFolderView.WndProc(var Message: TMessage);
var
  ARect : TRect;
  {$IF CompilerVersion < 23.0}
  phdwp : Cardinal;
  {$ELSE}
  phdwp : NativeUInt;
  {$IFEND}
begin
  inherited WndProc(Message);

  if (Message.Msg = WM_SIZE) then begin
    if m_pExplorerBrowser <> nil then begin
      phdwp := 0;
      ARect := Rect(0, 0, Width, Height);
      m_pExplorerBrowser.SetRect(phdwp, ARect);
    end;
  end;
end;

//-============================================================================
//  キー関係の処理用
//  これがないと，例えば[名前の変更]操作が正常に機能しない
//  設計時にはこれを実行しないようにする．実行するとエディタが正常に機能しない
//-============================================================================
procedure TplExplorerFolderView.OnIdleEvent(Sender: TObject; var Done: Boolean);
var
  Amsg : Msg;
begin
  if csDesigning in ComponentState then exit;

  while True do begin
    if GetMessage(AMsg, 0, 0, 0) = False then begin
      PostQuitMessage(0);
      break;
    end;
    if (m_pShellView = nil) or (m_pShellView.TranslateAccelerator(AMsg) <> S_OK)
    then begin
      TranslateMessage(Amsg);
      DispatchMessage(Amsg);
    end;
  end;
end;


//------------------ 以下インターフェイス関係関数類 ---------------------------


//-----------------------------------------------------------------------------
//  参照カウンタの問題回避策
//  Delphi 2010のみ．Delphi XE, XE2では不要
//-----------------------------------------------------------------------------
function TplExplorerFolderView._AddRef: Integer;
begin
  Result := -1;
end;

//-----------------------------------------------------------------------------
//  参照カウンタの問題回避策
//  Delphi 2010のみ．Delphi XE, XE2では不要
//-----------------------------------------------------------------------------
function TplExplorerFolderView._Release: Integer;
begin
  Result := -1;
end;

//-----------------------------------------------------------------------------
//  IExplorerBrowserEvents::OnNavigationPending
//  http://msdn.microsoft.com/en-us/library/bb761890%28VS.85%29.aspx
//
//  フォルダを切り替えようとすると，最初にこのOnNavigationPendingが呼ばれる
//  S_OKを返すと新しいフォルダの中身が表示されてOnViewCreatedが発生
//  その後にOnNavigationCompleteが呼ばれる
//
//  戻ることができない場合はOnNavigationPendingは呼ばれない
//  ここではルートフォルダの階層下でないとフォルダ内の表示を変更しないようにし
//  ている
//  ILIsEqual関数で比較し，イベントを設定すれば，外部から[戻る]ボタンの非表示
//  等の制御が可能
//-----------------------------------------------------------------------------
function TplExplorerFolderView.OnNavigationPending(
  pidlFolder: PItemIDList): HRESULT;
begin
  if ILIsParent(FpidlRootFolder, pidlFolder, False) then begin
    Result := S_OK;
  end else begin
    Result := E_NOTIMPL;
  end;
end;

//-----------------------------------------------------------------------------
//  IExplorerBrowserEvents::OnViewCreated
//  http://msdn.microsoft.com/en-us/library/bb761892%28VS.85%29.aspx
//-----------------------------------------------------------------------------
function TplExplorerFolderView.OnViewCreated(const psv: IShellView): HRESULT;
begin
  m_pShellView := psv;
  Result       := S_OK;
end;

//-----------------------------------------------------------------------------
//  IExplorerBrowserEvents::OnNavigationComplete
//  http://msdn.microsoft.com/en-us/library/bb761885%28VS.85%29.aspx
//
//  フォルダ展開のイベント発行
//-----------------------------------------------------------------------------
function TplExplorerFolderView.OnNavigationComplete(
  pidlFolder: PItemIDList): HRESULT;
var
  pFullPath : array [0..MAX_PATH - 1] of Char;
begin
  //イベントに引渡し
  if ILIsEqual(FpidlExpandFolder, pidlFolder) = False then begin
    SHGetPathFromIDList(pidlFolder, pFullPath);
    FpidlExpandFolder := ILClone(pidlFolder);
    FExpandFolder     := pFullPath;

    if Assigned(FOnExpandFolderChanged) then begin
      FOnExpandFolderChanged(Self, FpidlExpandFolder, FExpandFolder);
    end;
  end;

  Result := S_OK;
end;

//-----------------------------------------------------------------------------
//  IExplorerBrowserEvents::OnNavigationFailed
//  http://msdn.microsoft.com/en-us/library/bb761887%28VS.85%29.aspx
//-----------------------------------------------------------------------------
function TplExplorerFolderView.OnNavigationFailed(
  pidlFolder: PItemIDList): HRESULT;
begin
  Result := S_OK;
end;

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

end.



03_フォルダツリーのペインをフォーム上に表示


[NameSpaceTreeControl の作成] の記事のコードを Delphi に移植したものです．指定したルートフォルダ以下をツリー表示します．コンポーネントとして利用する場合は，plExplorerFolderTree.pas をコンポーネントとして登録してください．コンポーネントのアイコンは用意していません．下表のプロパティがあります．

参考にしたページの最後の方に，IShellItemFilter の実装の説明がありますが，IShellItemFilter インターフェイスを実装すると，ルートフォルダの設定が機能しませんでした．参考サイトの記事にも説明がありますが，実装するインターフェイスの組合せによっては，正常に機能しないことがあるようです．現在のところ，ネット上でもエクスプローラの，この関係の記事は少ないため，実際にコーディングして確認するしかないようです．
INameSpaceTreeControlEvents と INameSpaceTreeControlCustomDraw インターフェイスの組合せは動作することは確認しています．
ツリーの各アイテムのイベント類の操作が必要であれば，INameSpaceTreeControlEvents インターフェイスを実装するといいかも知れません．

このサンプルのコードも，フォルダビュー (ファイルリスト) と同様，参考サイトの記事の C++ のコードをなるべく忠実に移植しましたが，2010年12月27日，Delphi らしいコードに変更しました．元となった C++ のコードは，Halbow 資料館で言えば，アプリケーションのウィンドウ生成も含まれたコードとなっています．
Delphl ではそのようなコードを作成しなくてもアプリケーションが作成できます．またインターフェイスの基本的な部分も Delphi が面倒を見てくれます．以下のコードでは，インターフェイスの関数類もコンポーネントのメンバーにしてみました．



凡例 ■ published
□ public
▲ ReadOnly

■ RootFolder String ルートフォルダ
これより下の階層のみをツリー表示する
仮想フォルダは GUID 文字列で与える
空文字の時はデスクトップ

この値か pidlRootFolder を設定しないと表示しない
■ SelectFolder String 選択フォルダ
設定はルートフォルダの階層下でないと選択しない
取得値は選択中のフォルダであるが，仮想フォルダは空文字
□ pidlRootFolder PItemIDList ルートフォルダの項目識別子
ルートフォルダは，この値か RootFolder で指定する

この値か RootFolder を設定しないと表示しない
□ pidlSelectFolder PItemIDList 選択フォルダ
デスクトップからの絶対値相当の項目識別子
設定はルートフォルダの階層下でないと選択しない
▲ hwndTree HWND フォルダツリー表示枠のウインドウハンドル
実際の表示ハンドルではないので，このハンドルに対する操作はできないが，現在の位置と大きさは取得可能


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


OnRootFolderChanged(Sender, pidlFolder, AFullPath)

ルートフォルダを変更すると発生するイベントです．

引数 型 説明
Sender TObject コンポーネント自身
pidlFolder PItemIDList ルートフォルダの項目識別子
デスクトップからの絶対値相当
AFullPath String ルートフォルダのフルパス
仮想フォルダの場合は空文字 


OnSelectFolderChanged(Sender, pidlFolder, AFullPath)

選択フォルダが変更すると発生するイベントです．

引数 型 説明
Sender TObject コンポーネント自身
pidlFolder PItemIDList 選択したフォルダの項目識別子
デスクトップからの絶対値相当
AFullPath String 選択したフォルダのフルパス
仮想フォルダの場合は空文字


図8
テストプログラムの設計時画面
図9
デスクトップをルートフォルダに
  • フォルダのみ表示している
    INameSpaceTreeControl インターフェイスの AppendRoot メソッドの引数で変更可能
  • [コントロールパネル] は展開はするが，起動はしない
図10
ネットワークをルートフォルダに

リスト6
コンポーネント TplExplorerFolderTree のテストプログラム		 
unit Unit1;

interface

uses
  {$IF CompilerVersion < 23.0}
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, plExplorerFolderTree;
  {$ELSE}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
  Vcl.StdCtrls, plExplorerFolderTree;
  {$IFEND}

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

  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//-============================================================================
//  クラスのオブジェクトを生成してデスクトップをルートフォルダに設定
//-============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  plExplorerFolderTree1.RootFolder := '';
end;

//-============================================================================
//  ドライブDをフォルダツリー表示
//-============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  plExplorerFolderTree1.RootFolder := 'D:\';
end;

//-============================================================================
//  ネットワーク(CSIDL_NETWORK)をフォルダリー表示
//-============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  plExplorerFolderTree1.RootFolder := '::{F02C1A0D-BE21-4350-88B0-7367FC96EF3C}';
end;

end.


リスト7
コンポーネント TplExplorerFolderTree のソースコード		 
unit plExplorerFolderTree;

interface

uses
  {$IF CompilerVersion < 23.0}
  Windows, Messages, SysUtils, Variants, Classes, Controls, ShlObj, ActiveX,
  ExtCtrls, Graphics, Types, Forms;
  {$ELSE}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Controls, Winapi.ShlObj, Winapi.ActiveX, Vcl.ExtCtrls, Vcl.Graphics,
  System.Types, Vcl.Forms;
  {$IFEND}

type
  TpExplorerFolderTreeChanged  = procedure(Sender: TObject; pidlFolder: PItemIDList;
                                          AFullPath: String) of object;

  TplExplorerFolderTree = class(TCustomPanel, INameSpaceTreeControlCustomDraw)
  private
    FRootFolder           : String;
    FSelectFolder         : String;
    FpidlRootFolder       : PItemIDList;
    FpidlSelectFolder     : PItemIDList;
    FOnRootFolderChanged  : TpExplorerFolderTreeChanged;
    FOnSelctFolderChanged : TpExplorerFolderTreeChanged;

    FhwndTree               : HWND;
    m_dwTreeCookie          : DWORD;
    m_pNameSpaceTreeControl : INameSpaceTreeControl;
    m_pShellItem            : IShellItem;

    procedure SetFRootFolder(const Value: String);
    procedure SetFSelectFolder(const Value: String);
    procedure SetFpidlSelectFolder(const Value: PItemIDList);
  protected
    procedure WndProc(var Message: TMessage); override;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure Paint; override;

    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;

    function PrePaint(hdc: HDC; var prc: TRect;
      var plres: LRESULT): HRESULT; stdcall;
    function PostPaint(hdc: HDC; var prc: TRect): HRESULT; stdcall;
    function ItemPrePaint(hdc: HDC; var prc: TRect; var pnstccdItem: TNSTCCustomDraw;
      var pclrText: COLORREF; var pclrTextBk: COLORREF;
      var plres: LRESULT): HRESULT; stdcall;
    function ItemPostPaint(hdc: HDC; var prc: TRect;
      var pnstccdItem: TNSTCCustomDraw): HRESULT; stdcall;

    procedure SetParent(AParent: TWinControl); override;
    procedure OnIdleEvent(Sender: TObject; var Done: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property pidlRootFolder   : PItemIDList read FpidlRootFolder;
    property pidlSelectFolder : PItemIDList read FpidlSelectFolder
                                            write SetFpidlSelectFolder;
    property hwndTree : HWND read FhwndTree;

  published
    property Caption;
    property Align;
    property Anchors;
    property RootFolder   : String read FRootFolder   write SetFRootFolder;
    property SelectFolder : String read FSelectFolder write SetFSelectFolder;
    property OnRootFolderChanged   : TpExplorerFolderTreeChanged
                                     read  FOnRootFolderChanged
                                     write FOnRootFolderChanged;
    property OnSelectFolderChanged : TpExplorerFolderTreeChanged
                                     read  FOnSelctFolderChanged
                                     write FOnSelctFolderChanged;
  end;

  fIUnknown_GetWindow = function (punk: IUnknown; out phwnd: HWND): HRESULT; stdcall;

  procedure Register;

implementation

const
  CDRF_DODEFAULT         = $00000000;
  CDRF_NEWFONT           = $00000002;
  CDRF_SKIPDEFAULT       = $00000004;
  CDRF_DOERASE           = $00000008;
  CDRF_NOTIFYPOSTPAINT   = $00000010;
  CDRF_NOTIFYITEMDRAW    = $00000020;
  CDRF_NOTIFYSUBITEMDRAW = $00000020;
  CDRF_NOTIFYPOSTERASE   = $00000040;
  CDRF_SKIPPOSTPAINT     = $00000100;

  CDIS_SELECTED         = $0001;
  CDIS_GRAYED           = $0002;
  CDIS_DISABLED         = $0004;
  CDIS_CHECKED          = $0008;
  CDIS_FOCUS            = $0010;
  CDIS_DEFAULT          = $0020;
  CDIS_HOT              = $0040;
  CDIS_MARKED           = $0080;
  CDIS_INDETERMINATE    = $0100;
  CDIS_SHOWKEYBOARDCUES = $0200;
  CDIS_NEARHOT          = $0400;
  CDIS_OTHERSIDEHOT     = $0800;
  CDIS_DROPHILITED      = $1000;

var
  IUnknown_GetWindow : fIUnknown_GetWindow;

{ TplExplorerFolderTree }

//-============================================================================
//  フォルダツリーオブジェクトを乗せる(表示する)TWinControlの生成
//-============================================================================
constructor TplExplorerFolderTree.Create(AOwner: TComponent);
var
  DLLHandle : THandle;
begin
  inherited Create(AOwner);

  DLLHandle := LoadLibrary('shlwapi.dll');
  if DLLHandle <> 0 then begin
    @IUnknown_GetWindow := GetProcAddress(DLLHandle,'IUnknown_GetWindow');
  end;

  BevelOuter              := bvNone;
  FRootFolder             := '';;
  FSelectFolder           := '';
  FpidlRootFolder         := nil;
  FpidlSelectFolder       := nil;
  m_dwTreeCookie          := 0;
  m_pNameSpaceTreeControl := nil;
  m_pShellItem            := nil;

  Width  := 250;
  Height := 300;
end;

//-============================================================================
//  フォルダツリーオブジェクトを乗せる(表示する)TWinControlの解放処理
//-============================================================================
destructor TplExplorerFolderTree.Destroy;
begin
  if m_dwTreeCookie <> 0 then m_pNameSpaceTreeControl.TreeUnadvise(m_dwTreeCookie);

  if FpidlRootFolder   <> nil then CoTaskMemFree(FpidlRootFolder);
  if FpidlSelectFolder <> nil then CoTaskMemFree(FpidlSelectFolder);

  inherited;
end;

//-============================================================================
//  コンポのSetParentメソッド
//  ここでエクスプローラのインターフェイスオブジェクトを生成
//
//  INameSpaceTreeControインタフェイスオブジェクトは，ビジュアルなオブジェクト
//  なのでOnCreateだと失敗する可能性があるので，オーバライドしたSetPrentメソッ
//  ド内で生成する
//  SetPrentメソッドは，コンポの生成時，破棄の際等，複数回呼出されるので注意
//-============================================================================
procedure TplExplorerFolderTree.SetParent(AParent: TWinControl);
var
  rc  : TRect;
begin
  inherited;

  if Parent = nil then exit;
  if csDesigning in ComponentState then exit;

  if m_pNameSpaceTreeControl = nil then begin
    //INameSpaceControlインターフェイスのオブジェクトを生成して取得
    if Failed(CoCreateInstance(CLSID_NamespaceTreeControl,
                               nil,
                               CLSCTX_INPROC_SERVER,
                               INameSpaceTreeControl,
                               m_pNameSpaceTreeControl)) then exit;

    //取得したオブジェクトの初期化
    SetRectEmpty(rc);
    if Failed(m_pNameSpaceTreeControl.Initialize(
                               Handle,
                               rc,
                               NSTCS_HASEXPANDOS or
                               NSTCS_SHOWSELECTIONALWAYS or
                               NSTCS_BORDER or
                               NSTCS_TABSTOP)) then exit;

    //オブジェクトの有効化(操作の通知を受け取り可能にする)
    if Failed(m_pNameSpaceTreeControl.TreeAdvise(
                               INameSpaceTreeControlCustomDraw(Self),
                               m_dwTreeCookie)) then exit;

    //フォルダツリーのハンドル(HwndTree)を取得
    IUnknown_GetWindow(m_pNameSpaceTreeControl, FhwndTree);

    Application.OnIdle := OnIdleEvent;
  end;
end;

//-============================================================================
//  透明だとコントロールの配置がしにくいのでclWhiteで塗りつぶす
//  (コンポーネントとして登録して使用する場合の対策)
//  WM_ERASEBKGNDでバックグラウンドの消去を行っていないので，描画はすべてPaint
//  メソッドで実行する必要がある
//-============================================================================
procedure TplExplorerFolderTree.Paint;
var
  ARect : TRect;
  Flags : Longint;
begin
  inherited Paint;

  with Canvas do begin
    Brush.Color := clWhite;
    FillRect(ClientRect);

    if Caption <> '' then begin
      ARect       := ClientRect;
      Brush.Style := bsClear;
      Font        := Self.Font;
      Flags       := DT_SINGLELINE or DT_CENTER or DT_VCENTER;
      DrawText(Handle, Caption, -1, ARect, Flags);
    end;
  end;
end;

//-============================================================================
//  ルートフォルダの設定
//  RootFolderプロパティの設定メソッド
//  このフォルダより上の階層のフォルダは表示しない
//-============================================================================
procedure TplExplorerFolderTree.SetFRootFolder(const Value: String);

  //---------------------------------------------------------------------------
  //  実際のルートフォルダ設定と，現在表示中のツリー削除
  //---------------------------------------------------------------------------
  function SetRoot_TreeControlHost(pidl: PItemIDList): Boolean;
  var
    pShellItem : IShellItem;
  begin
    Result := False;

    if Failed(SHCreateItemFromIDList(pidl, IShellItem, pShellItem)) then exit;

    //取得したm_pShellItemからルートフォルダを生成してツリー生成
    //ここではフォルダ(SHCONTF_FOLDERS)のみの表示に設定
    if Failed(m_pNameSpaceTreeControl.AppendRoot(
                                pShellItem,
                                SHCONTF_FOLDERS,
                                NSTCRS_VISIBLE or NSTCRS_EXPANDED,
                                nil)) then exit;

    //既にルートフォルダの設定があれば削除
    //最初に削除するとアイテムが正常表示しない場合がある
    if m_pShellItem <> nil then begin
      if Failed(m_pNameSpaceTreeControl.RemoveRoot(m_pShellItem)) then exit;
    end;
    //新しいShellItemオブジェクト
    m_pShellItem := pShellItem;
    pShellItem   := nil;

    Result := True;
  end;
  //---------------------------------------------------------------------------

var
  pidl : PItemIDList;
begin
  if @IUnknown_GetWindow = nil then exit;
  if (Value <> '') and (Value = FRootFolder) then exit;

  pidl := nil;

  //空文字ならデスクトップをルートフォルダにする
  //空文字以外の場合は，項目識別子を求めてそれに該当するフォルダをルートにする
  if Value = '' then begin
    SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, pidl);
  end else begin
    pidl := ILCreateFromPath(PChar(Value));
    if pidl = nil then exit;
  end;

  //実際のルートフォルダの設定
  if SetRoot_TreeControlHost(pidl) = False then begin
    CoTaskMemFree(pidl);
    exit;
  end;

  FRootFolder     := Value;
  FpidlRootFolder := ILClone(pidl);

  //イベントに引渡し
  if Assigned(FOnRootFolderChanged) then begin
    FOnRootFolderChanged(Self, FpidlRootFolder, FRootFolder);
  end;
  CoTaskMemFree(pidl);
end;

//-============================================================================
//  選択フォルダの指定
//  SelectFolderプロパティの設定メソッド
//-============================================================================
procedure TplExplorerFolderTree.SetFSelectFolder(const Value: String);
var
  pidl : PItemIDList;
begin
  if Value = ''  then exit;

  //フォルダのパス名から項目識別子を取得
  pidl := ILCreateFromPath(PChar(Value));
  if pidl = nil then exit;
  if ILIsEqual(FpidlSelectFolder, pidl) then begin
    CoTaskMemFree(pidl);
    exit;
  end;

  SetFpidlSelectFolder(pidl);
  CoTaskMemFree(pidl);
end;

//-============================================================================
//  選択フォルダの設定(項目識別子による設定)
//  pidlSelectFolderプロパティの設定メソッド
//-============================================================================
procedure TplExplorerFolderTree.SetFpidlSelectFolder(const Value: PItemIDList);
var
  pShellItem : IShellItem;
  nsMask     : NSTCITEMSTATE;
  nsFlags    : NSTCITEMSTATE;
begin
  if Value = nil then exit;

  if ILIsEqual(Value, FpidlSelectFolder) = False then begin
    //ルートフォルダの階層下かを調査
    if ILIsParent(FpidlRootFolder, Value, False) = False then begin
      exit;
    end;

    //項目識別子からIShellItemオブジェクトを取得
    if Failed(SHCreateItemFromIDList(Value, IShellItem, pShellItem)) then begin
      exit;
    end;

    //取得したIShellItemを使用してSetItemStateメソッドを実行して選択
    //nsMaskにNSTCIS_EXPANDEDを含めればサブフォルダも展開する
    nsMask  := NSTCIS_SELECTED;
    nsFlags := nsMask;
    m_pNameSpaceTreeControl.SetItemState(pShellItem, nsMask, nsFlags);

    pShellItem        := nil;
    FpidlSelectFolder := ILClone(Value);
  end;
end;

//-============================================================================
//  チラつき防止
//  本コントロール自身には何も描画しないのでバックグラウンド消去はしない
//-============================================================================
procedure TplExplorerFolderTree.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 0;
end;

//-============================================================================
//  ウィンドウプロシージャー
//  フォルダツリーの位置とサイズの設定等
//-============================================================================
procedure TplExplorerFolderTree.WndProc(var Message: TMessage);
begin
  inherited WndProc(Message);

  if Message.Msg = WM_SIZE then begin
    if (FhwndTree <> 0) then begin
      MoveWindow(FhwndTree, 0, 0, Width, Height, True);
    end;
  end;
end;

//-============================================================================
//  キー関係の処理用
//  これがないと，アクセラレータキーの動作が正しく行われない
//  設計時にはこれを実行しないようにする．実行するとエディタが正常に機能しない
//-============================================================================
procedure TplExplorerFolderTree.OnIdleEvent(Sender: TObject; var Done: Boolean);
var
  Amsg : Msg;
begin
  if csDesigning in ComponentState then exit;

  while True do begin
    if GetMessage(AMsg, 0, 0, 0) = False then begin
      PostQuitMessage(0);
      break;
    end;
    TranslateMessage(Amsg);
    DispatchMessage(Amsg);
  end;
end;


//------------------ 以下インターフェイス関係関数類 ---------------------------


//-----------------------------------------------------------------------------
//  参照カウンタの問題回避策
//  Delphi 2010のみ．Delphi XE, XE2では不要
//-----------------------------------------------------------------------------
function TplExplorerFolderTree._AddRef: Integer;
begin
  Result := -1;
end;

//-----------------------------------------------------------------------------
//  参照カウンタの問題回避策
//  Delphi 2010のみ．Delphi XE, XE2では不要
//-----------------------------------------------------------------------------
function TplExplorerFolderTree._Release: Integer;
begin
  Result := -1;
end;

//-----------------------------------------------------------------------------
//  INameSpaceTreeControlCustomDraw::ItemPostPaint
//  http://msdn.microsoft.com/en-us/library/bb761616%28v=VS.85%29.aspx
//-----------------------------------------------------------------------------
function TplExplorerFolderTree.ItemPostPaint(hdc: HDC; var prc: TRect;
  var pnstccdItem: TNSTCCustomDraw): HRESULT;
begin
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
//  INameSpaceTreeControlCustomDraw::ItemPrePaint
//  http://msdn.microsoft.com/en-us/library/bb761617%28v=VS.85%29.aspx
//
//  選択したアイテムのテキスト色を変更
//  選択したフォルダに対するイベント
//-----------------------------------------------------------------------------
function TplExplorerFolderTree.ItemPrePaint(hdc: HDC; var prc: TRect;
  var pnstccdItem: TNSTCCustomDraw; var pclrText, pclrTextBk: COLORREF;
  var plres: LRESULT): HRESULT;
var
  pShellItem      : IShellItem;
  pShellItemArray : IShellItemArray;
  pidl            : PItemIDList;
  pFullPath       : array [0..MAX_PATH - 1] of Char;
begin
  if (pnstccdItem.uItemState and CDIS_FOCUS) > 0 then begin
    pclrText := RGB(200, 0, 0);
    plres    := CDRF_NEWFONT;
  end;

  //選択したアイテムのフルパスを取得
  //ただし仮想フォルダは空文字
  if (pnstccdItem.uItemState and CDIS_SELECTED) > 0 then begin
    if m_pNameSpaceTreeControl.GetSelectedItems(pShellItemArray) = S_OK then begin
      if Succeeded( pShellItemArray.GetItemAt(0, pShellItem)) then begin
        if Succeeded(SHGetIDListFromObject(pShellItem, pidl)) then begin

          if ILIsEqual(FpidlSelectFolder, pidl) = False then begin
            SHGetPathFromIDList(pidl, pFullPath);
            FpidlSelectFolder := ILClone(pidl);
            FSelectFolder     := pFullPath;

            //イベントに引渡し
            if Assigned(FOnSelctFolderChanged) then begin
              FOnSelctFolderChanged(Self, FpidlSelectFolder, FSelectFolder);
            end;
          end;
          CoTaskMemFree(pidl);
        end;
        pShellItem := nil;
      end;
      pShellItemArray := nil;
    end;
  end;

  Result := S_OK;
end;

//-----------------------------------------------------------------------------
//  INameSpaceTreeControlCustomDraw::PostPaint
//  http://msdn.microsoft.com/en-us/library/bb761618%28v=VS.85%29.aspx
//-----------------------------------------------------------------------------
function TplExplorerFolderTree.PostPaint(hdc: HDC; var prc: TRect): HRESULT;
begin
  Result := S_OK;
end;

//-----------------------------------------------------------------------------
//  INameSpaceTreeControlCustomDraw::PrePaint
//  http://msdn.microsoft.com/en-us/library/bb761619%28v=VS.85%29.aspx
//-----------------------------------------------------------------------------
function TplExplorerFolderTree.PrePaint(hdc: HDC; var prc: TRect;
  var plres: LRESULT): HRESULT;
begin
  plres  := CDRF_NOTIFYITEMDRAW;
  Result := S_OK;
end;

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

end.



04_フォルダツリーとフォルダビューをフォーム上に表示


上のサンプルで使用したユニット，plExplorerFolderView.pas と plExplorerFolderTree.pas を使用してフォルダツリーとフォルダビュー(ファイルリスト)を表示します．いわゆる「ファイラー」という部類のアプリケーションになるのでしょうか．フォルダツリーとフォルダビューとの連携はイベントで行っています．
他のシェルコンポーネント類のように，フォルダツーとフォルダビューのコードを 1 つのユニットにまとめて，ユニット内で処理する方がいいかも知れません．


図11
テストプログラムの設計時画面
  • TPanel を配置し，その上に以下を配置
  • TplExplorerFolderTree
  • TSplitter(リサイズ用)
  • TplExplorerFolderView
図12
実行して [デスクトップ]
  • ツリー部の [コントロールパネル] は展開はするが，機能しない
  • ファイルリストの [コントロールパネル] はクリックしても反応しない
図13
[D:\]

リスト8
コンポーネント TplExplorerFolderView と TplExplorerFolderTree を組合わせたテスト 
unit Unit1;

interface

uses
  {$IF CompilerVersion < 23.0}
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, plExplorerFolderTree, plExplorerFolderView, ShlObj;
  {$ELSE}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
  Vcl.StdCtrls, plExplorerFolderTree, plExplorerFolderView, Winapi.ShlObj;
  {$IFEND}


type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Panel1: TPanel;
    plExplorerFolderTree1: TplExplorerFolderTree;
    Splitter1: TSplitter;
    plExplorerFolderView1: TplExplorerFolderView;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure plExplorerFolderTree1SelectFolderChanged(Sender: TObject;
      pidlFolder: PItemIDList; AFullPath: string);
    procedure plExplorerFolderView1ExpandFolderChanged(Sender: TObject;
      pidlFolder: PItemIDList; AFullPath: string);
    procedure plExplorerFolderTree1RootFolderChanged(Sender: TObject;
      pidlFolder: PItemIDList; AFullPath: string);
  private
    { Private 宣言 }
  public
    { Public 宣言 }

  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// -============================================================================
//  フォルダツリーのルートフォルダをデスクトップに設定して表示
//  フォルダビュー(ファイルリスト)はイベントで設定
//
//  ドライブD:\をルートにした後にデスクトップをルートにすると，ドライブD:\は
//  デスクトップの階層下なので，ドライブD:\が選択状態となる
// -============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  plExplorerFolderTree1.RootFolder := '';
end;

// -============================================================================
// ドライブD:\をルートフォルダに設定
// -============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  plExplorerFolderTree1.RootFolder := 'D:\';
end;

// -============================================================================
// ネットワーク(CSIDL_NETWORK)をフォルダリー表示
// -============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  plExplorerFolderTree1.RootFolder := '::{F02C1A0D-BE21-4350-88B0-7367FC96EF3C}';
end;

// -============================================================================
// フォルダツリーのルートフォルダ変更イベント
// フォルダビュー(ファイルリスト)のルートフォルダも変更しておく
//
// PItemIDListの利用にはusesにShlObjが必要
// -============================================================================
procedure TForm1.plExplorerFolderTree1RootFolderChanged(Sender: TObject;
  pidlFolder: PItemIDList; AFullPath: string);
begin
  plExplorerFolderView1.pidlRootFolder := pidlFolder;
end;

// -============================================================================
// フォルダツリーの選択フォルダ変更イベント
// フォルダビュー(ファイルリスト)の展開(Expand)フォルダも変更
// -============================================================================
procedure TForm1.plExplorerFolderTree1SelectFolderChanged(Sender: TObject;
  pidlFolder: PItemIDList; AFullPath: string);
begin
  plExplorerFolderView1.pidlExpandFolder := pidlFolder;
end;

// -============================================================================
// フォルダビューの展開フォルダ変更イベント
// フォルダツリーの選択フォルダも変更
// -============================================================================
procedure TForm1.plExplorerFolderView1ExpandFolderChanged(Sender: TObject;
  pidlFolder: PItemIDList; AFullPath: string);
begin
  plExplorerFolderTree1.pidlSelectFolder := pidlFolder;
end;

end.