(************************************************************************
*    This File is Part of the AHM Triton Tools                          *
*    for Borland Delphi and C++ Builder.                                *
*************************************************************************
* Copyright © 1995-1999 Alexander H. Mehlhorn (AHM) and Tritontools.com *
* All Rights reserved.                                                  *
*                                                                       *
*    For more Information contact us at                                 *
*    E-Mail : support@tritontools.com                                   *
*    URL : http://www.tritontools.com                                   *
*                                                                       *
*    AHM is copyright by Alexander H. Mehlhorn                          *
*    All Parts of this Collection were developed,                       *
*    designed and implemented by AHM                                    *
*                                                                       *
*    Under no Circumstances may you distribute this file                *
*    in this or any other format. This File is supplied                 *
*    as Evaluation of Source only. No Delphi Components may be developed*
*    using extracts or subsets of this code without expressed permission*
*    by AHM.                                                            *
*                                                                       *
*************************************************************************)
unit AHMTFolderBrowser;

interface
uses
  Windows, Messages, Classes, Forms, Dialogs, SysUtils, Shlobj, Controls,
  Graphics,AHMDialogClass, ShellAPI;
type
  TAHMPathChange = procedure(Sender : TObject;const NewPath : String) of Object;
  TAHMCheckPath = procedure(Sender : TObject;const NewPath : String;var ValidPath : Boolean) of Object;
  TAHMBrowseRoots=(csidlDesktop,csidlDesktopExpanded,csidlPrograms,
                csidlControlPanel,csidlPrinters,csidlPersonal,csidlFavorites,
                csidlStartup,csidlRecent,csidlSendto,csidlRecycleBin,
                csidlStartMenu,csidlDesktopDirectory,csidlMyComputer,
                csidlNetwork,csidlNetworkNeighborhood,csidlFonts,csidlTemplates);
  TAHMBrowseInfoFlags=(bifFileSystemDirsOnly,bifDontGoBelowDomain,bifStatusText,
                    bifFileSystemAncestors,bifBrowseForComputer,bifBrowseForPrinter);
  TAHMBrowseInfoFlagSet=set of TAHMBrowseInfoFlags;
type
  TAHMFolderBrowser = class(TAHMDialogComponent)
  private
     FDialogHandle: HWnd;
     FParentHandle: HWnd;
     FDisplayName: String;
     FImageIndex: Integer;
     FReturnPath: String;
     FOptions: TAHMBrowseInfoFlagSet;
     FShowPath: Boolean;
     FBrowseRoot: TAHMBrowseRoots;
     FBeforeBrowse : TNotifyEvent;
     FAfterBrowse : TNotifyevent;
     FOnPathChanged : TAHMPathChange;
    FIsDisplayed : Boolean;
    FIsValidPath: TAHMCheckPath;
    FOnCancel: TNotifyEvent;
    FCaption: String;
    procedure SetCaption(const Value: String);
  protected
    procedure SetSelectionPIDL(const Hwnd: HWND; const ItemIDList: PItemIDList);
    procedure SetSelectionPath(const Hwnd: HWND; const Path: String);
    procedure SetCaptionVal(const Hwnd: HWND; const Caption: String);
    procedure EnableOK(const Hwnd: HWND; const Value: Boolean);
    property ParentHandle: HWnd read FParentHandle write FParentHandle;
    property DialogHandle: HWnd read FDialogHandle write FDialogHandle;
  public
    constructor Create(AOwner: TComponent); override;
    function Execute : Boolean; override;
    property DisplayName: String read FDisplayName;
    property ImageIndex: Integer read FImageIndex;
  published
    property ReturnPath: String read FReturnPath write FReturnPath;
    property Caption : String read FCaption write SetCaption;
    property Options : TAHMBrowseInfoFlagSet read FOptions write FOptions default [bifFileSystemDirsOnly, biFStatusText];
    property ShowPath : Boolean read FShowPath write FShowPath default True;
    property BrowseRoot : TAHMBrowseRoots read FBrowseRoot write FBrowseRoot default csidlDesktopExpanded;
    property BeforeBrowse : TNotifyEvent read FBeforeBrowse write FBeforeBrowse;
    property AfterBrowse : TNotifyEvent read FAfterBrowse write FAfterBrowse;
    property IsValidPath : TAHMCheckPath read FIsValidPath write FIsValidPath;
    property OnPathChanged : TAHMPathChange read FOnPathChanged write FOnPathChanged;
    property OnCancel : TNotifyEvent read FOnCancel write FOnCancel;
  end;

implementation

