unit Unit2;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ShlObj, ActiveX;
  function SelectFolder(hWnd: HWND; const Caption: WideString; var Folder: WideString): boolean;
  var DefaultPath:string;

implementation
 function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): integer; stdcall;
begin
  Result := 0;
  DefaultPath:='';
  if uMsg = BFFM_INITIALIZED then

    SendMessage(hwnd, BFFM_SETSELECTION, 1, LongInt(PWideChar(DefaultPath)));
end;

function SelectFolder(hWnd: HWND; const Caption: WideString; var Folder: WideString): boolean;
var
  WindowList: Pointer;
  BrowseInfo : TBrowseInfo;
  Buffer: PChar;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: LongWord;
begin
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  begin
    Buffer := ShellMalloc.Alloc(MAX_PATH);
    try
      DefaultPath := Folder;
      RootItemIDList := nil;
      with BrowseInfo do
      begin
        hwndOwner := hWnd;
        pidlRoot := RootItemIDList;
        pszDisplayName := Buffer;
        lpfn := @BrowseCallbackProc;
        lpszTitle := PWideChar(Caption);
        ulFlags := BIF_RETURNONLYFSDIRS or $0040 or BIF_EDITBOX or BIF_STATUSTEXT;
      end;
      WindowList := DisableTaskWindows(0);
      try
        ItemIDList := ShBrowseForFolder(BrowseInfo);
      finally
        EnableTaskWindows(WindowList);
      end;
      Result :=  ItemIDList <> nil;
      if Result then
      begin
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Folder := Buffer
      end;
    finally
      ShellMalloc.Free(Buffer);
      DefaultPath := '';
    end;
  end;
end;

end.
