Unicode対応のフォルダ選択ダイアログ
Unicode対応のSelectDirectoryのコンポーネント化。
ソースコード
gfnbOpenFolderDialogのコンポーネント化です。
まず最初に必要な定数の宣言とオプション用の定義を行います。
interface
uses
Windows,
Classes,
Controls,
Dialogs,
ShlObj,
{フォルダ選択ダイアログ}
const
//足りない定数の宣言
BIF_NEWDIALOGSTYLE = $0040;
BIF_USENEWUI = $0050;
//BIF_NEWDIALOGSTYLE or BIF_EDITBOXと等価
BIF_BROWSEINCLUDEURLS = $0080;
BIF_UAHINT = $0100;
BIF_NONEWFOLDERBUTTON = $0200;
BIF_NOTRANSLATETARGETS = $0400;
BIF_SHAREABLE = $8000;
type
{TMyOpenFolderOption}
TMyOpenFolderOption = (
bfReturnOnlyFsDirs,
//ファイルシステムディレクトリのみを返します。
bfBrowseForComputer,
//コンピュータのみを返します。
bfBrowseForPrinter,
//プリンタのみを返します。
bfReturnFsAncestors,
//シェルネームスペース階層構造の中でルートフォルダの下にあるファイルシステムサブフォルダのみを返します。
bfBrowseIncludeFiles,
//フォルダとファイルを表示します。
bfBrowseIncludeURLs,
//URLを表示することができるようにします。
bfDontGoBelowDomain,
//ダイアログボックスのツリービューコントロールにドメインレベルのネットワークフォルダを含めないようにします。
bfShareable,
//リモートシステム上にある共有リソースを表示できるようにします。
bfEditBox,
//ユーザーがアイテム名を書き込むことができるエディットコントロールを表示します。
bfValidate,
//ユーザーがエディットコントロールに無効な名前を入力した場合に、 BFFM_VALIDATEFAILED メッセージとともにコールバック関数が呼び出されます。
bfUseNewUI,
//エディットコントロールを持つ、新しいユーザーインターフェースを使用します。
bfUaHint,
//エディットコントロールの代わりに、ダイアログボックスに用法ヒントを追加します。
bfNoNewFolderButton,
//ダイアログボックスに「新しいフォルダ」ボタンを表示しないようにします。
bfNewDialogStyle,
//新しいユーザーインターフェースを使用します。
bfNoTranslateTargets,
//選択されたアイテムがショートカットであるとき、そのリンク先ではなく、ショートカットファイル自体のPIDLを返します。
bfStatusText
//ダイアログボックスにステータス領域を表示します。
);
TMyOpenFolderOptions =
set of TMyOpenFolderOption;
{TMyOpenFolderDialog}
TMyOpenFolderDialog =
class(TCommonDialog)
private
F_sFolderName,
F_sTitle,
F_sRoot,
F_sInitialDir:
WideString;
F_Options: TMyOpenFolderOptions;
F_Owner: TWinControl;
function F_GetItemIDList(
const sWPath:
WideString): PItemIDList;
public
constructor Create(AOwner: TComponent);
override;
function Execute: Boolean;
override;
property FolderName:
WideString read F_sFolderName;
published
property Title:
WideString read F_sTitle
write F_sTitle;
property Owner: TWinControl
read F_Owner
write F_Owner;
property Root:
WideString read F_sRoot
write F_sRoot;
property InitialDir:
WideString read F_sInitialDir
write F_sInitialDir;
property Options: TMyOpenFolderOptions
read F_Options
write F_Options
default [bfReturnOnlyFsDirs, bfReturnFsAncestors, bfNewDialogStyle, bfNoNewFolderButton];
end;
implementation
uses
ActiveX,
Forms,
Messages,
MultiMon,
SysUtils;
//------------------------------------------------------------------------------
constructor TMyOpenFolderDialog.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
F_sFolderName := '';
F_sTitle := '';
F_sRoot := '';
F_sInitialDir := '';
if (AOwner
is TWinControl)
then begin
F_Owner := (AOwner
as TWinControl);
end else begin
F_Owner :=
nil;
end;
Options := [bfReturnOnlyFsDirs, bfReturnFsAncestors, bfNewDialogStyle, bfNoNewFolderButton];
end;
function TMyOpenFolderDialog.
F_GetItemIDList(
const sWPath:
WideString): PItemIDList;
{
http://www.kab-studio.biz/Programing/Codian/ShellExtension/03.html
パスからアイテムIDリストを得る関数。
Unicode版のSHBrowseForFolderWの場合RootやInitialDirにはアイテムIDリストを渡さないといけない。
}
var
lp_Item: PItemIDList;
lI_Desktop: IShellFolder;
li_Eaten, li_Attribute: LongWord;
begin
Result :=
nil;
if (sWPath <> '')
then begin
if (SHGetDesktopFolder(lI_Desktop) = NOERROR)
then begin
if(lI_Desktop.ParseDisplayName(0,
nil, POleStr(sWPath), li_Eaten, lp_Item, li_Attribute) = NOERROR)
then begin
Result := lp_Item;
end;
end;
end;
end;
function l_fniCallbackOpenFolderDialog(hHandle: HWND; iMsg: UINT; lParam, lpData: LPARAM): Integer
stdcall;
//Executeから呼ばれるコールパック関数
var
lpt_Pos: TPoint;
lrc_Rect: TRect;
begin
if (iMsg = BFFM_INITIALIZED)
then begin
if (lpData <> 0)
then begin
//選択状態フォルダのセット
SendMessage(hHandle, BFFM_SETSELECTION, Integer(False), lpData);
end;
//カーソルのあるモニターの中央に表示
GetWindowRect(hHandle, lrc_Rect);
GetCursorPos(lpt_Pos);
lrc_Rect :=
gfnrcRectCenter(
gfnrcMonitorWorkAreaRectGet(lpt_Pos), lrc_Rect);
SetWindowPos(hHandle, HWND_TOPMOST, lrc_Rect.Left, lrc_Rect.Top, 0, 0, SWP_NOSIZE);
SetWindowPos(hHandle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE
or SWP_NOMOVE);
end;
Result := 0;
end;
function TMyOpenFolderDialog.Execute: Boolean;
var
lb_Init: Boolean;
lr_Info: TBrowseInfoW;
li_Options: UINT;
lp_PWPath: PWideChar;
lp_Item: PItemIDList;
lp_SubItem: PItemIDList;
begin
lp_PWPath := AllocMem(MAX_PATH * 2);
//WideStringなので*2
try
lb_Init := (CoInitialize(
nil) = S_OK);
FillChar(lr_Info, SizeOf(lr_Info), 0);
if (F_Owner =
nil)
then begin
lr_Info.hwndOwner := Application.Handle;
end else begin
lr_Info.hwndOwner := F_Owner.Handle;
end;
lr_Info.pszDisplayName := lp_PWPath;
lr_Info.lpszTitle := PWideChar(F_sTitle);
//オプションの変換
li_Options := 0;
if (bfReturnOnlyFsDirs
in F_Options)
then li_Options := li_Options
or BIF_RETURNONLYFSDIRS;
if (bfBrowseForComputer
in F_Options)
then li_Options := li_Options
or BIF_BROWSEFORCOMPUTER;
if (bfBrowseForPrinter
in F_Options)
then li_Options := li_Options
or BIF_BROWSEFORPRINTER;
if (bfBrowseIncludeFiles
in F_Options)
then li_Options := li_Options
or BIF_BROWSEINCLUDEFILES;
if (bfReturnFsAncestors
in F_Options)
then li_Options := li_Options
or BIF_RETURNFSANCESTORS;
if (bfNoTranslateTargets
in F_Options)
then li_Options := li_Options
or BIF_NOTRANSLATETARGETS;
if (bfDontGoBelowDomain
in F_Options)
then li_Options := li_Options
or BIF_DONTGOBELOWDOMAIN;
if (bfBrowseIncludeURLs
in F_Options)
then li_Options := li_Options
or BIF_BROWSEINCLUDEURLS;
if (bfShareable
in F_Options)
then li_Options := li_Options
or BIF_SHAREABLE;
if (bfStatusText
in F_Options)
then li_Options := li_Options
or BIF_STATUSTEXT;
if (bfEditBox
in F_Options)
then li_Options := li_Options
or BIF_EDITBOX;
if (bfValidate
in F_Options)
then li_Options := li_Options
or BIF_VALIDATE;
if (bfUaHint
in F_Options)
then li_Options := li_Options
or BIF_UAHINT;
if (bfNoNewFolderButton
in F_Options)
then li_Options := li_Options
or BIF_NONEWFOLDERBUTTON;
if (bfUseNewUI
in F_Options)
then li_Options := li_Options
or BIF_USENEWUI;
if (bfNewDialogStyle
in F_Options)
then li_Options := li_Options
or BIF_NEWDIALOGSTYLE;
lr_Info.ulFlags := li_Options;
lr_Info.iImage := 0;
//ルートフォルダのセット
if (
gfnbFolderExists(F_sRoot))
then begin
lr_Info.pidlRoot := F_GetItemIDList(F_sRoot);
//アイテムIDリストをセット
end;
//選択状態フォルダのセット
if (gfnbFolderExists(F_sInitialDir))
then begin
lp_SubItem :=
F_GetItemIDList(F_sInitialDir);
//アイテムIDリストをセット
lr_Info.lParam := Integer(lp_SubItem);
end else begin;
lp_SubItem :=
nil;
lr_Info.lParam := 0;
end;
//コールバック関数のセット
lr_Info.lpfn :=
l_fniCallbackOpenFolderDialog;
try
lp_Item := SHBrowseForFolderW(lr_Info);
try
Result := (lp_Item <>
nil);
if (Result)
then begin
//フルパスのフォルダをlp_pWPathにセット
SHGetPathFromIDListW(lp_Item, lp_PWPath);
F_sFolderName :=
gfnsStrEndFit(
WideString(lp_PWPath), '\');
end;
finally
if (lp_Item <>
nil)
then CoTaskMemFree(lp_Item);
end;
finally
if (lp_SubItem <>
nil)
then CoTaskMemFree(lp_SubItem);
end;
if (lb_Init)
then CoUninitialize;
finally
FreeMem(lp_PWPath);
end;
end;
必要な汎用関数
//------------------------------------------------------------------------------
汎用関数
function gfnsFilePathGet(sFile:
WideString):
WideString;
{
Unicode対応ExtractFilePath。
ドライブ名も含む。
末尾の '\' はつく。
ドライブ名のみの場合も '\' はつく。
ただしパスが空文字の場合のみ '\' はつかない。
}
var
i: Integer;
begin
Result := '';
if (sFile <> '')
thenbegin
for i := Length(sFile)
downto 1
dobegin
if (sFile[i] = '\')
or (sFile[i] = '/')
thenbegin
Result := Copy(sFile, 1, i);
Break;
endelseif (sFile[i] = ':')
thenbegin
Result := Copy(sFile, 1, i) + '\';
Break;
end;
end;
end;
end;
function gfnbFolderExists(sFolder:
WideString): Boolean;
//DirectoryExitsのWideString対応版
var
lh_Handle: THandle;
lr_Info: TWin32FindDataW;
li_Len: Integer;
begin
Result := False;
if (sFolder <> '')
thenbegin
li_Len := Length(sFolder);
if (sFolder[li_Len] = '\')
thenbegin
SetLength(sFolder, li_Len -1);
end;
end;
FillChar(lr_Info, SizeOf(TWin32FindDataW), 0);
lh_Handle:= FindFirstFileW(PWideChar(sFolder), lr_Info);
try
if (lh_Handle<> INVALID_HANDLE_VALUE)
thenbegin
repeat
if (
WideString(lr_Info.cFileName) <> '.')
and (
WideString(lr_Info.cFileName) <> '..')
and ((lr_Info.dwFileAttributes
and FILE_ATTRIBUTE_DIRECTORY) <> 0)
thenbegin
Result := True;
Break;
end;
untilnot(FindNextFileW(lh_Handle, lr_Info));
end;
finally
Windows.FindClose(lh_Handle);
end;
end;
function gfniRectWidth (rtRect: TRect): Integer;
//rtRectの幅を返す
begin
with rtRect
dobegin
Result := Right - Left;
end;
end;
function gfniRectHeight(rtRect: TRect): Integer;
//rtRectの高さを返す
begin
with rtRect
dobegin
Result := Bottom - Top;
end;
end;
function gfnrcRectCenter(rcParent, rcChild: TRect): TRect;
//rcChildがrcParentの真ん中にくるようなRectを返す
var
li_Left, li_Top, li_Width, li_Height: Integer;
begin
li_Width := gfniRectWidth (rcChild);
li_Height := gfniRectHeight(rcChild);
li_Left := rcParent.Left + (
gfniRectWidth (rcParent) - li_Width)
div 2;
li_Top := rcParent.Top + (
gfniRectHeight(rcParent) - li_Height)
div 2;
Result := Rect(li_Left, li_Top, li_Left + li_Width, li_Top + li_Height);
end;
function gfnrcMonitorWorkAreaRectGet(ptPos: TPoint): TRect;
//ptPos上のモニターのワークエリアを返す。
var
lr_Info: TMonitorInfo;
lh_Handle: HMONITOR;
lrc_Rect: TRect;
begin
lrc_Rect := Rect(ptPos.X, ptPos.Y, ptPos.X, ptPos.Y);
lh_Handle := MultiMon.MonitorFromRect(@lrc_Rect, MONITOR_DEFAULTTONEAREST);
lr_Info.cbSize := SizeOf(lr_Info);
GetMonitorInfo(lh_Handle, @lr_Info);
Result := lr_Info.rcWork;
end;
function gfnsStrEndFit(sSrc, sEnd:
WideString):
WideString;
//sSrcの末尾がsEndでなければsEndを足して返す。
begin
if (Copy(sSrc, Length(sSrc) - Length(sEnd) +1, Length(sEnd)) <> sEnd)
then begin
Result := sSrc + sEnd;
end else begin
Result := sSrc;
end;
end;
myFolderDialog.pas
プロパティ
- FolderName
property FolderName: WideString
選択されたフォルダ名が格納される。
読み出し専用。
- Title
property Title: WideString
フォルダ選択ダイアログのタイトルバーのキャプションではなく、タイトルバーとディレクトリツリーの間に表示される文字列を指定。
- Owner
property Owner: TWinControl
ダイアログのオーナーウィンドウを指定。
デフォルトのままで特に変更する必要はないと思われ。
- Root
property Root: WideString
ルートフォルダを指定。
このフォルダより上位のフォルダやドライブは表示されない。
フォルダ名の後ろに'\'は必要。
例えばCドライブのルートにしたいときは 'C:\' とする。
C:\WINDOWS にしたければ 'C:\WINDOWS\' とする。
- InitialDir
property InitialDir: WideString
ダイアログが表示される時に選択状態になるフォルダを指定。
フォルダ名の後ろに'\'は必要。
- Options
property Options: TMyOpenFolderOptions
様々なオプションを指定。
各オプションの内容はTMyOpenFolderOptionsを参照。
メソッド
- Create
constructor Create(AOwner: TComponent);
- Execute
function Execute: Boolean;
フォルダ選択ダイアログを呼び出す。
選択してOKボタンを押すとFolderNameに選択したフォルダ名がセットされTrueが返る。
キャンセルボタンを押したりダイアログの×印を押して閉じた場合はFalseが返る。
関数版
function gfnbOpenFolderDialog(
var sWDir:
WideSTring;
const sWTitle:
WideString;
const hHandle: HWND): Boolean;
overload;
var
ldlg_Folder: TMyOpenFolderDialog;
begin
ldlg_Folder := TMyOpenFolderDialog.Create(
nil);
with ldlg_Folder
do begin
try
Title := sWTitle;
InitialDir := sWDir;
//sWDirにセットされている値を初期フォルダにする
Options := [bfReturnOnlyFsDirs, bfReturnFsAncestors, bfNewDialogStyle, bfNoNewFolderButton];
Result := Execute;
if (Result)
then begin
sWDir := FolderName;
end;
finally
Free;
end;
end;
end;
SelectDirectoryならこんな感じで。
function SelectDirectoryW(const Caption, Root: WideString; out Directory: WideString): Boolean;
var
ldlg_Folder: TMyOpenFolderDialog;
begin
ldlg_Folder := TMyOpenFolderDialog.Create(nil);
try
ldlg_Folder.Root := Caption;
ldlg_Folder.Root := Root;
ldlg_Folder.Options := [bfReturnOnlyFsDirs, bfReturnFsAncestors,
bfNewDialogStyle, bfNoNewFolderButton];
Result := ldlg_Folder.Execute;
if (Result) then begin
Directory := ldlg_Folder.FolderName;
end;
finally
ldlg_Folder.Free;
end;
end;
2008-07-22: