CodeNet / Языки программирования / Delphi & Kylix / Компоненты
CodeNet / Языки программирования / Delphi & Kylix / Окна и формы

Пишем компонент - окно выбора папки

Автор: Трофим Роцкий
Development и Дельфи

Среди стандартных диалогов Delphi 6 (вкладка Dialogs) диалог выбора папки, как это ни прискорбно, отсутствует. Но ничего :). Сейчас мы исправим данное упущение, написав соответствующий компонент.

Чтобы создать новый компонент, в Delphi IDE выберите пункт File>New>Other и затем в появившемся окне нажмите New Component. Появится диалоговое окно, в котором:

Ancensor type (класс-предок нового компонента) - введите TComponent;
Class Name (имя нового класса) - TBrowseFolderDlg;
Palette Page (имя вкладки: поместим наш диалог вместе со стандартными дельфийскими) - Dialogs.

Остальное оставьте без изменений и нажмите OK. Наш мегадиалог будет вызываться функцией, продекларированной в Public Declarations компонента:

function BrowseFolder(title: PChar; h: hwnd): String;

где title - заголовок диалога (поставьте любой на ваш вкус :)), h - хэндл окна-владельца (то есть вашей программы). А команды, использованные в коде, содержатся в ShlObj.pas, так что не забудьте указать этот модуль в разделе Uses.

unit BrowseFolderDlg;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ShlObj;

type
  TBrowseFolderDlg = class(TComponent)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    function BrowseFolder(title: PChar; h: hwnd): String;
  published
    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Dialogs', [TBrowseFolderDlg]);
end;

function TBrowseFolderDlg.BrowseFolder(title: PChar; h: hwnd): String;
var
  lpItemID: PItemIDList;
  path: array[0..Max_path] of char; //выбранная папка
  BrowseInfo: TBrowseInfo; //настройки диалога
begin
  FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
  SHGetSpecialFolderLocation(h,csidl_desktop,BrowseInfo.pidlRoot);
  //устанавливаем свойства диалогового окна
  with BrowseInfo do begin 
    hwndOwner := h; //окно-владелец
    lpszTitle := title; //заголовок диалога
    //не показываем некоторые системные папки: "Корзина", "Панель управления" и т.д
    ulFlags := BIF_RETURNONLYFSDIRS+BIF_EDITBOX+BIF_STATUSTEXT;
  end;
  //выводим диалог
  lpItemID := SHBrowseForFolder(BrowseInfo);
  //папка, указанная юзером, существует?
  if lpItemId <> nil then begin 
    SHGetPathFromIDList(lpItemID, Path);
    result:=path;
    GlobalFreePtr(lpItemID); //освобождаем ресурсы
  end;
end;

end.

Готово? Сохранитесь и, выбрав Component>Install Component, проинсталлируйте наш диалог, указав в разделе Unit File Name путь к файлу BrowseFolderDlg.pas.

Осуществить вызов диалога из программы можно так (разумеется, предварительно бросив TBrowseFolderDlg на форму):

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form1.Caption:= 'Выбрана следующая папка: '+
  BrowseFolderDlg1.BrowseFolder('Укажите каталог:',Application.Handle);
end;

Конечно, это только "скелет" полноценного компонента, и просторы для модернизации безграничны.

Оставить комментарий

В примере Владимира от 17 марта 2006, 10:53:08 ошибка!
...
ulFlags:= 0;
for i := Low(TSFDOption) to High(TSFDOption) do
if i in FOptions then ulFlags:= ulFlags OR DlgOpts;
...
Должно быть
...
ulFlags:= 0;
for i := Low(TSFDOption) to High(TSFDOption) do
if i in FOptions then ulFlags:= ulFlags OR DlgOpts;
...

27K

01 марта 2007 года

ive

0 / / 01.03.2007

1 марта 2007, 20:10:07

В примере Владимира от 17 марта 2006, 10:53:08 ошибка
...
ulFlags:= 0;
for i := Low(TSFDOption) to High(TSFDOption) do
if i in FOptions then ulFlags:= ulFlags OR DlgOpts;
...
Должно быть
...
ulFlags:= 0;
for i := Low(TSFDOption) to High(TSFDOption) do
if i in FOptions then ulFlags:= ulFlags OR DlgOpts;
...

27K

01 марта 2007 года

ive

0 / / 01.03.2007

1 марта 2007, 20:07:45

Аноним

18 марта 2006, 00:11:11

2UL
У меня всё работает.
2All
Только форма с диалогом вылазит с боку, как её настроить что бы вылазила по центру? И как сделать что бы можно было указывать папки только с жесткого диска?

Аноним

17 марта 2006, 10:53:08

unit SelectFolderDialog;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ShlObj;

type
TSFDOption = (sfdoReturnOnlyFSDirs, sfdoDontGoBelowDomain, sfdoStatusText,
sfdoReturnFSAncestors, sfdoEditBox, sfdoValidate, sfdoBrowseForComputer,
sfdoBrowseForPrinter, sfdoBrowseIncludeFiles);
TSFDOptions = Set of TSFDOption;