const
  BrowsePathA:

  array[TAHMBrowseRoots] of Integer=(CSIDL_DESKTOP,-1,CSIDL_PROGRAMS,CSIDL_CONTROLS,CSIDL_PRINTERS,
      CSIDL_PERSONAL,CSIDL_FAVORITES,CSIDL_STARTUP,CSIDL_RECENT,CSIDL_SENDTO,CSIDL_BITBUCKET,
      CSIDL_STARTMENU,CSIDL_DESKTOPDIRECTORY,CSIDL_DRIVES,CSIDL_NETWORK,CSIDL_NETHOOD,CSIDL_FONTS,
      CSIDL_TEMPLATES);
  BrowseFlagsA:
    array[TAHMBrowseInfoFlags] of DWord=(BIF_RETURNONLYFSDIRS,BIF_DONTGOBELOWDOMAIN,BIF_STATUSTEXT,
                                 BIF_RETURNFSANCESTORS,BIF_BROWSEFORCOMPUTER,BIF_BROWSEFORPRINTER);
  CUSTOM_BUTTON_ID=255;
  MAX_PATH_DISPLAY_LENGTH=35;


function AHMBreakApart(const theString, Separator: String; var Tokens: TStringList): Integer;
var
  Index: Integer;
  CurrentString: String;
  CurrentToken: String;
  Done: Boolean;
begin
  Result:=0;
  CurrentString:=theString;
  Done:=FALSE;
  Tokens.Clear;
  repeat
    Index:=Pos(Separator,CurrentString);
    if Index=0 then
    begin
      CurrentToken:=CurrentString;
      Done:=TRUE;
    end else
    begin
      CurrentToken:=Copy(CurrentString,1,Index-1);
      CurrentString:=Copy(CurrentString,Index+1,Length(CurrentString)-Index);
    end;
    Tokens.Add(CurrentToken);
    Inc(Result);
  until Done;
end;

procedure AHMCenterWindow(HWindow: HWND);
var
  Rect: TRect;
  FWRect: TRect;
  fw,fh : Integer;
begin
  GetWindowRect(HWindow,Rect);
  fw:=(Screen.Width div 2)-((Rect.Right-Rect.Left) div 2);
  fh:=(Screen.Height div 2)-((Rect.bottom-Rect.top) div 2);
  GetWindowRect(0,FWRect);
  SetWindowPos(HWindow,0,fw,fh,0,0,SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;

function AHMDirectoryExists(const Name: string): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(Name));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;

procedure AHMGetIDListFromPath(Path: String; var ItemIDList: PItemIDList);
var
  ShellFolderInterface: IShellFolder;
  CharsParsed: ULONG;
  Attributes: ULONG;
begin
  if SHGetDesktopFolder(ShellFolderInterface)=NOERROR then
  try
    if AHMDirectoryExists(Path) then
       ShellFolderInterface.ParseDisplayName(0,nil,StringToOleStr(Path),CharsParsed,ItemIDList,Attributes);
  finally
    ShellFolderInterface._Release; {Normal Release for other Delphi}
  end;
end;

function AHMCompressString(const Path, Separator, Replacement: String; MaxLength: DWord): String;
var
  Tokens: TStringList;
function BuildPath(const Components: TStringList): String;
var i: Integer;
begin
  for i:=0 to Components.Count-1 do
  if i=0 then Result:=Components[i]
         else Result:=Result+Separator+Components[i];
end;
begin
  try
    Tokens:=TStringList.Create;
    Result:=Path;
    if StrLen(PChar(Result))<=MaxLength then Exit;
    if AHMBreakApart(Result,Separator,Tokens)<3 then Exit else
    begin
      Tokens[1]:=Replacement;
      Result:=BuildPath(Tokens);
    end;
    while (StrLen(PChar(Result))>MaxLength) and (Tokens.Count>3) do
    begin
      Tokens.Delete(2);
      Result:=BuildPath(Tokens);
    end;
  finally
    Tokens.Free;
  end;
end;


procedure AHMBrowserCallbackProc(HWindow: HWND; uMsg: Integer; lParameter: LPARAM;lpBrowseFolder: LPARAM); stdcall;
var
  Instance: TAHMFolderBrowser;
  Path: String;
  ValidPath: Boolean;
  TempPath: array[0..MAX_PATH] of Char;
