unit SHBFMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Mask, ToolEdit, FileCtrl, ShlObj, ActiveX;

type
  TMainForm = class(TForm)
    RootFolder: TDirectoryEdit;
    Label1: TLabel;
    Label2: TLabel;
    SelectedFolder: TDirectoryEdit;
    BtnSHBFF: TButton;
    Directory: TLabel;
    procedure RootFolderChange(Sender: TObject);
    procedure BtnSHBFFClick(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  MainForm: TMainForm;

function bffCallback(DlgHandle: HWND;
                     Msg:       Integer;
                     lParam:    Integer;
                     lpData:    Integer)
                     : Integer; stdcall;

implementation

{$R *.DFM}

function bffCallback(DlgHandle: HWND;
                     Msg:       Integer;
                     lParam:    Integer;
                     lpData:    Integer)
                     : Integer; stdcall;
begin
  {Vorgewähltes Verzeichnis übermitteln}
  if Msg = BFFM_INITIALIZED then
    SendMessage(DlgHandle, BFFM_SETSELECTION, Integer(LongBool(True)),
                Integer(PChar(MainForm.SelectedFolder.Text)));
end;

function SHGetIDListFromPath(pPath: PChar; var pidl: PItemIDList): Bool;
var
  pwcPath: PWideChar;
  ppshf  : IShellFolder;
  pchEaten: Integer;
  dwAttributes: Integer;
begin
  try
    // IShellFolder will den Unicode-Pfad, also...
    GetMem(pwcPath, SizeOf(WideChar)*MAX_PATH);
    StringToWideChar(pPath, pwcPath, MAX_PATH);
    SHGetDesktopFolder(ppshf);
    try
      Result := LongBool(ppshf.ParseDisplayName(0, nil, pwcPath,
                                pchEaten, pidl, dwAttributes));
    finally
      ppshf := nil;
      { aehm... ich kenne mich mit intefaces nicht so aus.
       Ich hoffe mal so, dass das der richtige weg ist,
       um sowas freizugeben, bei ppshf.Release wird jedenfalls
       eine Exception ausgeloest. }
    end;
  finally
    FreeMem(pwcPath);
  end;
end;

procedure SHFreeItemIDList(var pidl: PItemIDList);
var ppMalloc: IMalloc;
begin
  SHGetMalloc(ppMalloc);
  ppMalloc.Free(pidl);
  pidl := nil;
end;

function GetFolder(Root,Caption:string):string;
var
    bi            : TBROWSEINFO;
    lpBuffer      : PChar;
    RootID,
    pidlBrowse    : PItemIDList;
begin
  {Root-PIDL ermiiteln}
  SHGetIDListFromPath(PChar(Root), RootID);

  lpBuffer:=StrAlloc(max_path);
  bi.hwndOwner := getactivewindow;
  bi.pidlRoot := RootID;
  bi.pszDisplayName := lpBuffer;
  bi.lpszTitle := pChar(Caption);
  bi.ulFlags := BIF_RETURNONLYFSDIRS;
  bi.lpfn := @bffCallback;
{  bi.lpfn := nil;}
  bi.lParam := 0;
  pidlBrowse := SHBrowseForFolder(bi);
  if (pidlBrowse<>nil) then
    if (SHGetPathFromIDList(pidlBrowse, lpBuffer)) then
      Result:=lpBuffer;

  {lpBuffer freigeben}
  StrDispose(lpBuffer);

  {ID-List freigeben}
  SHFreeItemIDList(bi.pidlRoot);
end; {GetFolder}

procedure TMainForm.RootFolderChange(Sender: TObject);
var PartDir : string;
begin
  BtnSHBFF.Enabled:=false;
  if length(SelectedFolder.Text)>=length(RootFolder.Text) then begin
    PartDir:=copy(SelectedFolder.Text, 1, length(RootFolder.Text));
    if (UpperCase(PartDir)=UpperCase(RootFolder.Text)) and
     DirectoryExists(RootFolder.Text) and
     DirectoryExists(SelectedFolder.Text) then
      BtnSHBFF.Enabled:=true
  end;
end;

procedure TMainForm.BtnSHBFFClick(Sender: TObject);
begin
  Directory.Caption:=GetFolder(RootFolder.Text,'Bitte Verzeichnis wählen!');
end;

end.