其他网站也有这份代码,不过有问题,我修改后发表上来.

uses

  ShlObj,ActiveX;

function SelectDirCB(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 SelectDirectory(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_NEWDIALOGSTYLE;

       if Directory <> '' then

       begin

         lpfn := SelectDirCB;

         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.Button6Click(Sender: TObject);

var

  strPath: string; // 用户选定后的目录

begin

  strPath := '';

  if SelectDirectory('请选择文件目录路径', '', strPath) then

  begin

  LabeledEdit1Savepath.Text := strPath;

  end;

end;