Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2008年12月05日] [更新 2013年11月16日] Delphi サンプルプログラム集
   
802_フォルダの参照ダイアログとコールバック関数
動作確認等 Windows 7 U64(SP1) + Delphi XE Pro
802_FolderBrowserCallback.zip [1,673 KB] 2013年11月16日版(EXE同梱)



  • 2008年12月07日
  • コンポーネントのオプション (表示スタイル) をオブジェクトインスペクタで設定可能にした
  • この変更によりテストプログラムのコードも変更
  • 2010年10月10日
  • ファイル関連ダイアログコンポーネントの整備に伴いコンポーネントの添付を中止し,[コンポーネント化] の項の説明を変更
  • 2013年11月16日
  • コンポーネントを再添付.それに伴いそのコンポーネントを使用したサンプルを追加




01_フォルダの参照ダイアログとコールバック関数


[801_フォルダの参照ダイアログ] でフォルダの参照ダイアログのテストをしましたが,表示位置の指定を行なったり,スタイルをカスタマイズするには,コールバック関数を使用します.
コールバック関数は,SHBrowseForFolder 関数の引数,TBrowseInfo 構造体のメンバで設定します.

この SHBrowseFolder 関数では,フォルダやファイルを,ウィンドウズのシェルの項目識別子というもので管理しています.この項目識別子をエクスプローラ等に表示している文字列に変換したり,逆に項目識別子に変換するコードが必要となってきます.
この項目識別子は,シェルメモリアロケータという特別なメモリ領域を使用します.このメモリ領域は SHGetMalloc 関数で割り当て,使用終了した項目識別子は IMalloc インターフェイスの Free メソッドで解放します.解放しないと使用メモリが増大していく場合があります.

本ページのサンプルは,下表を参考にして作成しています.TForm1 の Button1 クリックでダイアログを表示していますが,別のユニットに関数として作成しておけば,必要な時に呼出して使用することができます.
なお,Delphi では,uses に ShlObj や ComObj がある場合,特に OleInitialize,CoInitialize 関数等で COM の初期化を行う必要はありません (古い Delphi を除く).

このページのサンプルでは,TBrowseInfo 構造体のメンバの InitDir を表示開始時に選択状態にするフォルダ,X と Y を表示位置の指定に使用しています.

Windows Vista 以降に追加された特殊フォルダを扱う方法は,[801_フォルダの参照ダイアログ] の記事を参考にしてください.



表1
SHBrowseForFolder の引数 TBrowseInfo 構造体のメンバ
関数の戻り値は,選択したフォルダの項目識別子 (型は PItemIDList)

hwndOwner HWND ダイアログのオーナーのウィンドウハンドル
pidlRoot PItemIDList ルートフォルダの項目識別子
pszDisplayName PAnsiChar 選択したフォルダの名前
lpszTitle PAnsiChar ダイアログ上部に表示する文字列
ulFlags UINT ダイアログの表示形式等を指定する値の組合わせ
下表参照
lpfn TFNBFFCallBack コールバック関数のアドレス
lParam LParam コールバック関数に渡すパラメータ
以下の TBFFRecord 構造体の各値で指定する
この構造体は Delphi にはないので定義して使用する
使い方は自由

type
  PBFFRecord = ^TBFFRecord;
  TBFFRecord = record
  InitDir : PChar;
  X : Integer;
  Y : Integer;
end;
iImage Integer 選択フォルダのシステムイメージリスト内のインデックス


表2
上の表の ulFlag の値で,ダイアログのスタイルを指定する定数値
全てが ShlObj.pas で定義されているわけではない.ない場合は自分で定義するか直接数値を指定
Windows のバージョンによっては使用できないものもある
この表の値は,Windows Vista 以降で使用可能

BIF_RETURNONLYFSDIRS $0001 ファイルシステムディレクトリのみを選択可能
BIF_DONTGOBELOWDOMAIN $0002 ドメインのネットワークフォルダを表示しない
BIF_STATUSTEXT $0004 ダイアログツリー部のすぐ上に文字列を表示する
コールバック関数内で処理する必要がある
BIF_RETURNFSANCESTORS $0008 ルート以下のファイル,フォルダのみ選択可能
BIF_EDITBOX $0010 名前編集用ボックスを表示
BIF_VALIDATE $0020 名前編集ボックスへの無効な文字列をチェックする
BIF_EDITBOX の指定がある時のみ有効
処理はコールバック関数内で行う
BIF_NEWDIALOGSTYLE $0040 以下の新しいスタイルのダイアログを表示
  リサイズ可能
  ダイアログへのドラッグアンドドロップ
  フォルダの再整理
  ショートカットメニュー (コンテキスト)
  新しいフォルダの作成
