Форум программистов [Powered by Invision Power Board]

Код


uses ShellAPI, ShlObj; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
 TitleName : string;  
 
 lpItemID : PItemIDList;  
 
 BrowseInfo : TBrowseInfo;  
 
 DisplayName : array[0..MAX_PATH] of char;  
 
 TempPath : array[0..MAX_PATH] of char;  
 
  
begin 
 FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);  
 
 BrowseInfo.hwndOwner := Form1.Handle;  
 
 BrowseInfo.pszDisplayName := @DisplayName;  
 
 TitleName := 'Please specify a directory';  
 
 BrowseInfo.lpszTitle := PChar(TitleName);  
 
 BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;  
 
 lpItemID := SHBrowseForFolder(BrowseInfo);  
 
 if lpItemId <> nil then begin  
 
  
 SHGetPathFromIDList(lpItemID, TempPath);  
 
 ShowMessage(TempPath);  
 
 GlobalFreePtr(lpItemID);  
 
  
 end;  
 
  
end;

Код


Вариант от Анатолия ([email protected]) 

threadvar myDir: string; 

function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: 
LPARAM): integer; stdcall; 
begin 
 Result := 0;  
 
 if uMsg = BFFM_INITIALIZED then begin  
 
 SendMessage(hwnd, BFFM_SETSELECTION, 1, LongInt(PChar(myDir)))  
 
 end;  
 
  
end; 

function SelectDirectory(const Caption: string; const Root: WideString; 
var Directory: string): Boolean; 
var 
 WindowList: Pointer;  
 
 BrowseInf!  
 
 o: TBrowseInfo;  
 
 Buffer: PChar;  
 
 RootItemIDList, ItemIDList: PItemIDList;  
 
 ShellMalloc: IMalloc;  
 
 IDesktopFolder: IShellFolder;  
 
 Eaten, Flags: LongWord;  
 
  
begin 
 myDir := Directory;  
 
 Result := False;  
 
 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;  
 
 lpfn := @BrowseCallbackProc;  
 
 lParam := Integer(PChar(Directory));  
 
 lpszTitle := PChar(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);  
 
 Directory := Buffer;  
 
  
 end;  
 
 finally  
 
  
 ShellMalloc.Free(Buffer);  
 
  
 end;  
 
 end;  
 
  
end;

Код


 threadvar myDir: string;

Цитата(sgentstuff @ 7.7.2006, 14:04

)

threadvar

Код


uses ShlObj; 

{....}

procedure CallBack(wnd: hWnd; uMsg: UINT; lParam, lpData: LParam) stdcall; 
begin 
  SendMessage(wnd, BFFM_ENABLEOK, 0, 1); 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
  bi: TBrowseInfo; 
  s: PChar; 
  PIDL, ResPIDL: PItemIDList; 
begin 
  SHGetSpecialFolderLocation(Form1.Handle, CSIDL_DESKTOP, PIDL); 
  s := StrAlloc(128); 
  bi.hwndOwner := Form1.Handle; 
  bi.pszDisplayName := s; 
  bi.lpszTitle := 'Выбор прапки'; 
  bi.pidlRoot := PIDL; 
  bi.lpfn := addr(CallBack); 
{bi.ulFlags флаги, которые задают режим отображения диалога:
  BIF_BROWSEFORCOMPUTER - Возвратить только компьютеры. Если пользователь выбрал что-то отличное от компьютеров, то кнопка OK останется серой.
  BIF_BROWSEFORPRINTER - Возвратить только принтеры. Если пользователь выбрал что-
то отличное от принтеров, то кнопка OK останется серой.
  BIF_RETURNONLYFSDIRS - Возвратить только папки файловой системы. Если пользователь выберет папки, которые не являются частью файловой системы, то кнопка OK останется серой. Это необходимо для того если ваша программа не работает с виртуальными папками вроде "Панель управления".
  BIF_BROWSEINCLUDEFILES - Диалог просмотра будет отображать файлы вместе с директориями.
  BIF_DONTGOBELOWDOMAIN - Не включать сетевые папки Доменного уровня ниже, чем в TreeView контроле.
  BIF_RETURNFSANCESTORS - В качестве выбора допустимы только объекты, представленные в файловой системе.
  BIF_STATUSTEXT - Включает область статуса в блок диалога. Функция может установить текст посылая сообщения блоку диалога.
  BIF_EDITBOX - В диалоговом окне будет присутствовать строка редактирования, таким образом пользователь может набрать имя элемента.
  BIF_VALIDATE - Если пользователь введёт неверное имя в строке редактирования, то диалоговое окно вызовет функцию обратного вызова приложения по сообщению BFFM_VALIDATEFAILED.}
  ResPidl := SHBrowseForFolder(BI); 
  SHGetPathFromIDList(ResPidl, s); 
  Form1.Caption := s; 
