OK, here it comes, the ultimate bugfix for the FileCtrl.SelectDirectory function. 😉
I blogged about it before: The SelectDirectory function in Delphi’s FileCtrl unit has several bugs. My first approach on fixing these, while working, was ugly because the user could see that the dialog position changed after it was shown initially at a different position. My initial guess why the code in FileCtrl failed to set the position correctly was wrong. It’s not because the dialog is not yet visible, but because its size is being changed later in the initialization process so the size used to calculate its position centered on the monitor was wrong.
My bugfix works like this:
- During the initialization subclass the window of the dialog by setting a new WindowProc function.
- Wait for the first WM_SIZE message.
- Now, that the dialog has its final size, position it
- Un-subclass the window, we don’t need the WindowProc any more
But there is more:
Since the caller passed a Parent to SelectDirectory, why not use that parameter? The user expects modal dialogs to pop up on top of the window he is currently using, so why not position the dialog centered on the Parent rather than the monitor? To do that correctly we also must position it so that it is fully visible on a particular monitor. Nobody wants a dialog crossing monitor borders or being partially obscured by the task bar. For that I have added some overloaded TMonitor_MakeVisible procedures to u_dzVclUtils and call one of them after centering the dialog on the parent.
Of course, the bug of the given directory not being visible, which was already fixed in my first try, is still fixed.
Here is the code:
///<summary>
/// Fixes the SelectDirectory function of Delphi 2007 (not sure whether it needs fixing
/// in later versions)</summary>
unit u_dzSelectDirectoryFix;
interface
uses
Windows,
SysUtils,
FileCtrl,
Controls;
///<summary>
/// Bugixed version of the FilCtrl SelectDirectory function with identical parameters
/// The following bugs have been fixed:
/// 1. Positioning the dialog works for all tested monitor combinations. This means
/// not only that the correct monitor is being selected (which is already fixed
/// Delphi 10.1 (and possibly earlier) but also that it is correctly centered
/// on that monitor.
/// 2. The given directory is not only selected but the tree view is also scrolled
/// to make the entry visible.
/// In addition to that, if passing a Parent parameter <> nil, the dialog will be
/// centered on that parent (or the form the parent belongs to), taking the monitor
/// work area into account. </summary>
function SelectDirectory(const Caption: string; const Root: WideString;
var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: TWinControl = nil): Boolean;
///<summary>
/// Same as SelectDirectory above but with a different name so it can be called explicitly rather
/// than relying on the order of units in the uses clause. </summary>
function dzSelectDirectory(const Caption: string; const Root: WideString;
var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: TWinControl = nil): Boolean;
implementation
uses
Consts,
ShlObj,
ActiveX,
Dialogs,
Forms,
Messages,
Classes,
u_dzVclUtils;
type
TSelectDirCallback = class(TObject)
private
FWndProcInstanceStub: Pointer;
FWndProcPrevious: TFNWndProc;
FWnd: HWND;
FParent: TWinControl;
FDirectory: string;
FInitialized: Boolean;
FPositioned: Boolean;
procedure WndProcSubClassed(var _Msg: TMessage);
procedure SetDialogPosition;
procedure SubClass(_Wnd: HWND);
procedure UnsubClass;
protected
function SelectDirCB(_Wnd: HWND; _uMsg: UINT; _lParam, _lpData: lParam): Integer;
public
constructor Create(const _Directory: string; _Parent: TWinControl);
end;
{ TSelectDirCallback }
constructor TSelectDirCallback.Create(const _Directory: string; _Parent: TWinControl);
begin
inherited Create;
FParent := _Parent;
FDirectory := _Directory;
end;
// subclass the given window by replacing its WindowProc
procedure TSelectDirCallback.SubClass(_Wnd: HWND);
begin
if FWndProcPrevious <> nil then
Exit;
FWnd := _Wnd;
FWndProcPrevious := TFNWndProc(GetWindowLong(_Wnd, GWL_WNDPROC));
FWndProcInstanceStub := MakeObjectInstance(WndProcSubClassed);
SetWindowlong(_Wnd, GWL_WNDPROC, NativeInt(FWndProcInstanceStub));
end;
// un-subclass the window by restoring the previous WindowProc
procedure TSelectDirCallback.UnsubClass;
begin
if FWndProcPrevious <> nil then begin
SetWindowlong(FWnd, GWL_WNDPROC, NativeInt(FWndProcPrevious));
FreeObjectInstance(FWndProcInstanceStub);
FWndProcPrevious := nil;
FWndProcInstanceStub := nil;
end;
end;
// The WindowsProc method set by sublcassing the window.
// Waits for the first WM_SIZE message, sets the dialog position
// and un-subclasses the window.
procedure TSelectDirCallback.WndProcSubClassed(var _Msg: TMessage);
begin
if (_Msg.Msg = WM_SIZE) then begin
SetDialogPosition;
_Msg.Result := CallWindowProc(FWndProcPrevious, FWnd, _Msg.Msg, _Msg.WParam, _Msg.lParam);
UnsubClass;
end;
_Msg.Result := CallWindowProc(FWndProcPrevious, FWnd, _Msg.Msg, _Msg.WParam, _Msg.lParam);
end;
procedure TSelectDirCallback.SetDialogPosition;
var
Rect: TRect;
Monitor: TMonitor;
ltwh: TRectLTWH;
RefLtwh: TRectLTWH;
frm: TCustomForm;
begin
GetWindowRect(FWnd, Rect);
if Assigned(FParent) then begin
// this is new: Center on the parent form if a parent was given
frm := GetParentForm(FParent);
Monitor := Screen.MonitorFromWindow(frm.Handle);
RefLtwh.Assign(frm.BoundsRect);
end else begin
if Assigned(Application.MainForm) then
Monitor := Screen.MonitorFromWindow(Application.MainForm.Handle)
else
Monitor := Screen.MonitorFromWindow(0);
RefLtwh.Assign(Monitor.BoundsRect);
end;
ltwh.Assign(Rect);
ltwh.Left := RefLtwh.Left + RefLtwh.Width div 2 - ltwh.Width div 2;
ltwh.Top := RefLtwh.Top + RefLtwh.Height div 2 - ltwh.Height div 2;
TMonitor_MakeFullyVisible(Monitor, ltwh);
SetWindowPos(FWnd, 0, ltwh.Left, ltwh.Top, 0, 0, SWP_NOZORDER or SWP_NOSIZE);
end;
function TSelectDirCallback.SelectDirCB(_Wnd: HWND; _uMsg: UINT; _lParam, _lpData: lParam): Integer;
procedure SelectDirectory;
begin
if FDirectory <> '' then begin
// we use PostMessage to asynchronously select the directory
PostMessage(_Wnd, BFFM_SETSELECTION, Windows.WParam(True), Windows.lParam(PChar(FDirectory)));
end;
end;
begin
Result := 0;
if _uMsg = BFFM_INITIALIZED then begin
// Subclass the window to catch the WM_SIZE message when it is automatically being resized
// later in the initialization process. Only then it is possible to get the final size
// and position it correctly.
SubClass(_Wnd);
FInitialized := True;
// Selecting the directory here only selects the entry but does not necessarily make
// it visible. So we set it here and again further below.
SelectDirectory;
end else if (_uMsg = BFFM_VALIDATEFAILEDW) or (_uMsg = BFFM_VALIDATEFAILEDA) then begin
// default code copied from FileCtrl
MessageDlg(Format(SInvalidPath, [PChar(_lParam)]), mtError, [mbOK], 0);
Result := 1;
end else if _uMsg = BFFM_SELCHANGED then begin
if FInitialized and not FPositioned then begin
FPositioned := True;
// The first call to SelectDirectory only selects it but does not scroll the tree view
// to make it visible. That's what this second call is for.
SelectDirectory;
end;
end;
end;
// This is the actual callback function passed to the Windows API. lpData is the TSelectDirCallback
// object we created. Here we simply call its SelectDirCB method.
function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam): Integer stdcall;
begin
Result := TSelectDirCallback(lpData).SelectDirCB(Wnd, uMsg, lParam, lpData);
end;
function SelectDirectory(const Caption: string; const Root: WideString;
var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: TWinControl = nil): Boolean;
begin
Result := dzSelectDirectory(Caption, Root, Directory, Options, Parent);
end;
// This is copied from FileCtrl, mostly unchanged. I removed the WITH statement though.
function dzSelectDirectory(const Caption: string; const Root: WideString;
var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: TWinControl = nil): Boolean;
var
BrowseInfo: TBrowseInfo;
OldErrorMode: Cardinal;
ShellMalloc: IMalloc;
IDesktopFolder: IShellFolder;
Eaten, Flags: LongWord;
CoInitResult: HRESULT;
SelectDirCallback: TSelectDirCallback;
WindowList: Pointer;
Buffer: PChar;
RootItemIDList, ItemIDList: PItemIDList;
begin
Result := False;
if not DirectoryExists(Directory) then
Directory := '';
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then begin
Buffer := ShellMalloc.Alloc(MAX_PATH * SizeOf(Char));
try
RootItemIDList := nil;
if Root <> '' then begin
SHGetDesktopFolder(IDesktopFolder);
IDesktopFolder.ParseDisplayName(Application.Handle, nil,
POleStr(Root), Eaten, RootItemIDList, Flags);
end;
// fill BrowseInfo
if (Parent = nil) or not Parent.HandleAllocated then
BrowseInfo.hwndOwner := Application.Handle
else
BrowseInfo.hwndOwner := Parent.Handle;
BrowseInfo.pidlRoot := RootItemIDList;
BrowseInfo.pszDisplayName := Buffer;
BrowseInfo.lpszTitle := PChar(Caption);
BrowseInfo.lpfn := SelectDirCB;
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
if sdNewUI in Options then
BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_NEWDIALOGSTYLE;
if not (sdNewFolder in Options) then
BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_NONEWFOLDERBUTTON;
if sdShowEdit in Options then
BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_EDITBOX;
if not (sdNewUI in Options) and (sdShowShares in Options) then
BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_SHAREABLE;
if sdShowFiles in Options then
BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_BROWSEINCLUDEFILES;
if sdValidateDir in Options then
BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_VALIDATE;
SelectDirCallback := TSelectDirCallback.Create(Directory, Parent);
try
BrowseInfo.lParam := lParam(SelectDirCallback);
// Not sure if this is necessary. Delphi 2007 does it, Delphi 10.1 doesn't
if sdNewUI in Options then begin
CoInitResult := CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
if CoInitResult = RPC_E_CHANGED_MODE then
BrowseInfo.ulFlags := BrowseInfo.ulFlags and not BIF_NEWDIALOGSTYLE;
end;
try
WindowList := DisableTaskWindows(0);
OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
ItemIDList := ShBrowseForFolder(BrowseInfo);
finally
SetErrorMode(OldErrorMode);
EnableTaskWindows(WindowList);
end;
finally
if sdNewUI in Options then
CoUninitialize;
end;
finally
SelectDirCallback.Free;
end;
Result := ItemIDList <> nil;
if Result then begin
ShGetPathFromIDList(ItemIDList, Buffer);
ShellMalloc.Free(ItemIDList);
Directory := Buffer;
end;
finally
ShellMalloc.Free(Buffer);
end;
end;
end;
end.
The unit u_dzSelectDirectoryFix is part of my dzlib in the svn repository on SourceForge.