begin
  Instance:=TAHMFolderBrowser(lpBrowseFolder);
  case uMsg of
    BFFM_INITIALIZED:
    begin
      Instance.FIsDisplayed:=True;
      Instance.DialogHandle:=HWindow;
      Instance.SetCaptionVal(HWindow,Instance.FCaption);
      AHMCenterWindow(HWindow);
      SetWindowLong(HWindow,GWL_USERDATA,lpBrowseFolder);
      if AHMDirectoryExists(Instance.ReturnPath) then
         Instance.SetSelectionPath(HWindow,Instance.ReturnPath);
    end;
    BFFM_SELCHANGED:
    begin
      SHGetPathFromIDList(PItemIDList(lParameter),TempPath);
      Instance.FReturnPath:=StrPas(TempPath);
      if Instance.ShowPath then
      begin
        SetLength(Path,MAX_PATH);
        Path:=AHMCompressString(StrPas(TempPath),'\','...',MAX_PATH_DISPLAY_LENGTH);
        SendMessage(HWindow,BFFM_SETSTATUSTEXT,0,Longint(PChar(Path)));
      end;
      ValidPath:=SHGetPathFromIDList(PItemIDList(lParameter),TempPath);
      if Assigned(Instance.IsValidPath) then Instance.IsValidPath(Instance,String(TempPath),ValidPath);
      Instance.EnableOK(HWIndow,ValidPath);
      if Assigned(Instance.OnPathChanged) then Instance.OnPathChanged(Instance,String(TempPath));
    end;
  end;
end;




constructor TAHMFolderBrowser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetLength(FDisplayName,MAX_PATH);
  SetLength(FReturnPath,MAX_PATH);
  FShowPath:=True;
  FParentHandle:=0;
  FBrowseRoot:=csidlDesktopExpanded;
  FOptions:=[bifFileSystemDirsOnly, bifStatusText];
  FReturnPath:='';
  FIsDisplayed:=False;
end;

procedure TAHMFolderBrowser.SetCaptionVal(const Hwnd: HWND; const Caption: String);
begin
  SendMessage(Hwnd,BFFM_SETSTATUSTEXT,0,Longint(PChar(Caption)));
end;

procedure TAHMFolderBrowser.SetSelectionPIDL(const Hwnd: HWND; const ItemIDList: PItemIDList);
begin
  SendMessage(Hwnd,BFFM_SETSELECTION,Ord(FALSE),Longint(ItemIDList));
end;

procedure TAHMFolderBrowser.SetSelectionPath(const Hwnd: HWND; const Path: String);
begin
  SendMessage(Hwnd,BFFM_SETSELECTION,Ord(TRUE),Longint(PChar(Path)));
end;

procedure TAHMFolderBrowser.EnableOK(const Hwnd: HWND; const Value: Boolean);
begin
  SendMessage(Hwnd,BFFM_ENABLEOK,0,Ord(Value));
end;

function TAHMFolderBrowser.Execute: Boolean;
var
  BrowseInfo: TBrowseInfo;
  i: Integer;
  ItemIDList : PItemIDList;
  TempPath: array[0..MAX_PATH] of Char;
begin
  inherited Execute;
  try
    if assigned(FBeforeBrowse) then FBeforeBrowse(self);
    if IsWindow(FParentHandle) then BrowseInfo.hwndOwner:=FParentHandle else
       if (Owner is TWinControl) then BrowseInfo.hwndOwner:=TWinControl(Owner).Handle
           else BrowseInfo.hwndOwner:=Application.MainForm.Handle;
    if FBrowseRoot=csidlDesktopExpanded then BrowseInfo.pidlRoot:=nil else
      SHGetSpecialFolderLocation(Application.Handle,BrowsePathA[FBrowseRoot],BrowseInfo.pidlRoot);
    BrowseInfo.pszDisplayName:=PChar(FDisplayName);
    BrowseInfo.lpszTitle:=PChar(FCaption);
    BrowseInfo.ulFlags:=0;
    for i:=0 to 5 do if TAHMBrowseInfoFlags(i) in FOptions then
       BrowseInfo.ulFlags:=BrowseInfo.ulFlags or BrowseFlagsA[TAHMBrowseInfoFlags(i)];
    BrowseInfo.lpfn:=@AHMBrowserCallbackProc;
    BrowseInfo.lParam:=Longint(Self);
    BrowseInfo.iImage:=0;
    ItemIDList:=SHBrowseForFolder(BrowseInfo);
    Result:=ItemIDList<>nil;
    if Result then
    begin
      SHGetPathFromIDList(ItemIDList,TempPath);
      FReturnPath:=StrPas(TempPath);
      FImageIndex:=BrowseInfo.iImage;
    end else if assigned(FOnCancel) then FOnCancel(Self);
  finally
    FIsDisplayed:=False;
    if assigned(FAfterBrowse) then FAfterBrowse(self);
  end;
end;

procedure TAHMFolderBrowser.SetCaption(const Value: String);
begin
  FCaption := Value;
 if FIsDisplayed then SetCaptionVal(DialogHandle,Value);
end;

end.