end;

Код


uses ... ShlObj, ...

...



function TfmOptions.Selectdir(const str: string): string;

function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData:LPARAM): integer; stdcall;
begin
 Result := 0;
 if uMsg = BFFM_INITIALIZED then begin
 SendMessage(hwnd, BFFM_SETSELECTION, 1, LongInt(PChar(fmOptions.sx)))
 end;
end;

var
 TitleName : string;
 lpItemID : PItemIDList;
 BrowseInfo : TBrowseInfo;
 DisplayName : array[0..MAX_PATH] of char;
 TempPath : array[0..MAX_PATH] of char;
 begin
   Result:='';
   sx:=str;
   FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
   BrowseInfo.hwndOwner := Application.Handle;
   BrowseInfo.pszDisplayName := @DisplayName;
   TitleName := 'Выберите папку...';
   BrowseInfo.lpszTitle := PChar(TitleName);
   BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS or $0040;// or BIF_EDITBOX or BIF_STATUSTEXT;
   BrowseInfo.lpfn := @BrowseCallbackProc;
   lpItemID := SHBrowseForFolder(BrowseInfo);
   if lpItemId <> nil then begin
   SHGetPathFromIDList(lpItemID, TempPath);
   Result:=StrPas(TempPath);
   GlobalFreePtr(lpItemID);
 end;
end;

Цитата(Akella @ 10.7.2006, 07:38

)

вопрос в тему относительно флагов: какой флаг отвечает за кнопку "Создать папку"? Хочу дать возможность пользователям создавать папки.

Код


создавать новые папки и обновлять дерево папок

Цитата(Akella @ 10.7.2006, 09:06

)

сам-то посмотрел пример?

Цитата(Akella @ 10.7.2006, 09:06

)

там сделано через отдельную кнопку на своей форме

Код


BFFM_INITIALIZED: begin
        CreateBrowseWindow(Wnd);

Код


function BrowseCallbackProc( Wnd : THandle; uMsg : UINT;
                             lParam : Integer; lpData : Pointer ) : Integer; stdcall;

Цитата(Akella @ 10.7.2006, 09:06

)

интерисует флаг,

Цитата

Use the new user interface. Setting this flag provides the user with a larger dialog box that can be resized. The dialog box has several new capabilities including: drag-and-drop capability within the dialog box, reordering, shortcut menus, new folders, delete, and other shortcut menu commands. To use this flag, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder

Цитата

BIF_NEWDIALOGSTYLE
Version 5.0. Use the new user interface. Setting this flag provides the user with a larger dialog box that can be resized. The dialog box has several new capabilities including: drag-and-drop capability within the dialog box, reordering, shortcut menus, new folders, delete, and other shortcut menu commands. To use this flag, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.

BIF_NONEWFOLDERBUTTON
Version 6.0. Do not include the New Folder button in the browse dialog box.

Цитата(Akella @ 10.7.2006, 08:38

)

Sunvas, вопрос в тему относительно флагов: какой флаг отвечает за кнопку "Создать папку"? Хочу дать возможность пользователям создавать папки.

Код


bi.ulFlags:=BIF_NEWDIALOGSTYLE;