delphi 调用选择目录对话框带新建文件按钮

精简版：

uses Vcl.FileCtrl;

procedure TForm1.Button2Click(Sender: TObject);
var
  vPath: string;
begin
  //默认选择的目录
  vPath := 'D:\dir';
  //显示列表的根目录，空时显示全部
  //sdNewUI  可调整大小，显示右键菜单
  //sdNewFolder 显示“新建文件夹”按钮
  //sdShowEdit 显示“文件夹”输入框
  //sdValidateDir  验证插入编辑框中的文件夹/文件的名称
  if SelectDirectory('弹出的标题', '', vPath, [sdNewUI, sdNewFolder, sdShowEdit, sdValidateDir], Self) then
    ShowMessage('选择的目录 ' + vPath);
end;

uses  ShlObj, ActiveX,System.IOUtils;

function NewSelectDirectoryCallback(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;

begin

  if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then

    SendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpdata);

  result := 0;

end;

function NewSelectDirectory(const Caption: string; const Root: WideString; var Directory: string): Boolean;

var

  WindowList: Pointer;

  BrowseInfo: TBrowseInfo;

  Buffer: PChar;

  OldErrorMode: Cardinal;

  RootItemIDList, ItemIDList: PItemIDList;

  ShellMalloc: IMalloc;

  IDesktopFolder: IShellFolder;

  Eaten, Flags: LongWord;

begin

  Result := False;

  if not DirectoryExists(Directory) then

    Directory := '';

  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);

  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then begin

    Buffer := ShellMalloc.Alloc(MAX_PATH);

    try

      RootItemIDList := nil;

      if Root <> '' then begin

        SHGetDesktopFolder(IDesktopFolder);

        IDesktopFolder.ParseDisplayName(Application.Handle, nil,

          POleStr(Root), Eaten, RootItemIDList, Flags);

      end;

      with BrowseInfo do begin

        hwndOwner := Application.Handle;

        pidlRoot := RootItemIDList;

        pszDisplayName := Buffer;

        lpszTitle := PChar(Caption);

        ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI; // FIX

        if Directory <> '' then begin

          lpfn := NewSelectDirectoryCallback;

          lParam := Integer(PChar(Directory));

        end;

      end;

      WindowList := DisableTaskWindows(0);

      OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);

      try

        ItemIDList := ShBrowseForFolder(BrowseInfo);

      finally

        SetErrorMode(OldErrorMode);

        EnableTaskWindows(WindowList);

      end;

      Result := ItemIDList <> nil;

      if Result then begin

        ShGetPathFromIDList(ItemIDList, Buffer);

        ShellMalloc.Free(ItemIDList);

        Directory := Buffer;

      end;

    finally

      ShellMalloc.Free(Buffer);

    end;

  end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

  filepath: String;

begin

 //if NewSelectDirectory('标题说明', '', filepath) then

 if NewSelectDirectory('标题说明', 'c:\', filepath) then

    Text := filepath;

end;