Browse Directories and Files

unit DirBrowseDialog;
  {TDirBrowse component by Glenn9999 at tek-tips.com, updated here 6/21/2011 }
interface

  {$R DIRBROWSEDIALOG.DCR}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  shlobj, DsgnIntf;

const
  BIF_NEWDIALOGSTYLE = $40;

  CSIDL_PERSONAL = $0005; { My Documents }
  CSIDL_APPDATA = $001A; { Application Data, new for NT4 }
  CSIDL_LOCAL_APPDATA = $001C; { non roaming, user\Local Settings\Application Data }
  CSIDL_INTERNET_CACHE = $0020;
  CSIDL_COOKIES = $0021;
  CSIDL_HISTORY = $0022;
  CSIDL_COMMON_APPDATA = $0023; { All Users\Application Data }
  CSIDL_WINDOWS = $0024; { GetWindowsDirectory() }
  CSIDL_SYSTEM = $0025; { GetSystemDirectory() }
  CSIDL_PROGRAM_FILES = $0026; { C:\Program Files }
  CSIDL_MYPICTURES = $0027; { My Pictures, new for Win2K }
  CSIDL_PROGRAM_FILES_COMMON = $002b; { C:\Program Files\Common }
  CSIDL_COMMON_DOCUMENTS = $002e; { All Users\Documents }
  CSIDL_COMMON_ADMINTOOLS = $002f; { All Users\Start Menu\Programs\Administrative Tools }
  CSIDL_ADMINTOOLS = $0030; { <user name>\Start Menu\Programs\Administrative Tools }

type
{ TPathName is an explicit path name designed to be connected to a property
  editor which triggers this control.  It must be defined like this so Delphi
  distinguishes it from regular string types in this control and in other
  controls }
  TPathName = String[255];
  TBDirFlag = (bifBrowseFolders, bifBrowseFiles, bifBrowseComputer,
               bifBrowsePrinter);
  TBStartFlag = (ciNone, ciRecycleBin, ciControlPanel,
                 ciDesktopDirectory, ciMyComputer, ciFonts, ciNetHood,
                 ciMyDocuments, ciPrograms, ciRecent, ciSendTo,
                 ciStartMenu, ciStartup, ciTemplates, ciAppdata, ciFavorites,
                 ciHistory, ciInternetCache, ciLocalAppData,
                 ciMyPictures, ciSystem, ciWindows, ciAdminTools,
                 ciCommonAdminTools, ciCommonAppData,
                 ciCookies, ciProgramFiles, ciCommonProgramFiles);

  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 TPathName within this component
  TPathNameProperty = 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: TPathName;      // path or dir returned
    FStartDir: TPathName;     // 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: TPathName read FStartDir write FStartDir;
    property StatusMsg: Boolean read FStatusMsg write FStatusMsg;
    property DirName: TPathName 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 through TPathNameProperty
     begin
       case uMsg of
         BFFM_INITIALIZED: // initialization code
           begin
             SendMessage(wnd, BFFM_SETSELECTIONA, Longint(true), lpdata);
             centercbwindow(wnd);
           end;
       end;
       Result := 0;
     end;

  function TPathNameProperty.GetAttributes: TPropertyAttributes;
    // property handler for file dir paths, set attributes for the property
    begin
      Result := [paDialog, paReadOnly];
    end {GetAttributes};

  procedure TPathNameProperty.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 VCL dialog
     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;
      ciAppdata: sflag := CSIDL_APPDATA;
      ciFavorites: sflag := CSIDL_FAVORITES;
      ciHistory: sflag := CSIDL_HISTORY;
      ciInternetCache: sflag := CSIDL_INTERNET_CACHE;
      ciLocalAppData: sflag := CSIDL_LOCAL_APPDATA;
      ciMyPictures: sflag := CSIDL_MYPICTURES;
      ciSystem: sflag := CSIDL_SYSTEM;
      ciWindows: sflag := CSIDL_WINDOWS;
      ciAdminTools: sflag := CSIDL_ADMINTOOLS;
      ciCommonAdminTools: sflag := CSIDL_COMMON_ADMINTOOLS;
      ciCommonAppData: sflag := CSIDL_COMMON_APPDATA;
      ciCookies: sflag := CSIDL_COOKIES;
      ciProgramFiles: sflag := CSIDL_PROGRAM_FILES;
      ciCommonProgramFiles: sflag := CSIDL_PROGRAM_FILES_COMMON;
    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(String(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 := String(temppath)
        else
          FDirName := String(DisplayName);
        Result := true;
        GlobalFreePtr(lpItemID);
      end
    else
      Result := false;
  end;

procedure Register;
begin
  RegisterComponents('Samples', [TDirBrowseDialog]);
// this line below isolates the property editor to this control only
//  RegisterPropertyEditor(TypeInfo(TPathName), TDirBrowseDialog, '', TPathNameProperty);
  RegisterPropertyEditor(TypeInfo(TPathName), nil, '', TPathNameProperty)
end;

end.