Mega Code Archive
Browse Directories and Files
<![CDATA[
Title: Browse Directories and Files
Just a code sample. This is a component that encapsulates SHBrowseForFolder and should hold most of the functionality offered through it.
I do not have the capability to test a lot of it, so YMMV. Please let me know if you find a problem, find it useful, or both.
Download to the source, documentation, and a demo here:
http://cid-3af7a836477cc1d2.skydrive.live.com/embedrowdetail.aspx/Public/DirBrowse%20Component.zip
CODE
unit DirBrowseDialog;
{TDirBrowse component by Glenn9999 at tek-tips.com }
interface
{$R DIRBROWSEDIALOG.DCR}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
shlobj, DsgnIntf;
const
BIF_NEWDIALOGSTYLE = $40;
type
TBDirFlag = (bifBrowseFolders, bifBrowseFiles, bifBrowseComputer,
bifBrowsePrinter);
TBStartFlag = (ciNone, ciRecycleBin, ciControlPanel,
ciDesktopDirectory, ciMyComputer, ciFonts, ciNetHood,
ciMyDocuments, ciPrograms, ciRecent, ciSendTo,
ciStartMenu, ciStartup, ciTemplates);
TBDSelectEvent = procedure (Sender: TObject; selitem: string;
var stext: string; var valid: Boolean) of object;
TStub = packed record
PopEDX: Byte;
MovEAX: Byte;
SelfPointer: Pointer;
PushEAX: Byte;
PushEDX: Byte;
JmpShort: Byte;
Displacement: Integer;
end;
// property editor for TFileName within this component
TFileNameProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
TDirBrowseDialog = class(TCommonDialog)
private
// processing variables
FBrowseInfo : TBrowseInfo;
FHandle: Cardinal;
FFlag: Integer;
FTitle: String; // title or caption
FDirName: String; // path or dir returned
FStartDir: TFileName; // directory to start with
FUserFlag: TBDirFlag; // determines functionality
FStartFlag: TBStartFlag; // determines special start places
FStatusMsg: Boolean; // show status messages?
FNewStyle: Boolean; // use new display style?
FCenter: Boolean; // center the dialog?
FFSAncestors: Boolean; // allow only file system ancestors?
FBelowDomain: Boolean; // do not go below domain level in network browse?
FRootDir: Boolean; // truncate browse in root dir instead of simply select?
FOnItemSelect: TBDSelectEvent;
procedure UFlagHandle;
procedure SFlagHandle;
protected
function BD_Callback(wnd: hwnd; umsg: uint;
lparam, lpdata: lparam): integer; stdcall;
public
FMyCallBack: Pointer;
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
function Execute: Boolean; override;
published
property Title: string read FTitle write FTitle;
property StartDir: TFileName read FStartDir write FStartDir;
property StatusMsg: Boolean read FStatusMsg write FStatusMsg;
property DirName: string read FDirName write FDirName;
property UserFlag: TBDirFlag read FUserFlag
write FUserFlag default bifbrowsefolders;
property StartFlag: TBStartFlag read FStartFlag write FStartFlag default ciNone;
property NewStyle: Boolean read FNewStyle write FNewStyle default false;
property Centered: Boolean read FCenter write FCenter;
property FSAncestors: Boolean read FFSAncestors write FFSAncestors;
property BelowDomain: Boolean read FBelowDomain write FBelowDomain;
property RootDir: Boolean read FRootDir write FRootDir;
property OnItemSelect: TBDSelectEvent read FOnItemSelect write FOnItemSelect;
end;
procedure Register;
implementation
function CreateStub(ObjectPtr: Pointer; MethodPtr: Pointer): Pointer;
{ Jeroen Mineur's code as found on the Internet. Allows a class
method to be called as a procedure in the case of call backs}
const
AsmPopEDX = $5A;
AsmMovEAX = $B8;
AsmPushEAX = $50;
AsmPushEDX = $52;
AsmJmpShort = $E9;
var
Stub: ^TStub;
begin
New(Stub);
Stub^.PopEDX := AsmPopEDX;
Stub^.MovEAX := AsmMovEAX;
Stub^.SelfPointer := ObjectPtr;
Stub^.PushEAX := AsmPushEAX;
Stub^.PushEDX := AsmPushEDX;
Stub^.JmpShort := AsmJmpShort;
Stub^.Displacement := (Integer(MethodPtr) - Integer(@(Stub^.JmpShort))) -
(Sizeof(Stub^.JmpShort) + Sizeof(Stub^.Displacement));
Result := Stub;
end;
procedure DisposeStub(Stub: Pointer);
// dispose of the procedure reference made in createstub
begin
Dispose(Stub);
end;
procedure centercbwindow(wnd: HWnd);
// centers a window on the screen.
var
wa, rect: TRect;
dialogPT: TPoint;
begin
wa.Top := 0; wa.Left := 0;
Wa.Right := Screen.Width; Wa.Bottom := Screen.Height;
GetWindowRect(Wnd, Rect);
dialogPT.X := ((wa.Right - wa.Left) div 2) -
((rect.Right - rect.Left) div 2);
dialogPT.Y := ((wa.Bottom - wa.Top) div 2) -
((rect.Bottom - rect.Top) div 2);
MoveWindow(Wnd, dialogPT.X, dialogPT.Y, rect.Right - Rect.Left,
Rect.Bottom - Rect.Top, True);
end;
function BD_Callback(wnd: hwnd; umsg: uint; lparam, lpdata: lparam): integer; stdcall;
// callback function for SHBrowseforfolder, TFileNameProperty
begin
case uMsg of
BFFM_INITIALIZED: // initialization code
begin
SendMessage(wnd, BFFM_SETSELECTIONA, Longint(true), lpdata);
centercbwindow(wnd);
end;
end;
Result := 0;
end;
function TFileNameProperty.GetAttributes: TPropertyAttributes;
// property handler for file dir paths, set attributes
begin
Result := [paDialog, paReadOnly]
end {GetAttributes};
procedure TFileNameProperty.Edit;
// property handler for file paths. Returns directory path.
var
lpItemID : PItemIDList;
DisplayName : array[0..MAX_PATH] of char;
TempPath : array[0..MAX_PATH] of char;
FBr: TBrowseInfo;
begin
FillChar(FBr, sizeof(TBrowseInfo), #0);
with FBr do
begin
hwndOwner := Application.Handle;
pszDisplayName := @DisplayName;
lpszTitle := PChar('Select the value for ' + GetName);
lpfn := BD_Callback;
lparam := Longint(PChar(GetValue));
ulFlags := BIF_RETURNONLYFSDIRS;
end;
lpItemID := SHBrowseForFolder(FBr);
if lpItemId nil then
begin
if SHGetPathFromIDList(lpItemID, TempPath) then
SetValue(String(TempPath));
GlobalFreePtr(lpItemID);
end
else
SetValue('');
end;
function TDirBrowseDialog.BD_Callback(wnd: hwnd; umsg: uint;
lparam, lpdata: lparam): integer; stdcall;
// callback function for SHBrowseforfolder
var
TempPath : array[0..MAX_PATH] of char;
SText: string;
valid: Boolean;
begin
case uMsg of
BFFM_INITIALIZED: // initialization code
begin
{ set browse directory }
SendMessage(wnd, BFFM_SETSELECTIONA, Longint(true), lpdata);
if FCenter then centercbwindow(wnd);
end;
BFFM_SELCHANGED: // selection code, handles status message & validation
begin
SHGetPathFromIDList(PItemIDList(lparam), @TempPath);
if Assigned(FOnItemSelect) then
begin
OnItemSelect(Self, String(TempPath), stext, valid);
if valid then
SendMessage(wnd, BFFM_ENABLEOK, 1, 1)
else
SendMessage(wnd, BFFM_ENABLEOK, 0, 0);
SendMessage(wnd, BFFM_SETSTATUSTEXT, 0, Longint(@stext[1]));
end;
end;
end;
Result := 0;
end;
Constructor TDirBrowseDialog.Create(AOwner: TComponent);
begin
FHandle := Application.Handle;
FMyCallBack := CreateStub(Self, @TDirBrowseDialog.BD_CallBack);
inherited create(aowner);
end;
Destructor TDirBrowseDialog.Destroy;
begin
DisposeStub(FMyCallBack);
Inherited;
end;
procedure TDirBrowseDialog.SFlagHandle;
// handles the special starting flag
var
IDRoot: PItemIDList;
sflag: integer;
begin
case FStartflag of
ciNone: sflag := CSIDL_DESKTOP;
ciRecycleBin: sflag := CSIDL_BITBUCKET;
ciControlPanel: sflag := CSIDL_CONTROLS;
ciDesktopDirectory: sflag := CSIDL_DESKTOPDIRECTORY;
ciMyComputer: sflag := CSIDL_DRIVES;
ciFonts: sflag := CSIDL_FONTS;
ciNetHood: sflag := CSIDL_NETHOOD;
ciMyDocuments: sflag := CSIDL_PERSONAL;
ciPrograms: sflag := CSIDL_PROGRAMS;
ciRecent: sflag := CSIDL_RECENT;
ciSendTo: sflag := CSIDL_SENDTO;
ciStartMenu: sflag := CSIDL_STARTMENU;
ciStartup: sflag := CSIDL_STARTUP;
ciTemplates: sflag := CSIDL_TEMPLATES;
else
sFlag := 0;
end;
SHGetSpecialFolderLocation(FHandle, sflag, IDRoot);
FBrowseInfo.pidlRoot := IDRoot;
end;
procedure TDirBrowseDialog.UFlagHandle;
// handles the user functionality flag
var
IDRoot: PItemIDList;
begin
case FUserFlag of
bifBrowseFolders: Fflag := BIF_RETURNONLYFSDIRS;
bifBrowseFiles: Fflag := BIF_BROWSEINCLUDEFILES;
bifBrowseComputer: Fflag := BIF_BROWSEFORCOMPUTER;
bifBrowsePrinter: Fflag := BIF_BROWSEFORPRINTER;
else
Fflag := 0;
end;
// special cases
if Fflag = BIF_BROWSEFORCOMPUTER then
begin
SHGetSpecialFolderLocation(FHandle, CSIDL_NETWORK, IDRoot);
FBrowseInfo.pidlRoot := IDRoot;
end;
if Fflag = BIF_BROWSEFORPRINTER then
begin
SHGetSpecialFolderLocation(FHandle, CSIDL_PRINTERS, IDRoot);
FBrowseInfo.pidlRoot := IDRoot;
end;
// not mutually exclusive options
if FStatusMsg then
FFlag := FFlag + BIF_STATUSTEXT;
if FNewStyle then
FFlag := FFlag + BIF_NEWDIALOGSTYLE;
if FBelowDomain then
FFlag := FFlag + BIF_DONTGOBELOWDOMAIN;
if FFSAncestors then
FFlag := FFlag + BIF_RETURNFSANCESTORS;
end;
function TDirBrowseDialog.Execute: boolean;
var
lpItemID : PItemIDList;
DisplayName : array[0..MAX_PATH] of char;
TempPath : array[0..MAX_PATH] of char;
RootIDList: PItemIDList;
IDesktopFolder: IShellFolder;
Dummy: Longint;
begin
FillChar(FBrowseInfo, sizeof(TBrowseInfo), #0);
SFlagHandle;
UFlagHandle;
// find the ItemIDList for startdir if truncate the dir
if FRootDir then
begin
RootIDList := nil;
if StartDir '' then
begin
SHGetDesktopFolder(IDesktopFolder);
IDesktopFolder.ParseDisplayName(FHandle, nil,
PWideChar(WideString(startdir)), Dummy, RootIDList, Dummy);
FBrowseInfo.pidlRoot := RootIDList;
end;
end;
with FBrowseInfo do
begin
hwndOwner := FHandle;
pszDisplayName := @DisplayName;
lpszTitle := PChar(Title);
lpfn := FMyCallback;
lparam := Longint(PChar(FStartDir));
ulFlags := FFlag;
end;
lpItemID := SHBrowseForFolder(FBrowseInfo);
if lpItemId nil then
begin
{ must check whether the item selected is file system item or not
display name is selected item if it is a printer or machine and not
a file or directory }
if SHGetPathFromIDList(lpItemID, TempPath) then
FDirName := temppath
else
FDirName := String(DisplayName);
Result := true;
GlobalFreePtr(lpItemID);
end
else
Result := false;
end;
procedure Register;
begin
RegisterComponents('Samples', [TDirBrowseDialog]);
RegisterPropertyEditor(TypeInfo(TFileName), nil, '', TFileNameProperty)
end;
end.
]]>