Опытный
Профиль
Группа: Участник
Сообщений: 469
Регистрация: 23.4.2005
Репутация: 18
Всего: 29
|
Установи вот этот компонент и не мучайся: | Код |
////////////////////////////////////////////////////////////////////////////////
//
// ****************************************************************************
// * Project : Fangorn Wizards Lab Exstension Library v1.35
// * Unit Name : FWOpenDirectory
// * Purpose : Класс для работы с диалогом открытия папки.
// * Author : Александр (Rouse_) Багель
// * Copyright : © Fangorn Wizards Lab 1998 - 2003.
// * Version : 1.08
// ****************************************************************************
//
// Последние изменения:
// 22 марта 2003 - отключен модуль ShlOBJ,
// из-за которого возникали проблемы совместимости
// различных версий Delphi
// 29 августа 2005 - добавлено событие выбора директории
// в котором можно включать/отключать кнопку
// Св-во DisableOkOnStart, заменено событием OnChangeFolder
// 6 февраля 2006 - исправлен глючек который заметил Питерский Михаил aka Piter,
// за что ему огромное спасибо. Неверно велась работа с параметром
// pszDisplayName структуры _browseinfoA из-за моего невнимательного чтения MSDN :)
// 29 марта 2006 - добавлен необязательный параметр в метод Execute
// позволяющий напрямую указывать хэндл родителя перед
// отображением диалога.
// Добавлен вызов события OnChangeFolder при инициализации диалога
// для редактирования состояния кнопки "Ок" перед отображением диалога.
// Добавлено свойство ShowScreenCenter отвечающее за центрирование диалога.
// 7 апреля 2006 - добавлено свойство EditReadOnly
// отвечаемое за активность элемента EDIT в расширенном режиме диалога
unit FWOpenDirectory;
interface
uses
Windows, Messages, Classes, Controls;
const
SID_IShellFolder = '{000214E6-0000-0000-C000-000000000046}';
BFFM_INITIALIZED = 1;
BFFM_SELCHANGED = 2;
BFFM_VALIDATEFAILED = 3;
BFFM_SETSTATUSTEXT = WM_USER + 100;
BFFM_ENABLEOK = WM_USER + 101;
BFFM_SETSELECTIONA = WM_USER + 102;
BIF_RETURNONLYFSDIRS = $0001;
BIF_DONTGOBELOWDOMAIN = $0002;
BIF_STATUSTEXT = $0004;
BIF_RETURNFSANCESTORS = $0008;
BIF_EDITBOX = $0010;
BIF_VALIDATE = $0020;
BIF_NEWDIALOGSTYLE = $0040;
BIF_BROWSEINCLUDEURLS = $0080;
BIF_BROWSEFORCOMPUTER = $1000;
BIF_BROWSEFORPRINTER = $2000;
BIF_BROWSEINCLUDEFILES = $4000;
BIF_SHAREABLE = $8000;
BIF_USENEWUI = BIF_NEWDIALOGSTYLE or BIF_EDITBOX;
type
PSHItemID = ^TSHItemID;
_SHITEMID = record
cb: Word;
abID: array[0..0] of Byte;
end;
TSHItemID = _SHITEMID;
PItemIDList = ^TItemIDList;
_ITEMIDLIST = record
mkid: TSHItemID;
end;
TItemIDList = _ITEMIDLIST;
BFFCALLBACK = function(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
TFNBFFCallBack = type BFFCALLBACK;
PBrowseInfo = ^TBrowseInfo;
_browseinfoA = record
hwndOwner: HWND;
pidlRoot: PItemIDList;
pszDisplayName: PAnsiChar;
lpszTitle: PAnsiChar;
ulFlags: UINT;
lpfn: TFNBFFCallBack;
lParam: LPARAM;
iImage: Integer;
end;
TBrowseInfoA = _browseinfoA;
TBrowseInfo = TBrowseInfoA;
TFWChangeFolderEvent = procedure(Sender: TObject; Path: String;
var EnableButton: Boolean) of object;
TDoChangeFolder = procedure(Path: String; var EnableButton: Boolean) of object;
TODCallbackBaram = record
StartDir: Integer;
Title: Integer;
StatusText: Integer;
ChangeFolder: TDoChangeFolder;
Centered: Boolean;
EditRO: Boolean;
end;
PODCallbackBaram = ^TODCallbackBaram;
TFWOpenDirStyle = (odsReturnOnlyFSDirs, odsDontGoBelowDomain, odsStatusText,
odsReturnFSAncestors, odsEditBox, odsValidate, odsNewDialogStyle,
odsBrowseIncludeUrls, odsBrowseForComputer, odsBrowseForPrinter,
odsBrowseIncludeFiles, odsShareable, odsUseNewUI);
TFWOpenDirStyles = set of TFWOpenDirStyle;
IShellFolder = interface(IUnknown) [SID_IShellFolder]
function ParseDisplayName(hwndOwner: HWND;
pbcReserved: Pointer; lpszDisplayName: PWideChar; out pchEaten: ULONG;
out ppidl: PItemIDList; var dwAttributes: ULONG): HResult; stdcall;
end;
// Класс представляющий из себя диалог выбора директории
TFWOpenDirectory = class(TComponent)
private
FAbout: String;
FTitle: String;
FStatusText: String;
FDirName: String;
FStartDir: String;
FRootDir: WideString;
FStyle: TFWOpenDirStyles;
FStyleArray: array [0..12] of Integer;
FHandle: THandle;
FShowScreenCenter: Boolean;
FEditReadOnly: Boolean;
FOnChangeFolder: TFWChangeFolderEvent;
protected
procedure Init; virtual;
procedure DoChangeFolder(Path: String; var EnableButton: Boolean); virtual;
public
constructor Create(AOwner: TComponent); override;
function Execute(OwnerHandle: THandle = INVALID_HANDLE_VALUE): Boolean;
property DirName: String read FDirName;
published
property About: String read FAbout write FAbout;
property StatusText: String read FStatusText write FStatusText;
property RootDir: WideString read FRootDir write FRootDir;
property StartDir: String read FStartDir write FStartDir;
property Style: TFWOpenDirStyles read FStyle write FStyle default [odsUseNewUI];
property Title: String read FTitle write FTitle;
property ShowScreenCenter: Boolean read FShowScreenCenter write FShowScreenCenter default True;
property EditReadOnly: Boolean read FEditReadOnly write FEditReadOnly default False;
property OnChangeFolder: TFWChangeFolderEvent read FOnChangeFolder write FOnChangeFolder;
end;
function SHBrowseForFolder(var lpbi: TBrowseInfo): PItemIDList; stdcall;
function SHGetPathFromIDList(pidl: PItemIDList; pszPath: PChar): BOOL; stdcall;
function SHGetDesktopFolder(var ppshf: IShellFolder): HResult; stdcall;
function CoInitialize(pvReserved: Pointer): HResult; stdcall;
procedure CoUninitialize; stdcall;
function SHBrowseForFolder; external 'shell32.dll' name 'SHBrowseForFolderA';
function SHGetPathFromIDList; external 'shell32.dll' name 'SHGetPathFromIDListA';
function SHGetDesktopFolder; external 'shell32.dll' name 'SHGetDesktopFolder';
function CoInitialize; external 'ole32.dll' name 'CoInitialize';
procedure CoUninitialize; external 'ole32.dll' name 'CoUninitialize';
implementation
uses ComObj, ActiveX;
{ TFWOpenDirectory }
constructor TFWOpenDirectory.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
if AOwner = nil then
FHandle := GetDesktopWindow
else
FHandle := TWinControl(AOwner).Handle;
FStyle := [odsUseNewUI];
FStartDir := 'c:\';
FTitle := 'Browse For Folder';
FStatusText := 'Specify the directory:';
FShowScreenCenter := True;
FEditReadOnly := False;
Init;
end;
procedure TFWOpenDirectory.DoChangeFolder(Path: String;
var EnableButton: Boolean);
begin
if Assigned(FOnChangeFolder) then
FOnChangeFolder(Self, Path, EnableButton);
end;
var
OldProc: DWORD;
// Запуск диалога
function TFWOpenDirectory.Execute(
OwnerHandle: THandle = INVALID_HANDLE_VALUE): Boolean;
// Для центрирования диалога подменяем диалоговою процедуру
// Для чего это нужно?
// При использовани BIF_USENEWUI по приходу BFFM_INITIALIZED
// функция GetWindowRect возвращает размеры диалога по умолчанию,
// а изменение размеров диалога происходит позже.
// Из-за этого диалог центрируется не правильно
function ExchangeDlgProc(hwndDlg: HWND; uMsg: UINT;
WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall;
var
ScrWidth, ScrHeight, CurWidth,
CurHeight, Left, Top: Cardinal;
ClientRect: TRect;
begin
if uMsg = WM_SHOWWINDOW then
begin
GetWindowRect(hwndDlg, ClientRect);
CurWidth := ClientRect.Right - ClientRect.Left;
CurHeight := ClientRect.Bottom - ClientRect.Top;
ScrWidth := GetSystemMetrics(SM_CXSCREEN);
ScrHeight := GetSystemMetrics(SM_CYSCREEN);
Left := (ScrWidth - CurWidth) div 2;
Top := (ScrHeight - CurHeight) div 2;
SetWindowPos(hwndDlg, 0, Left, Top, 0, 0, SWP_NOSIZE or SWP_NOZORDER);
end;
Result := CallWindowProc(Pointer(OldProc),
hwndDlg, uMsg, WParam, LParam);
end;
// Callback процедура диалога
// в ней мы будем обрабатывать сообщения приходящие от диалога
function BrowseCallbackProc(hwnd: HWND; uMsg: UINT;
lParam, lpData: LPARAM): Integer; stdcall;
const
ErrorPath = 'The name entered was not valid.';
var
EnableButton: Boolean;
Path: array[0..MAX_PATH - 1] of Char;
hEdit: THandle;
begin
Result := 0;
case uMsg of
// Диалог создан и инициализирован
BFFM_INITIALIZED:
begin
// Меняем заголовок
SendMessage(hwnd, WM_SETTEXT, 0, PODCallbackBaram(lpData)^.Title);
// Меняем информационную строку
SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, PODCallbackBaram(lpData)^.StatusText);
// Выставляем фокус на директорию
SendMessage(hwnd, BFFM_SETSELECTIONA, 1, PODCallbackBaram(lpData)^.StartDir);
// Редактируем состояние кнопки при инициализации
EnableButton := True;
PODCallbackBaram(lpData)^.ChangeFolder(
PChar(PODCallbackBaram(lpData)^.StartDir), EnableButton);
SendMessage(hwnd, BFFM_ENABLEOK, 0, Integer(EnableButton));
// Определяем наличие расширенного диалога
hEdit := FindWindowEx(hwnd, 0, 'EDIT', nil);
// По необходимости делаем РО едиту
if PODCallbackBaram(lpData)^.EditRO then
if hEdit <> 0 then
EnableWindow(hEdit, False);
// По необходимости - центрируем диалог
if PODCallbackBaram(lpData)^.Centered then
// Придется запоминать старое значение в глобальной переменной
// помещать его в DWL_USER нельзя, т.к. там храниться
// указатель на PBFSF необходимый для работы диалога
OldProc := SetWindowLong(hwnd, DWL_DLGPROC,
DWORD(@ExchangeDlgProc));
end;
// Выбрана определенная директория
BFFM_SELCHANGED:
begin
// Включаем кнопку OK
EnableButton := True;
if lParam <> 0 then
begin
Path[0] := #0;
SHGetPathFromIDList(PItemIDList(lParam), Path);
PODCallbackBaram(lpData)^.ChangeFolder(Path, EnableButton);
SendMessage(hwnd, BFFM_ENABLEOK, 0, Integer(EnableButton));
SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, Integer(@Path[1]));
end;
end;
// Набрано неверное имя
BFFM_VALIDATEFAILED:
begin
// Отключаем кнопку ОК
SendMessage(hwnd, BFFM_ENABLEOK, 0, 0);
// Еслю включена галка odsStatusText - говорим пользователю что путь неверен
SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, Integer(@ErrorPath[1]));
end;
end;
end;
var
lpItemID, lpRootID: PItemIDList;
BrowseInfo: TBrowseInfo;
Desktop: IShellFolder;
TempPath: array[0..MAX_PATH - 1] of Char;
pchEaten: Cardinal;
dwAttributes: LongWord;
I, Flags: Integer;
CallbackParam: TODCallbackBaram;
ShellMalloc: IMalloc;
TmpHandle: THandle;
begin
if OwnerHandle = INVALID_HANDLE_VALUE then
TmpHandle := FHandle
else
TmpHandle := OwnerHandle;
if (CoGetMalloc(1, ShellMalloc) <> S_OK) or (ShellMalloc = nil) then
raise EComponentError.Create('CoGetMalloc failed.');
FDirName := '';
CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
try
// Смотрим какие флаги у нас выставлены (вид диалога)
Flags := 0;
for I:= 0 to 12 do
if (TFWOpenDirStyle(I) in FStyle) then
Flags:= Flags or FStyleArray[I];
// Если Root у нас не desktop folder то берем его PIDL
lpRootID := nil;
if FRootDir <> '' then
begin
SHGetDesktopFolder(Desktop);
dwAttributes := 0;
Desktop.ParseDisplayName(TmpHandle, nil, PWideChar(FRootDir),
pchEaten, lpRootID, dwAttributes);
end;
try
// Заполняем структуру
FillChar(BrowseInfo, SizeOf(TBrowseInfo), #0);
with BrowseInfo do
begin
hwndOwner := TmpHandle;
pidlRoot := lpRootID;
lpszTitle := PAnsiChar(FStatusText);
lpfn := @BrowseCallbackProc;
// Путь к директории откуда начинать - пойдет параметром в CallbackProc
CallbackParam.StartDir := Integer(@FStartDir[1]);
// Заголовок также пойдет параметром в CallbackProc
CallbackParam.Title := Integer(@FTitle[1]);
CallbackParam.StatusText := Integer(@FStatusText[1]);
CallbackParam.ChangeFolder := DoChangeFolder;
CallbackParam.Centered := FShowScreenCenter;
CallbackParam.EditRO := FEditReadOnly;
lParam := Integer(@CallbackParam);
ulFlags := Flags;
end;
// Выполняем функцию
lpItemID := SHBrowseForFolder(BrowseInfo);
// Проверка результата
if Assigned(lpItemId) then
try
TempPath[0] := #0;
Result := SHGetPathFromIDList(lpItemID, TempPath);
FDirName := String(TempPath);
finally
ShellMalloc.Free(lpItemID);
end
else
Result := False;
finally
if lpRootID <> nil then
ShellMalloc.Free(lpRootID);
end;
finally
CoUninitialize;
end;
end;
// Заполнение массива необходимыми для работы компонента значениями
procedure TFWOpenDirectory.Init;
begin
FStyleArray[0] := BIF_RETURNONLYFSDIRS;
FStyleArray[1] := BIF_DONTGOBELOWDOMAIN;
FStyleArray[2] := BIF_STATUSTEXT;
FStyleArray[3] := BIF_RETURNFSANCESTORS;
FStyleArray[4] := BIF_EDITBOX;
FStyleArray[5] := BIF_VALIDATE;
FStyleArray[6] := BIF_NEWDIALOGSTYLE;
FStyleArray[7] := BIF_BROWSEINCLUDEURLS;
FStyleArray[8] := BIF_BROWSEFORCOMPUTER;
FStyleArray[9] := BIF_BROWSEFORPRINTER;
FStyleArray[10] := BIF_BROWSEINCLUDEFILES ;
FStyleArray[11] := BIF_SHAREABLE;
FStyleArray[12] := BIF_USENEWUI;
end;
end.
|
Designtime модуль (он же установочный для компонента) | Код |
////////////////////////////////////////////////////////////////////////////////
//
// ****************************************************************************
// * Project : Fangorn Wizards Lab Exstension Library v1.35
// * Unit Name : FWOpenDirectoryReg
// * Purpose : Регистрация класса для работы с диалогом открытия папки.
// * Author : Александр (Rouse_) Багель
// * Copyright : © Fangorn Wizards Lab 1998 - 2003.
// * Version : 1.00
// ****************************************************************************
//
unit FWOpenDirectoryReg;
interface
uses
Windows, Classes, SysUtils,
{$IFDEF VER130}
DsgnIntf
{$ELSE}
DesignIntf, DesignEditors, VCLEditors
{$ENDIF};
type
// Редактор для свойства About
TAboutPropertyEditor = class(TStringProperty)
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
// Редактор свойств RootDir и StartDir
TSelectDirPropertyEditor = class(TStringProperty)
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
// Редактор свойств компонента по умолчанию
TFWOpenDirectoryEditor = class(TComponentEditor)
public
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): string; override;
function GetVerbCount: Integer; override;
end;
procedure Register;
implementation
uses FWOpenDirectory;
procedure Register;
begin
RegisterComponents('Fangorn Wizards Lab', [TFWOpenDirectory]);
RegisterPropertyEditor(TypeInfo(String), TFWOpenDirectory, 'About', TAboutPropertyEditor);
RegisterPropertyEditor(TypeInfo(WideString), TFWOpenDirectory, 'RootDir', TSelectDirPropertyEditor);
RegisterPropertyEditor(TypeInfo(String), TFWOpenDirectory, 'StartDir', TSelectDirPropertyEditor);
RegisterComponentEditor(TFWOpenDirectory, TFWOpenDirectoryEditor);
end;
{ TAboutPropertyEditor }
procedure TAboutPropertyEditor.Edit;
begin
inherited;
MessageBoxEx(GetDesktopWindow, PAnsiChar('Fangorn Wizards Lab Exstension Library v1.35'+#13#10+
'© Fangorn Wizards Lab 1998-2003'+#13#10+
'Author: Alexander (Rouse_) Bagel'+#13#10+
'Mailto: [email protected]'), 'About...', MB_ICONASTERISK, LANG_NEUTRAL);
end;
function TAboutPropertyEditor.GetAttributes: TPropertyAttributes;
begin
Result := inherited GetAttributes + [paDialog];
end;
{ TSelectDirPropertyEditor }
procedure TSelectDirPropertyEditor.Edit;
var
Dialog: TFWOpenDirectory;
begin
inherited;
Dialog := TFWOpenDirectory.Create(nil);
try
if Dialog.Execute then
SetValue(Dialog.DirName);
finally
Dialog.Free;
end;
end;
function TSelectDirPropertyEditor.GetAttributes: TPropertyAttributes;
begin
Result := inherited GetAttributes + [paDialog];
end;
{ TFWOpenDirectoryEditor }
procedure TFWOpenDirectoryEditor.ExecuteVerb(Index: Integer);
var
Dialog: TFWOpenDirectory;
begin
inherited;
Dialog := (Component as TFWOpenDirectory);
Dialog.Execute;
end;
function TFWOpenDirectoryEditor.GetVerb(Index: Integer): string;
begin
Result := 'Test Dialog';
end;
function TFWOpenDirectoryEditor.GetVerbCount: Integer;
begin
Result := 1;
end;
end.
|
|
Как в SHBrowseForFolder активировать кнопку, "Создать папку" ("Удалить папку")? 
Загрузка ...