BIF_USENEWUI $0050 名前編集ボックスのある新しいスタイル
BIF_EDITBOX or BIF_NEWDIALOGSTYLE 指定と同じ
BIF_BROWSEINCLUDEURLS $0080 URLを表示可能とする
BIF_USENEWUIとBIF_BROWSEINCLUDEFILES の指定必要
該当フォルダがサポートする場合のみ表示
BIF_UAHINT $0100 名前編集ボックスの代わりにヒントを表示
BIF_NEWDIALOGSTYLE の指定も必要
BIF_NONEWFOLDERBUTTON $0200 [新しいフォルダの作成] ボタンを表示しない
BIF_NEWDIALOGSTYLE の指定も必要
BIF_NOTRANSLATETARGETS $0400 選択アイテムがショートカットの場合,リンク先ではなく,ショートカット自身の項目識別子を返す
BIF_BROWSEFORCOMPUTER $1000 コンピュータのみ選択可能とする
BIF_BROWSEFORPRINTER $2000 プリンタのみ選択可能とする
BIF_BROWSEINCLUDEFILES $4000 ファイルも表示して選択可能とする
BIF_SHAREABLE $8000 共有リソースを表示して選択可能にする
BIF_USENEWUI の指定も必要


表3
コールパック関数の引数
関数名と引数の名前は任意だが,型とその順序は一致させる

hwindow HWND ダイアログのハンドル
uMsg UINT ダイアログが発行するメッセージで以下のいずれか
BFFM_INITIALIZED
  ダイアログは初期設定の状態にある.lParam は 0
  ダイアログの表示位置などが設定可能
BFFM_SELCHANGED
  フォルダが選択された時に発生
  lParam の値は選択されたフォルダの項目識別子
BFFM_VALIDATEFAILED
  名前編集ボックスに無効な文字列が入力された場合に発生
lParam LPARAM uMsg の値によって異なる
lpData LPARAM SHBrowseForFolder 関数の引数
TBrowseInfo 構造体のメンバ のアドレス


図1
設計時画面
図2
実行してルートフォルダを選択
  • CSIDL_PROGRAMS をルートフォルダにしてみる
図3
フォルダの参照ダイアログを表示
  • 確かにプログラムとなっているが
  • これが CSIDL_PROGRAMS なのか
  • Vistaでは ? Windows XP とは何か違う

リスト1
SHBrowseForFolder 関数を使用して,フォルダの参照ダイアログを表示
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    ComboBox1: TComboBox;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ShlObj, ActiveX;

type
  PBFFRecord = ^TBFFRecord;
  TBFFRecord = record
  InitDir : PChar;
  X  : Integer;
  Y  : Integer;
end;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  SHBrowseForFolder関数ののコールバック関数のコード例
//
//  [引数]
//  hWindow  ダイアログのハンドル
//  uMsg     ダイアログが発行するメッセージ
//  lParam   uMsgに応じた値
//  lpData   呼出し側のTBFFRecord構造体のポインタ
//-----------------------------------------------------------------------------
function plBrowseExCallBack(hWindow: HWND; uMsg: UINT; lParam: LPARAM;
  lpData: LPARAM): Integer; stdcall;
var
   PathName  : array[0..MAX_PATH-1] of Char;
   APath     : String;
   PBFFR     : PBFFRecord;
   ARect     : TRect;
   APosX     : Integer;
   APosY     : Integer;
   DlgWidth  : Integer;
   DlgHeight : Integer;
