implementation
uses
ActiveX,
Classes,
Forms,
MultiMon,
ShlObj,
SysUtils;
//------------------------------------------------------------------------------
汎用関数
function gfnsFilePathGet(sFile:
WideString):
WideString;
{
Unicode対応ExtractFilePath。
ドライブ名も含む。
末尾の '\' はつく。
ドライブ名のみの場合も '\' はつく。
ただしパスが空文字の場合のみ '\' はつかない。
}
var
i: Integer;
begin
Result := '';
if (sFile <> '')
then begin
for i := Length(sFile)
downto 1
do begin
if (sFile[i] = '\')
or (sFile[i] = '/')
then begin
Result := Copy(sFile, 1, i);
Break;
end else if (sFile[i] = ':')
then begin
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 <> '')
then begin
li_Len := Length(sFolder);
if (sFolder[li_Len] = '\')
then begin
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)
then begin
repeat
if (
WideString(lr_Info.cFileName) <> '.')
and (
WideString(lr_Info.cFileName) <> '..')
and ((lr_Info.dwFileAttributes
and FILE_ATTRIBUTE_DIRECTORY) <> 0)
then begin
Result := True;
Break;
end;
until not(FindNextFileW(lh_Handle, lr_Info));
end;
finally
Windows.FindClose(lh_Handle);
end;
end;
function gfnpFileToItemIDList(sFile:
WideString): PItemIDList;
{
パスからアイテムIDリストを得る関数
http://www.kab-studio.biz/Programing/Codian/ShellExtension/03.html
}
var
lp_Item: PItemIDList;
lI_Desktop: IShellFolder;
li_Eaten, li_Attribute: LongWord;
begin
Result :=
nil;
if (sFile <> '')
then begin
if (SHGetDesktopFolder(lI_Desktop) = NOERROR)
then begin
if(lI_Desktop.ParseDisplayName(0,
nil, POleStr(sFile), li_Eaten, lp_Item, li_Attribute) = NOERROR)
then begin
Result := lp_Item;
end;
end;
end;
end;
function gfniRectWidth (rtRect: TRect): Integer;
//rtRectの幅を返す
begin
with rtRect
do begin
Result := Right - Left;
end;
end;
function gfniRectHeight(rtRect: TRect): Integer;
//rtRectの高さを返す
begin
with rtRect
do begin
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 l_fniCallbackSelFolderDialog(hHandle: HWND; iMsg: UINT; lParam, lpData: LPARAM): Integer
stdcall;
//gfnbOpenFolderDialogから呼ばれるコールパック関数
var
lpt_Pos: TPoint;
lrc_Rect: TRect;
begin
if (iMsg = BFFM_INITIALIZED)
then begin
if (lpData <> 0)
then begin
//lpDataには選択状態にするフォルダのアイテムIDリストが入っている
SendMessageW(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 gfnbOpenFolderDialog(
var sDir:
WideSTring; sTitle, sRoot:
WideString; hHandle: HWND): Boolean;
{Unicode対応のフォルダ選択ダイアログ。
http://www.kab-studio.biz/Programing/Codian/ShellExtension/02.html
最初にsWDirに指定しているフォルダを選択状態にする
Unicode版の関数を使った場合コールパック関数にはアイテムIDリストを渡すようにしないといけない
}
var
lb_Init: Boolean;
lr_Info: TBrowseInfoW;
lp_Item: PItemIDList;
lp_SubItem: PItemIDList;
lp_PPath: PWideChar;
ls_Path:
WideString;
li_Len: Integer;
begin
lp_PPath := AllocMem(MAX_PATH * 2);
//WideStringなので * 2
try
lb_Init := (CoInitialize(
nil) = S_OK);
FillChar(lr_Info, SizeOf(lr_Info), 0);
lr_Info.hwndOwner := hHandle;
if gfnbFolderExists(sRoot)
then begin
lr_Info.pidlRoot :=
gfnpFileToItemIDList(
gfnsFilePathGet(sRoot));
end else begin
lr_Info.pidlRoot :=
nil;
end;
lr_Info.pszDisplayName := lp_PPath;
lr_Info.lpszTitle := PWideChar(sTitle);
lr_Info.ulFlags :=
BIF_RETURNONLYFSDIRS
or BIF_RETURNFSANCESTORS
or BIF_DONTGOBELOWDOMAIN
or BIF_NEWDIALOGSTYLE
//新しいスタイルのダイアログ
// or BIF_BROWSEINCLUDEFILES //コメントアウトを外せばファイルも選択できるようになる。
// or BIF_NONEWFOLDERBUTTON //「新しいフォルダの作成」ボタンなし。BIF_NEWDIALOGSTYLE必須。
//↑をコメントアウトすれば[新しいフォルダの作成]ボタンが現れる。
;
lr_Info.iImage := 0;
ls_Path :=
gfnsFilePathGet(sDir);
if (
gfnbFolderExists(ls_Path))
then begin
//初期選択フォルダの設定
//ls_Pathの最後は\でないとフォルダであると認識されない
//'C:\Windows'は C:\ が選択状態になる
// C:\Windows を選択状態にするためには'C:\Windows\'とする。
lp_SubItem :=
gfnpFileToItemIDList(ls_Path);
lr_Info.lParam := Integer(lp_SubItem);
end else begin;
lp_SubItem :=
nil;
lr_Info.lParam := 0;
end;
lr_Info.lpfn :=
l_fniCallbackSelFolderDialog;
try
lp_Item := SHBrowseForFolderW(lr_Info);
try
Result := (lp_Item <>
nil);
if (Result)
then begin
//フルパスのフォルダをlp_PPathにセット
SHGetPathFromIDListW(lp_Item, lp_PPath);
sDir :=
WideString(lp_PPath);
if (sDir <> '')
then begin
li_Len := Length(sDir);
if (sDir[li_Len] <> '\')
then begin
sDir := sDir + '\';
end;
end;
end else begin
sDir := '';
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_PPath);
end;
end;
//------------------------------------------------------------------------------
//ディレクトリ選択
function SelectDirectoryW(
const Caption:
WideString;
const Root:
WideString;
out Directory:
WideString): Boolean;
begin
Result :=
gfnbOpenFolderDialog(Directory, Caption, Root, Application.Handle);
end;
function gfnbOpenFolderDialog(
var sDir:
WideString): Boolean;
begin
Result :=
gfnbOpenFolderDialog(sDir, '', '', Application.Handle);
end;
function gfnbOpenFolderDialog(
var sDir:
WideString; sTitle:
WideString): Boolean;
begin
Result :=
gfnbOpenFolderDialog(sDir, sTitle, '', Application.Handle);
end;
function gfnbOpenFolderDialog(
var sDir:
WideString; hHandle: HWND): Boolean;
begin
Result :=
gfnbOpenFolderDialog(sDir, '', '', hHandle);
end;