Open Folder

← →
Vovan#1 (2006-09-05 23:02) [0]

Нужен Open folder dialog. Что посоветуете?

← →
Vovan#1 (2006-09-05 23:08) [1]

Ладно, чего ждать, пока скажут SHBrowseForFolder.

← →
PSPF2003 © (2006-09-06 08:15) [2]

{******************************************************************************}
{* SelectFolderDialog.pas - TSelectFolderDialog Component *}
{* (c)2001-2003 Vasil Minaev V2.1 *}
{******************************************************************************}
unit SelectFolderDialog;

interface

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

type

TRootType = (rtNone,
rtRecycledBin,
rtControlPanel,
rtDesctop,
rtDesctopDirectory,
rtMyComputer,
rtFonts,
rtNetHood,
rtNetWork,
rtMyDocuments,
rtPrinters,
rtPrograms,
rtRecentlyUsed,
rtSendTo,
rtStartMenu,
rtStartup,
rtDocumentTemplates);

TSelectOption = (soBrowseForComputer,
soBrowseForPrinter,
soDontGoBelowDomain,
soReturnOnlyFsDirs,
soReturnFSAncestors,
soStatusText,
soBrowseIncludeFiles,
soBrowseIncludeURLS,
soNewDialogStyle,
soEditBox,
soShareable);

TSelectOptions = set of TSelectOption;

TDialogPosition = (dpFormCenter,dpFormPosition,dpScreenCenter,dpScreenPosition);

TAcceptChange = procedure(Sender: TObject; const NewFolder: string; var
Accept: Boolean) of object;

TFolderChange = procedure(Sender: TObject; NewFolder: string) of object;

TSelectFolderDialog = class(TComponent)
private
FParentHWND: HWND;
FDialogHandle: THandle;

FSelectOptions: TSelectOptions;
FRootType: TRootType;

FCaption: string;
FTitle: string;
FPath: string;
FDisplayName: string;
FStatusText: string;

FDialogPosition: TDialogPosition;
FPosTop: Integer;
FPosLeft: Integer;

FOnAcceptChange: TAcceptChange;
FOnChange: TFolderChange;

procedure UpdateStatusText(const Text: string);
procedure SetPath(const NewPath: string);
procedure DoChange(const NewPath: string);
procedure SetLeft(const Value: Integer);
procedure SetTop(const Value: Integer);
public
constructor Create(AOwner: TComponent); override;

function Execute: Boolean;
procedure SetStatusText(Value: string);
procedure SetOkEnabled(Value: Boolean);

property DialogHandle: THandle read FDialogHandle write FDialogHandle;
published
property RootType: TRootType read FRootType write FRootType;
property SelectOptions: TSelectOptions read FSelectOptions write FSelectOptions;

{ dialog form caption }
property Caption: string read FCaption write FCaption;
{ dialog form title }
property Title: string read FTitle write FTitle;
{ result or initial path }
property Path: string read FPath write FPath;
property StatusText: string read FStatusText write FStatusText;

property Position: TDialogPosition read FDialogPosition write FDialogPosition default dpFormCenter;
property PosTop: Integer read FPosTop write SetTop;
property PosLeft: Integer read FPosLeft write SetLeft;

property OnAcceptChange: TAcceptChange read FOnAcceptChange write FOnAcceptChange;
property OnChange: TFolderChange read FOnChange write FOnChange;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents("Мои компоненты", [TSelectFolderDialog]);
end;