begin
  case uMsg of

  //ダイアログの表示開始初期状態
  BFFM_INITIALIZED:
    begin
      PBFFR := pointer(lpData);
      //初期選択フォルダ名が空でなければ,それを選択状態にする
      //それにはダイアログウィンドウにBFFM_SETSELECTIONメッセージを送る
      if lstrlen(PBFFR^.InitDir) > 1 then begin
        SendMessage(hWindow,BFFM_SETSELECTION,1,Integer(PBFFR^.InitDir));
      end;
      //表示位置の設定
      APosX := PBFFR^.X;
      APosY := PBFFR^.Y;

      //表示指定の座標値が共に-1であれば画面の中央に表示
      //そうでないと時はAPosXとAPosYで指定する値
      if (APosX < 0) and (APosY < 0) then begin
        GetWindowRect(hWindow,ARect);
        DlgWidth  := ARect.Right-ARect.Left;
        DlgHeight := ARect.Bottom-ARect.Top;
        APosX := (GetSystemMetrics(SM_CXSCREEN) - DlgWidth)  div 2;
        APosY := (GetSystemMetrics(SM_CYSCREEN) - DlgHeight) div 2;
      end;
      SetWindowPos(hWindow, 0, APosX, APosY, 0, 0, SWP_NOSIZE or SWP_NOZORDER);
    end;

  //フォルダまたはファイルが選択された
  BFFM_SELCHANGED:
    begin
      //選択しているフォルダの項目識別子をパス文字列に変換
      //それをステータス表示部に表示
      //TBrowseInfo構造体のulFlagsにBIF_STATUSTEXTを指定した時の処理方法例
      SHGetPathFromIDList(PItemIDList(lParam), Addr(PathName));
      APath := PathName;
      SendMessage(hWindow,
                  BFFM_SETSTATUSTEXT,
                  0,
                  LongInt(PChar(ExtractFileName(APath))));
    end;
  end;
  //このコールバック関数は常に0を返さなければいけない
  Result := 0;
end;

//-----------------------------------------------------------------------------
//  SHBrowseForFolder関数でフォルダの参照ダイアログを表示する
//  戻り値は選択したフォルダのフルパス文字列
//
//  [引数]
//  RootDir  ルートフォルダ.CSIDL値で指定する
//  InitDir  表示開始時に選択するフォルダ.フルパスの文字列で指定する
//  Flags    表示スタイルの指定.BIF_XXXXの組合わせで指定する
//  X        ダイアログの表示位置.左上のX座標値
//  Y        同上.左上のY座標値
//-----------------------------------------------------------------------------
function plBrowseForderEx(RootDir:Integer; InitDir: String; Flags: UINT;
   X,Y:Integer): String;
var
   AFileDir     : String;
   BFFR         : TBFFRecord;
   IDList       : PItemIDList;
   BrowseInfo   : TBrowseInfo;
   BPathName    : array[0..MAX_PATH-1] of Char;
   BDisplayName : array[0..MAX_PATH-1] of Char;
   Malloc       : IMalloc;