TSFBrowseFor = (sfbfDesktop, sfbfInternet, sfbfPrograms, sfbfControls,
sfbfPrinters, sfbfPersonal, sfbfFavorites, sfbfStartup, sfbfRecent,
sfbfSendto, sfbfBitBucket, sfbfStartMenu, sfbfDesktopDirectory,
sfbfDrives, sfbfNetwork, sfbfNethood, sfbfFonts, sfbfTemplates,
sfbfCommonStartMenu, sfbfCommonPrograms, sfbfCommonStartUp,
sfbfCommonDesktopDirectory, sfbfAppData, sfbfPrintHood, sfbfAltStartUp,
sfbfCommonAltStartUp, sfbfCommonFavorites, sfbfInternetCache, sfbfCookies,
sfbfHistory);

TSelectFolderDialog = class(TComponent)
private
FPath, FTitle: String;
FOptions: TSFDOptions;
FBrowseFor: TSFBrowseFor;
protected
public
constructor Create(AOwner: TComponent); override;
function Execute: Boolean;

property Path: String read FPath;
published
property BrowseFor: TSFBrowseFor read FBrowseFor write FBrowseFor;
property Options: TSFDOptions read FOptions write FOptions
default [sfdoReturnOnlyFSDirs, sfdoStatusText];
property Title: String read FTitle write FTitle;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Dialogs', [TSelectFolderDialog]);
end;

const
DlgOpts: array [TSFDOption] of Cardinal = (BIF_RETURNONLYFSDIRS,
BIF_DONTGOBELOWDOMAIN, BIF_STATUSTEXT, BIF_RETURNFSANCESTORS, BIF_EDITBOX,
BIF_VALIDATE, BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER,
BIF_BROWSEINCLUDEFILES);
BF: array [TSFBrowseFor] of Cardinal = (CSIDL_DESKTOP, CSIDL_INTERNET,
CSIDL_PROGRAMS, CSIDL_CONTROLS, CSIDL_PRINTERS, CSIDL_PERSONAL,
CSIDL_FAVORITES, CSIDL_STARTUP, CSIDL_RECENT, CSIDL_SENDTO, CSIDL_BITBUCKET,
CSIDL_STARTMENU, CSIDL_DESKTOPDIRECTORY, CSIDL_DRIVES, CSIDL_NETWORK,
CSIDL_NETHOOD, CSIDL_FONTS, CSIDL_TEMPLATES, CSIDL_COMMON_STARTMENU,
CSIDL_COMMON_PROGRAMS, CSIDL_COMMON_STARTUP, CSIDL_COMMON_DESKTOPDIRECTORY,
CSIDL_APPDATA, CSIDL_PRINTHOOD, CSIDL_ALTSTARTUP, CSIDL_COMMON_ALTSTARTUP,
CSIDL_COMMON_FAVORITES, CSIDL_INTERNET_CACHE, CSIDL_COOKIES, CSIDL_HISTORY);

constructor TSelectFolderDialog.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOptions := [sfdoReturnOnlyFSDirs, sfdoStatusText];
end;

function TSelectFolderDialog.Execute: Boolean;
var
lpItemID: PItemIDList;
APath: array [0..Max_path] of char;
BrowseInfo: TBrowseInfo;
Wnd: HWND;
Component: TComponent;
i: TSFDOption;
begin
Result := False;
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
Component := Owner;
Wnd := 0;
while (Component <> nil) and not(Component is TForm) do
Component := Component.Owner;
if Component <> nil then
Wnd := (Component as TForm).Handle;
SHGetSpecialFolderLocation(Wnd, BF[FBrowseFor], BrowseInfo.pidlRoot);
with BrowseInfo do
begin
hwndOwner := Wnd;
lpszTitle := PChar(FTitle);
pszDisplayName := APath;
ulFlags := 0;
for i := Low(TSFDOption) to High(TSFDOption) do
if i in FOptions then
ulFlags := ulFlags or DlgOpts;
end;
lpItemID := SHBrowseForFolder(BrowseInfo);
if lpItemId <> nil then
begin
SHGetPathFromIDList(lpItemID, APath);
FPath := APath;
GlobalFreePtr(lpItemID);
Result := True;
end;
end;

end.

Аноним

9 июня 2005, 13:28:30

При бросании компоненты на форму возникает ошибка

Ваш аккаунт

Последние темы форума

Почтовая рассылка

Пишем компонент - окно выбора папки

Оставить комментарий

Комментарии

Комментарий: можно использовать BB-коды Максимальная длина комментария - 4000 символов.	CodeNet ВКонтакте Facebook Twitter Google Яндекс Чтобы оставить комментарий, необходимо авторизоваться. Можно ввести логин и пароль, или авторизоваться через социальные сети.