function GetShellVersion: Integer;
var
InfoSize, Wnd: DWORD;
VerBuf: Pointer;
FI: PVSFixedFileInfo;
VerSize: DWORD;
ShellVersion: Integer;
begin
ShellVersion := 0;
InfoSize := GetFileVersionInfoSize("shell32.dll", Wnd);
if InfoSize <> 0 then
begin
GetMem(VerBuf, InfoSize);
try
if GetFileVersionInfo("shell32.dll", Wnd, InfoSize, VerBuf) then
if VerQueryValue(VerBuf, "\\\", Pointer(FI), VerSize) then
ShellVersion := FI.dwFileVersionMS;
finally
FreeMem(VerBuf);
end;
end;
Result := ShellVersion;
end;

function MinimizeName(const Filename: string; Canvas: TCanvas; MaxLen: Integer): string;
var b: array[0..MAX_PATH] of char; R: TRect;
begin
StrCopy(b, PChar(Filename));
R := Rect(0, 0, MaxLen, Canvas.TextHeight("Wq\"));
if DrawText(Canvas.Handle, b, Length(Filename), R,
DT_SINGLELINE or DT_MODIFYSTRING or DT_PATH_ELLIPSIS or DT_CALCRECT or DT_NOPREFIX) > 0 then
Result := b
else
Result := Filename;
end;

procedure SetDialogPos(AParentHandle, AWndHandle: THandle;
Position: TDialogPosition; Top,Left: Integer);
var
R, Sr: TRect;
begin
if GetClientRect(AWndHandle, R) then
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @Sr, 0);
case Position of
dpScreenPosition:
begin
R.Left := Sr.Left + Left;
R.Top := Sr.Top + Top;
end;
dpFormCenter:
begin
GetWindowRect(AParentHandle, Sr);
R.Left := sr.Left + ((Sr.Right - Sr.Left - (R.Right - R.Left)) div 2);
R.Top := sr.Top + (Sr.Bottom - Sr.Top - (R.Bottom - R.Top)) div 2;
end;
dpFormPosition:
begin
GetWindowRect(AParentHandle, Sr);
R.Left := Sr.Left + Left;
R.Top := Sr.Top + Top;
end;
dpScreenCenter:
begin
R.Left := ((Sr.Right - Sr.Left - (R.Right - R.Left)) div 2);
R.Top := (Sr.Bottom - Sr.Top - (R.Bottom - R.Top)) div 2;
end;
end;
SetWindowPos(AWndHandle, 0, R.Left, R.Top, 0, 0, SWP_NOACTIVATE or SWP_NOSIZE
or SWP_NOZORDER);
end;
end;

procedure BrowseCallbackProc(HWND: THandle; uMsg: Integer; lParam: LPARAM; lpData: LPARAM); stdcall;
var Dialog: TSelectFolderDialog;
FBuff: array[0..MAX_PATH] of Char;
APath: string;
begin
Dialog := TSelectFolderDialog(lpData);
Dialog.DialogHandle := HWND;
case uMsg of
BFFM_INITIALIZED:
begin
SetDialogPos(Dialog.FParentHWND,HWND,Dialog.Position,Dialog.PosTop,Dialog.PosLef t);
if Trim(Dialog.Caption) > "\" then
SetWindowText(HWND,PChar(Dialog.Caption));
if Trim(Dialog.FPath) > "\" then
begin
Dialog.SetPath(Dialog.FPath);
Dialog.DoChange(Dialog.FPath);
end
else
Dialog.UpdateStatusText("\");
end;
BFFM_SELCHANGED:
begin
SHGetPathFromIDList(PItemIDList(lParam), FBuff);
APath := StrPas(FBuff);
Dialog.DoChange(APath);
end;
end;
end;

← →
PSPF2003 © (2006-09-06 08:15) [3]

{ TSelectFolderDialog }

procedure TSelectFolderDialog.DoChange(const NewPath: string);
var Accept: Boolean;
begin
Accept := True;
UpdateStatusText(NewPath);
if Assigned(OnAcceptChange) then
FOnAcceptChange(Self,NewPath, Accept);
SetOKEnabled(Accept);
if Assigned(FOnChange) then
FOnChange(Self,NewPath);
end;

procedure TSelectFolderDialog.SetPath(const NewPath: string);
begin
SendMessage(FDialogHandle, BFFM_SETSELECTION, Ord(True), Integer(PChar(NewPath)));
end;

procedure TSelectFolderDialog.UpdateStatusText(const Text: string);
const
cStatusLabel = $3743;
var
R, R2: TRect;
S: string;
ItemHWND: THandle;
begin
if (soStatusText in FSelectOptions) then
begin
if Trim(FStatusText) <> "\" then
S := FStatusText
else
S := Text;
ItemHWND := GetDlgItem(FDialogHandle, cStatusLabel);
if (ItemHWND <> 0) then
begin
if FStatusText = "\" then
begin
GetWindowRect(FDialogHandle, R);
GetWindowRect(ItemHWND, R2);
S := MinimizeName(S, Application.MainForm.Canvas, (R.Right - R.Left) -
(R2.Left - R.Left) * 2 - 8);
end;
SendMessage(FDialogHandle, BFFM_SETSTATUSTEXT, 0, Integer(PChar(S)));
end;
end;
end;

constructor TSelectFolderDialog.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FParentHWND := 0;
if AOwner <> nil then
if AOwner.InheritsFrom(TWincontrol) then
FParentHWND := TWincontrol(AOwner).Handle;
end;

procedure TSelectFolderDialog.SetOkEnabled(Value: Boolean);
begin
if FDialogHandle <> 0 then
SendMessage(FDialogHandle, BFFM_ENABLEOK, 0, LPARAM(Value));
end;

procedure TSelectFolderDialog.SetStatusText(Value: string);
begin
if FDialogHandle <> 0 then
SendMessage(FDialogHandle, BFFM_SETSTATUSTEXT, 0, LPARAM(PChar(Value)));
end;

function TSelectFolderDialog.Execute: Boolean;
var BrowseInfo: _browseinfoA;
RootItem,ResultItem: PItemIDList;
BrowseFlags,RootParam: Integer;
ShellVersion: Integer;
StartPath: String;
I: IMalloc;
begin
RootItem := nil;
ResultItem := nil;
SetLength(StartPath,MAX_PATH);
SetLength(FDisplayName,MAX_PATH);
Result := false;
RootParam := 0;
ShellVersion := GetShellVersion;

try
if FRootType <> rtNone then
begin
case FRootType of
rtRecycledBin: RootParam := CSIDL_BITBUCKET;
rtControlPanel: RootParam := CSIDL_CONTROLS;
rtDesctop: RootParam := CSIDL_DESKTOP;
rtDesctopDirectory: RootParam := CSIDL_DESKTOPDIRECTORY;
rtMyComputer: RootParam := CSIDL_DRIVES;
rtFonts: RootParam := CSIDL_FONTS;
rtNetHood: RootParam := CSIDL_NETHOOD;
rtNetWork: RootParam := CSIDL_NETWORK;
rtMyDocuments: RootParam := CSIDL_PERSONAL;
rtPrinters: RootParam := CSIDL_PRINTERS;
rtPrograms: RootParam := CSIDL_PROGRAMS;
rtRecentlyUsed: RootParam := CSIDL_RECENT;
rtSendTo: RootParam := CSIDL_SENDTO;
rtStartMenu: RootParam := CSIDL_STARTMENU;
rtStartup: RootParam := CSIDL_STARTUP;
rtDocumentTemplates: RootParam := CSIDL_TEMPLATES;
end;
SHGetSpecialFolderLocation(FParentHWND,RootParam,RootItem);
end;

SHGetMalloc(I);
FillChar(BrowseInfo,SizeOf(_browseinfoA),0);

BrowseInfo.hwndOwner := FParentHWND;
BrowseInfo.lpfn := nil;
BrowseInfo.pidlRoot := RootItem;
BrowseInfo.lpfn := @BrowseCallbackProc;
BrowseInfo.lParam := Longint(Self);

if Trim(FTitle) > "\" then
BrowseInfo.lpszTitle := PChar(FTitle)
else
BrowseInfo.lpszTitle := nil;

BrowseInfo.pszDisplayName := PChar(FDisplayName);

BrowseFlags := 0;

if soBrowseForComputer in FSelectOptions then
BrowseFlags := BIF_BROWSEFORCOMPUTER;
if soBrowseForPrinter in FSelectOptions then
BrowseFlags := BIF_BROWSEFORPRINTER;

if soDontGoBelowDomain in FSelectOptions then
BrowseFlags := BrowseFlags or BIF_DONTGOBELOWDOMAIN;
if soReturnOnlyFsDirs in FSelectOptions then
BrowseFlags := BrowseFlags or BIF_RETURNONLYFSDIRS;
if soReturnFSAncestors in FSelectOptions then
BrowseFlags := BrowseFlags or BIF_RETURNFSANCESTORS;
if soStatusText in FSelectOptions then
BrowseFlags := BrowseFlags or BIF_STATUSTEXT;

if (soBrowseIncludeFiles in FSelectOptions) and (ShellVersion >= $00040071) then
BrowseFlags := BrowseFlags or BIF_BROWSEINCLUDEFILES;
if (soBrowseIncludeURLS in FSelectOptions) and (ShellVersion >= $00050000) then
BrowseFlags := BrowseFlags or BIF_BROWSEINCLUDEURLS;
if (soEditBox in FSelectOptions) and (ShellVersion >= $00040071) then
BrowseFlags := BrowseFlags or BIF_EDITBOX;
if (soNewDialogStyle in FSelectOptions) and (ShellVersion >= $00050000) then
BrowseFlags := BrowseFlags or BIF_NEWDIALOGSTYLE;
if (soShareable in FSelectOptions) and (ShellVersion >= $00050000) then
BrowseFlags := BrowseFlags or BIF_SHAREABLE;

BrowseInfo.ulFlags := BrowseFlags;

ResultItem := SHBrowseForFolder(BrowseInfo);
if ResultItem <> nil then
begin
SHGetPathFromIDList(ResultItem,PChar(StartPath));
SetLength(StartPath,StrLen(PChar(StartPath)));
Result := true;
end;
FPath := Trim(StartPath);
FDisplayName := BrowseInfo.pszDisplayName;
finally
if RootItem <> nil then
I.Free(RootItem);
I.Free(ResultItem);
end;
end;

procedure TSelectFolderDialog.SetLeft(const Value: Integer);
begin
if Value > 0 then
FPosLeft := Value
else
FPosLeft := 0;
end;

procedure TSelectFolderDialog.SetTop(const Value: Integer);
begin
if Value > 0 then
FPosTop := Value
else
FPosTop := 0;
end;

end.

← →
Dmitrij_K (2006-09-06 08:37) [4]

Функция SelectDirectory()

Сайт http://www.ya.ru

>PSPF2003 © (06.09.06 08:15) [2],[3]

Это прям детектив какой-то ;)))

>Dmitrij_K (06.09.06 08:37) [4]
>Функция SelectDirectory()

Только локальные папки

Open Folder Найти похожие ветки