begin
   SHGetMalloc(Malloc);
   FillChar(BrowseInfo, SizeOf(BrowseInfo), #0);

   //CSIDL値を項目識別子に変換
   SHGetSpecialFolderLocation(Application.Handle, RootDir, IDList);

   AFileDir     := InitDir;
   BFFR.InitDir := PChar(AFileDir);
   BFFR.X       := X;
   BFFR.Y       := Y;

   BrowseInfo.hwndOwner      := Application.Handle;
   BrowseInfo.pidlRoot       := IDList;
   BrowseInfo.pszDisplayName := BDisplayName;
   BrowseInfo.lpszTitle      := PChar('フォルダの指定');
   BrowseInfo.ulFlags        := Flags;
   BrowseInfo.lpfn           := Addr(plBrowseExCallBack);
   BrowseInfo.lParam         := integer(Addr(BFFR));

   IDList := SHBrowseForFolder(BrowseInfo);
   if IDList <> nil then begin
     //BrowseInfo.pszDisplayNameだとパス部分がない名前
     SHGetPathFromIDList(IDList,Addr(BPathName));
     Result := BPathName;
     Malloc.Free(IDList);
   end;
end;

//=============================================================================
//  上の関数をテストするコード
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  RootDir : Integer;
  InitDir : String;
  Flags   : UINT;
  PosX    : Integer;
  PosY    : Integer;
begin
  //ルートと初期選択フォルダ
  //RootDir := 0; の時はデスクトップ
  RootDir := 0;
  if ComboBox1.Text <> '' then begin
    if ComboBox1.ItemIndex >= 1 then begin
      RootDir := Integer(ComboBox1.Items.Objects[ComboBox1.ItemIndex]);
    end else begin
      InitDir := ComboBox1.Text;
    end;
  end;

  //表示開始位置
  //共に-1だと画面中央
  PosX := -1;
  PosY := -1;

  //表示スタイル
  Flags := BIF_RETURNONLYFSDIRS or BIF_STATUSTEXT;

  //次回はInitDirを選択フォルダにするためにInitDirに結果を取得
  InitDir := plBrowseForderEx(RootDir, InitDir, Flags, PosX, PosY);
  if InitDir <> '' then begin
    ComboBox1.Text := InitDir;
    Panel1.Caption := ' ' + InitDir;
  end;
end;

//=============================================================================
//  特殊フォルダのCSIDL値をセット
//  これをルートフォルダにする
//  Vista以降にしか対応していないCSIDL_値があるので定数ではなく実値を格納
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  ComboBox1.Text := '';
  ComboBox1.AutoComplete := False;

  //ルートフォルダ用の値をセット
  with ComboBox1.Items do begin
    Clear;
    //このプロジェクトのフォルダ
    Add( ExtractFileDir(ParamStr(0)));
    AddObject('CSIDL_DESKTOP',                 TObject($0000));
    AddObject('CSIDL_INTERNET',                TObject($0001));
    AddObject('CSIDL_PROGRAMS',                TObject($0002));
    AddObject('CSIDL_CONTROLS',                TObject($0003));
    AddObject('CSIDL_PRINTERS',                TObject($0004));
    AddObject('CSIDL_PERSONAL',                TObject($0005));
    AddObject('CSIDL_FAVORITES',               TObject($0006));
    AddObject('CSIDL_STARTUP',                 TObject($0007));
    AddObject('CSIDL_RECENT',                  TObject($0008));
    AddObject('CSIDL_SENDTO',                  TObject($0009));
    AddObject('CSIDL_BITBUCKET',               TObject($000A));
    AddObject('CSIDL_STARTMENU',               TObject($000B));
    AddObject('CSIDL_MYDOCUMENTS',             TObject($000C));
    AddObject('CSIDL_MYMUSIC',                 TObject($000D));
    AddObject('CSIDL_MYVIDEO',                 TObject($000E));
    AddObject('CSIDL_DESKTOPDIRECTORY',        TObject($0010));
    AddObject('CSIDL_DRIVES',                  TObject($0011));
    AddObject('CSIDL_NETWORK',                 TObject($0012));
    AddObject('CSIDL_NETHOOD',                 TObject($0013));
    AddObject('CSIDL_FONTS',                   TObject($0014));
    AddObject('CSIDL_TEMPLATES',               TObject($0015));
    AddObject('CSIDL_COMMON_STARTMENU',        TObject($0016));
    AddObject('CSIDL_COMMON_PROGRAMS',         TObject($0017));
    AddObject('CSIDL_COMMON_STARTUP',          TObject($0018));
    AddObject('CSIDL_COMMON_DESKTOPDIRECTORY', TObject($0019));
    AddObject('CSIDL_APPDATA',                 TObject($001A));
    AddObject('CSIDL_PRINTHOOD',               TObject($001B));
    AddObject('CSIDL_LOCAL_APPDATA',           TObject($001C));
    AddObject('CSIDL_ALTSTARTUP',              TObject($001D));
    AddObject('CSIDL_COMMON_ALTSTARTUP',       TObject($001E));
    AddObject('CSIDL_COMMON_FAVORITES',        TObject($001F));
    AddObject('CSIDL_INTERNET_CACHE',          TObject($0020));
    AddObject('CSIDL_COOKIES',                 TObject($0021));
    AddObject('CSIDL_HISTORY',                 TObject($0022));
    AddObject('CSIDL_COMMON_APPDATA',          TObject($0023));
    AddObject('CSIDL_WINDOWS',                 TObject($0024));
    AddObject('CSIDL_SYSTEM',                  TObject($0025));
    AddObject('CSIDL_PROGRAM_FILES',           TObject($0026));
    AddObject('CSIDL_MYPICTURES',              TObject($0027));
    AddObject('CSIDL_PROFILE',                 TObject($0028));
    AddObject('CSIDL_SYSTEMX86',               TObject($0029));
    AddObject('CSIDL_PROGRAM_FILESX86',        TObject($002A));
    AddObject('CSIDL_PROGRAM_FILES_COMMON',    TObject($002B));
    AddObject('CSIDL_PROGRAM_FILES_COMMONX86', TObject($002C));
    AddObject('CSIDL_COMMON_TEMPLATES',        TObject($002D));
    AddObject('CSIDL_COMMON_DOCUMENTS',        TObject($002E));
    AddObject('CSIDL_COMMON_ADMINTOOLS',       TObject($002F));
    AddObject('CSIDL_ADMINTOOLS',              TObject($0030));
    AddObject('CSIDL_CONNECTIONS',             TObject($0031));
    AddObject('CSIDL_COMMON_MUSIC',            TObject($0035));
    AddObject('CSIDL_COMMON_PICTURES',         TObject($0036));
    AddObject('CSIDL_COMMON_VIDEO',            TObject($0037));
    AddObject('CSIDL_RESOURCES',               TObject($0038));
    AddObject('CSIDL_RESOURCES_LOCALIZED',     TObject($0039));
    AddObject('CSIDL_COMMON_OEM_LINKS',        TObject($003A));
    AddObject('CSIDL_CDBURN_AREA',             TObject($003B));
    AddObject('CSIDL_COMPUTERSNEARME',         TObject($003D));
    AddObject('CSIDL_PROFILES',                TObject($003E));
  end;
end;

end.




02_コンポーネント化とそのテスト


上のコードでは,ダイアログの表示部分を関数にしていますが,この部分をコンポーネントにしておけば便利です.そこでコンポーネントにしてみました.
本サンプルは,作成したコンポーネントのテストプログラムです.コンポボックスで選択した特殊フォルダをルートフォルダにして,ダイアログを表示するだけです.コンボボックスにフォルダ名を入力すると,そのフォルダをルートフォルダにして表示します.

コンポーネントは,実行時に生成しています.添付の Readme.txt で確認してください.


図4
設計時画面
図5
実行例
  • CSIDL_PROGRAM_FILES_COMMON をルートフォルダにした場合

リスト2
SHBrowseForFolder 関数を使用したコンポーネントのテスト
//=============================================================================
//  作成したフォルダ参照ダイアログコンポーネントのテストプログラム
//  ルートフォルダをコンボボックスから選択
//
//  表示位置の取得はフォルダ選択時に行っている
//  したがって,フォルダ選択後に移動しても位置は記録されない
//  ダイアログを[キャンセル]で閉じた場合も位置の記録はしない
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AIndex  : Integer;
  Browser : TplBrowseFolderEx;
begin
  //コンポーネント生成
  Browser := TplBrowseFolderEx.Create(Self);

  try
    //ルートと初期選択フォルダ
    if ComboBox1.Text <> '' then begin
      AIndex := ComboBox1.ItemIndex;
      if AIndex >= 1 then begin
        Browser.RootSpecialDir := Integer(ComboBox1.Items.Objects[AIndex]);
      end else begin
        Browser.RootDir := ComboBox1.Text;
        Browser.InitDir := ComboBox1.Text + '\AAA\BBB';
      end;
    end;

    //表示位置
    if APosX > 0 then Browser.Left := APosX;
    if APosy > 0 then Browser.Top  := APosy;
    //表示スタイル
    Browser.Options := [bifReturnOnlyFSDirs];

    //ダイアログを表示して[OK]で閉じたら
    if Browser.Execute then begin
      //表示位置を記憶しておき,次回この位置に表示する
      APosX := Browser.Left;
      APosY := Browser.Top;
      Panel1.Caption := ' ' + Browser.Directory;
    end;
  finally
    FreeAndNil(Browser);
  end;
end;

//=============================================================================
//  特殊フォルダのCSIDL値をセット
//  これをルートフォルダにする
//  Vista以降にしか対応していないCSIDL_値があるので定数ではなく実値を格納
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //最初のサンプルと同じ
end;




03_作成したコンポーネントで BIF_XXX オプションの動作確認


これも作成したコンポーネントのテストです.
TBrowseInfo 構造体のメンバの ulFlags によって,ダイアログのスタイルがどうなるかを確認するためのものです.ulFlags の値は,BIF_XXXXX という定数名です.値の意味については,本ページの最初の方の表を参考にしてください.

コンポーネントは,実行時に生成しています.添付の Readme.txt で確認してください.


図6
設計時画面
図7
実行例
  • ルートフォルダは,このサンプルの EXE があるフォルダ
  • BIF_EDITBOX と BIF_BROWSEINCLUDEFILES を指定
  • 上部に編集ボックスが配置されていて,ファイルも表示されている

リスト3
SHBrowseForFolder 関数を使用したコンポーネントのテスト
BIF_XXXX の動作確認用
//=============================================================================
//  作成したフォルダ参照ダイアログコンポーネントのテストプログラム
//  ルートフォルダをコンボボックスから選択する
//  BIF関係オプションの組み合わせ動作の確認用
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AIndex  : Integer;
begin
  //ルートと初期選択フォルダ
  if ComboBox1.Text <> '' then begin
    AIndex := ComboBox1.ItemIndex;
    if AIndex >= 1 then begin
      plBrowser.RootSpecialDir := Integer(ComboBox1.Items.Objects[AIndex]);
    end else begin
      plBrowser.RootDir := ComboBox1.Text;
      plBrowser.InitDir := ComboBox1.Text + '\AAA\BBB';
    end;
  end;

  //表示位置
  plBrowser.Left := -1;
  plBrowser.Top  := -1;

  //表示スタイルのオプション
  plBrowser.Options := [];
  with plBrowser do begin
    if CheckBox1.Checked  then Options := Options + [bifReturnOnlyFSDirs];
    if CheckBox2.Checked  then Options := Options + [bifDontGoBelowDomain];
    if CheckBox3.Checked  then Options := Options + [bifStatusText];
    if CheckBox4.Checked  then Options := Options + [bifReturnFSAncestors];
    if CheckBox5.Checked  then Options := Options + [bifEditBox];
    if CheckBox6.Checked  then Options := Options + [bifValidate];
    if CheckBox7.Checked  then Options := Options + [bifNewDialogStyle];
    if CheckBox8.Checked  then Options := Options + [bifUseNewUI];
    if CheckBox9.Checked  then Options := Options + [bifBrowseIncludeURLs];
    if CheckBox10.Checked then Options := Options + [bifUAHint];
    if CheckBox11.Checked then Options := Options + [bifNonNewFolderButton];
    if CheckBox12.Checked then Options := Options + [bifNoTranslatetarGets];
    if CheckBox13.Checked then Options := Options + [bifBrowseForComputer];
    if CheckBox14.Checked then Options := Options + [bifBrowseForPrinter];
    if CheckBox15.Checked then Options := Options + [bifBrowseIncludeFiles];
    if CheckBox16.Checked then Options := Options + [bifShareable];
  end;

  //ダイアログを表示して[OK]で閉じたら
  if plBrowser.Execute then begin
    Panel1.Caption := ' ' + plBrowser.Directory;
  end;
end;

//=============================================================================
//  特殊フォルダのCSIDL値をセット
//  これをルートフォルダにする
//  Vista以降にしか対応していないCSIDL_値があるので定数ではなく実値を格納
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //コンポーネント生成
  plBrowser := TplBrowseFolderEx.Create(Self);

  //以下,最初のサンプルと同じ

end;




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


作成したコンポーネントのソースコードです.TComponent からの継承コンポーネントです.追加したプロパティとメソッド類は,以下表の通りとなっています.
最初のサンプルとは違い,特殊フォルダ以外もルートフォルダにできるようにしています.
ダイアログの表示位置は,ダイアログでフォルダを選択した時に検出しています.したがって,フォルダを選択した後に位置を変更しても無効です.

当サイトでは,同様の機能のコンポーネントを配布していますが,提供しているコンポーネントは,古い Delphi でも動作可能にするために,項目識別子関係のコードが違っています.また,ダイアログの位置の設定には,サブクラスという手法を使用しています.


表4 プロパティ

Directory String 読出し専用
Excute メソッドを実行して [OK] でダイアログを閉じた時に返される値で,選択したディレクトリのフルパス
Title String ダイアログ上部に表示するタイトル文字列
RootDir String ルートフォルダの指定
特殊フォルダ以外を指定する場合に使用する
RootSpecialDir Integer ルートフォルダの指定
特殊フォルダを CSIDL 値で指定する
RootDir を指定している場合は,RootDir の設定が有効となる
InitDir String 表示開始時に選択するフォルダのフルパス文字列
特殊フォルダでの指定はできない
Top Integer ダイアログの表示位置の左上の Y 座標値
指定がない場合は画面中央
Left Integer ダイアログの表示位置の左上の X 座標値
指定がない場合は画面中央
Options TplBrowseOps 表示スタイルの値を BIF_XXXXX の組み合わせで指定する
BIF_XXXXX の使用には uses に ShlObj が必要


表5 メソッド

Execute 関数 フォルダ選択ダイアログを表示する
フォルダを選択すると True
[キャンセル] でダイアログを閉じると False を返す


リスト4
SHBrowseForFolder 関数を使用したフォルダの参照ダイアログのコンポーネント
unit plBrowseFolderEx;

interface

uses
  SysUtils, Classes, Windows, Forms;

type
  //指定可能なオブションの要素
  //オブシェクトインスペクタで設計時に設定可能とするため定義
  TplBrowseOp =(bifReturnOnlyFSDirs,
                bifDontGoBelowDomain,
                bifReturnFSAncestors,
                bifStatusText,
                bifEditBox,
                bifValidate,
                bifNewDialogStyle,
                bifUseNewUI,
                bifBrowseIncludeURLs,
                bifUAHint,
                bifNonNewFolderButton,
                bifNoTranslatetarGets,
                bifBrowseForComputer,
                bifBrowseForPrinter,
                bifBrowseIncludeFiles,
                bifShareable);

  //指定可能なオプションを示す集合体
  //上のTplBrowsOptionExは複数選択可能な集合体とする
  TplBrowseOps = set of TplBrowseOp;

  TplBrowseFolderEx = class(TComponent)
  private
    { Private 宣言 }
    FDirectory: String;
    FTitle          : String;
    FRootDir        : String;
    FRootSpecialDir : Integer;
    FInitDir        : String;
    FTop            : Integer;
    FLeft           : Integer;
    FOptions        : TplBrowseOps;
  protected
    { Protected 宣言 }
  public
    { Public 宣言 }
    constructor Create(AOwner: TComponent); override;
    function Execute:Boolean;
    property Directory      : String read FDirectory;
    property RootDir        : String read FRootDir        write FRootDir;
    property RootSpecialDir : Integer read FRootSpecialDir write FRootSpecialDir;
    property InitDir        : String read FInitDir        write FInitDir;
    property Top            : Integer read FTop            write FTop;
    property Left           : Integer read FLeft           write FLeft;
  published
    { Published 宣言 }
    property Title   : String      read FTitle   write FTitle;
    property Options : TplBrowseOps read FOptions write FOptions;
  end;

procedure Register;

implementation

uses ShlObj, ActiveX, Dialogs;

//-----------------------------------------------------------------------------
//  コンポーネント登録情報
//-----------------------------------------------------------------------------
procedure Register;
begin
  RegisterComponents('Samples', [TplBrowseFolderEx]);
end;

{ TplBrowseFolderEx }

type
  PBFFRecord = ^TBFFRecord;
  TBFFRecord = record
  InitDir : PChar;
  X  : Integer;
  Y  : Integer;
end;

var
  APosX : Integer;
  APosY : Integer;
  //ダイアログの各オプションに対応する集合型
  //Vista以外で使用することを考えて実値で定義
  BrowseOptions: array [TplBrowseOp] of Integer=($0001, //BIF_RETURNONLYFSDIRS
                                                 $0002, //以下略
                                                 $0004,
                                                 $0008,
                                                 $0010,
                                                 $0020,
                                                 $0040,
                                                 $0050,
                                                 $0080,
                                                 $0100,
                                                 $0200,
                                                 $0400,
                                                 $1000,
                                                 $2000,
                                                 $4000,
                                                 $8000);

//-----------------------------------------------------------------------------
//  フルパス名を項目識別子に変換する関数
//  特殊フォルダ(CSIDL以外)もルートフォルダで指定可能なようにするため装備
//-----------------------------------------------------------------------------
function GetPItemIDFromFullPath(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;

//=============================================================================
//  コンポーネントの初期化
//=============================================================================
constructor TplBrowseFolderEx.Create(AOwner: TComponent);
begin
  inherited;

  //初期状態の表示位置はデスクトップの真中
  FTop  := -1;
  FLeft := -1;
  FRootSpecialDir := CSIDL_DESKTOP;
  FOptions        := [bifReturnOnlyFSDirs];
end;

//-----------------------------------------------------------------------------
//  フォルダー選択ダイアログのコールバック関数
//  表示位置の戻り値は,フォルダ選択後に移動した値は無効
//-----------------------------------------------------------------------------
function plBrowseExCallBack(hWindow: HWND; uMsg: UINT; lParam: LPARAM;
  lpData: LPARAM): Integer; stdcall;
var
  PBFFR     : PBFFRecord;
  ARect     : TRect;
  DlgWidth  : Integer;
  DlgHeight : Integer;
begin
  case uMsg of

  //ダイアログの表示開始初期状態
  BFFM_INITIALIZED:
    begin
      PBFFR := pointer(lpData);

      //初期選択フォルダ名が空でなければ,それを選択状態にする
      //それにはダイアログウィンドウにBFFM_SETSELECTIONメッセージを送る
      if lstrlen(PBFFR^.InitDir) > 1 then begin
        SendMessage(hWindow, BFFM_SETSELECTION, 1, Integer(PBFFR^.InitDir));
      end;

      //表示位置の設定
      //実際にはAPosX,APosYはグローバル変数なのでPBFFRを経由しなくてもよい
      APosX := PBFFR^.X;
      APosY := PBFFR^.Y;
      //表示指定の座標値が共に-1であれば画面の中央に表示
      //そうでないと時はAPosXとAPosYで指定する値
      if (APosX < 0) and (APosY < 0) then begin
        GetWindowRect(hWindow, ARect);
        DlgWidth  := ARect.Right  - ARect.Left;
        DlgHeight := ARect.Bottom - ARect.Top;
        APosX := (GetSystemMetrics(SM_CXSCREEN) - DlgWidth) div 2;
        APosY := (GetSystemMetrics(SM_CYSCREEN) - DlgHeight) div 2;
      end else begin
      end;
      SetWindowPos(hWindow, 0, APosX, APosY, 0, 0, SWP_NOSIZE or SWP_NOZORDER);
    end;

  //フォルダまたはファイルが選択された
  BFFM_SELCHANGED:
    begin
      //終了後にダイアログの位置(左上)を取得するためにフォルダを選択する度に
      //その位置を監視
      GetWindowRect(hWindow, ARect);
      APosX := ARect.Left;
      APosY := ARect.Top;
    end;
  end;
  //このコールバック関数は常に0を返さなければいけない
  Result := 0;
end;

//=============================================================================
//  本コンポの実行メソッド
//  TOpenDialogのようにExecuteとしてみた
//
//  本コンポーネントの全プロパティ
//
//  Directory      Excuteメソッドを実行して[OK]でダイアログを閉じた時に返される
//                 ディレクトリのフルパス.読出し専用
//   Title         ダイアログ上部に表示するタイトル文字列
//  RootDir        ルートフォルダの指定.特殊フォルダ以外を指定する場合に設定
//  RootSpecialDir ルートフォルダの指定.特殊フォルダをCSIDL値で指定する
//                 RootDirの設定が優先
//  InitDir        表示開始時に選択するフォルダのフルパス文字列
//                 特殊フォルダでの指定は,このコンポーネントでは不可
//  Top            ダイアログの表示位置(左上のY座標値).指定なしの時は画面中央
//  Left           ダイアログの表示位置(左上のX座標値).指定なしの時は画面中央
//  Options        表示スタイルの値をBIF_XXXXXで指定する
//                 BIF_XXXXXにはusesにShlObjが必要
//=============================================================================
function TplBrowseFolderEx.Execute: Boolean;
var
  DesktopShFolder : IShellFolder;
  AFileDir        : String;
  BFFR            : TBFFRecord;
  IDList          : PItemIDList;
  BrowseInfo      : TBrowseInfo;
  Option          : TplBrowseOp;
  BPathName       : array[0..MAX_PATH-1] of Char;
  BDisplayName    : array[0..MAX_PATH-1] of Char;
  Malloc          : IMalloc;
begin
  Result := False;
  SHGetMalloc(Malloc);
  FillChar(BrowseInfo, SizeOf(BrowseInfo), #0);

  //RootDirプロパティが空でない時はそれをルートとする
  //そうでない時はRootSepecialDirを使用する
  if FRootDir <> '' then begin
    //デスクトップのシェルフォルダオブジェクト取得
    //シェルではデスクトップが大元のルートとなる
    SHGetDesktopFolder(DesktopSHFolder);
    //それを用いて通常のフルパス文字列を項目識別子に変換
    IDList := GetPItemIDFromFullPath(DesktopShFolder, FRootDir);
  end else begin
    //CSIDL値を項目識別子に変換
    SHGetSpecialFolderLocation(Application.Handle, FRootSpecialDir, IDList);
  end;

  AFileDir     := FInitDir;
  BFFR.InitDir := PChar(AFileDir);
  BFFR.X       := FLeft;
  BFFR.Y       := FTop;

  BrowseInfo.hwndOwner      := Application.Handle;
  BrowseInfo.pidlRoot       := IDList;
  BrowseInfo.pszDisplayName := BDisplayName;
  BrowseInfo.lpszTitle      := PChar(FTitle);
  BrowseInfo.lpfn           := Addr(plBrowseExCallBack);
  BrowseInfo.lParam         := Integer(Addr(BFFR));

  //オプションの設定
  BrowseInfo.ulFlags := 0;
  for Option := Low(Option) to High(Option) do begin
    if Option in FOptions then begin
      BrowseInfo.ulFlags := BrowseInfo.ulFlags or Cardinal(BrowseOptions[Option]);
    end;
  end;

  IDList := SHBrowseForFolder(BrowseInfo);
  if IDList <> nil then begin
    //BrowseInfo.pszDisplayNameだとパス部分がない名前
    SHGetPathFromIDList(IDList,
    Addr(BPathName));
    FLeft      := APosX;
    FTop       := APosY;
    Result     := True;
    FDirectory := BPathName;
    Malloc.Free(IDList);
  end;
end;

end.