unit myOpenFolderDialog;

interface
uses
	Windows;


function SelectDirectoryW(const Caption: WideString; const Root: WideString; out Directory: WideString): Boolean;

function gfnbOpenFolderDialog(var sDir: WideString; sTitle, sRoot: WideString; hHandle: HWND): Boolean; overload;
function gfnbOpenFolderDialog(var sDir: WideString): Boolean; overload;
function gfnbOpenFolderDialog(var sDir: WideString; sTitle: WideString): Boolean; overload;
function gfnbOpenFolderDialog(var sDir: WideString; hHandle: HWND): Boolean; overload;

const
	BIF_NEWDIALOGSTYLE     = $0040;
	BIF_BROWSEINCLUDEURLS  = $0080;
	BIF_UAHINT             = $0100;
	BIF_NONEWFOLDERBUTTON  = $0200;
	BIF_NOTRANSLATETARGETS = $0400;
	BIF_SHAREABLE          = $8000;


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 := Succeede(CoInitialize(nil));

    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_WPathの最後は\でないとフォルダであると認識されない
			//'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;


end.