CD Shareware Magazine 1996 December/CD_shareware_12-96.iso/WIN/Programa/JPRSHBR.ZIP/JPRSHBR.PAS

Pascal/Delphi Source File | 1996-08-11 | 7.3 KB | 264 lines

Unit JPRShBr;

//                       TShellBrowser
//  A VCL encapsulation of the Win95/NT4 SHBrowseForFolder API function
//
//               Copyright ⌐ 1996 JP Ritchey

interface

uses Windows,Classes,ShellAPI;

type
  TShellBrowserOption = (shbBrowseForComputer,shbBrowseForPrinter,
                         shbDontGoBelowDomain,shbReturnFSAncestors,
                         shbReturnOnlyFSDirs,shbStatusText);
  TShellBrowserOptions = set of TShellBrowserOption;


  TSelChangeEvent = procedure(Sender:TObject; NewFolder:String; IsDisplayName:boolean) of object;

  TShellBrowser = class(TComponent)
  private
    fOnInitialize:TNotifyEvent;
    fOnSelChange:TSelChangeEvent;
    fPrompt:String;
    fRootPath:String;
    fInitialPath:String;
    fPathName:String;
    fDisplayName:String;
    fStatusText:String;
    fCaption:String;
    fOptions:TShellBrowserOptions;
    fDialogWnd:HWND;
    function BrowserCallback(Wnd:HWND; Msg:UINT; lParam:LPARAM):integer;
    procedure SetStatusText(const Value:String);
    procedure SetCaption(const Value:String);
  public
    constructor Create(AOwner:TComponent); override;
    function Execute:boolean;
    procedure EnableOK(Enable:boolean);
    procedure SetSelection(const Value:String);
    property DialogWnd:HWND read fDialogWnd;
    property PathName:String read fPathName;
    property DisplayName:String read fDisplayName;
  published
    property InitialPath:String read fInitialPath write fInitialPath;
    property RootPath:String read fRootPath write fRootPath;
    property Prompt:String read fPrompt write fPrompt;
    property Caption:String read fCaption write SetCaption;
    property StatusText:String read fStatusText write SetStatusText;
    property Options:TShellBrowserOptions read fOptions write fOptions;
    property OnInitialize:TNotifyEvent read fOnInitialize write fOnInitialize;
    property OnSelChange:TSelChangeEvent read fOnSelChange write fOnSelChange;
  end;

procedure Register;

implementation

uses SysUtils,Messages,Controls,OLE2,SHLOBJ;

procedure Register;
begin
  RegisterComponents('Dialogs',[TShellBrowser]);
end;

function ItemIDListToPath(PIDL:PItemIDList):String;
var
  szPath:array[0..MAX_PATH] of char;
begin
  if ShGetPathFromIDList(PIDL,@szPath) then
     Result := String(szPath)
  else
     Result := '';
end;

function ItemIDListToDisplayName(PIDL:PItemIDList):String;
var
   pDesktopFolder:ISHELLFOLDER;
   STRRET : TSTRRET;
begin
 if Succeeded(SHGetDesktopFolder(pDesktopFolder)) then
    try
       pDesktopFolder.GetDisplayNameOf(PIDL,SHGDN_NORMAL,STRRET);
       case STRRET.uType of
         STRRET_CSTR: REsult := String(STRRET.cStr);
         STRRET_WSTR: Result := WideCharToString(STRRET.pOLEStr);
         STRRET_OFFSET: Result := StrPas(Pchar(PIDL)+STRRET.uOffset);
       end;
    finally
       pDesktopFolder.Release;
       end
 else
    Result := '';
end;

function PathToItemIDList(APath:String):PItemIDList;
var
   pidl:PITEMIDLIST;
   pDesktopFolder:ISHELLFOLDER;
   olePath:array[0..MAX_PATH] of TOLECHAR;
   chEaten:ULONG;
   dwAttributes:ULONG;
begin
 if Succeeded(SHGetDesktopFolder(pDesktopFolder)) then
    try
     MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,PChar(APAth),-1,olePath,MAX_PATH);
     if Succeeded(pDesktopFolder.ParseDisplayName(0,nil,olePath,chEaten,pidl,dwAttributes)) then
        Result := pidl
     else
        Result := nil;
     finally
       pDesktopFolder.Release;
     end
 else
     Result := nil;
end;


function glBrowseCallback(Wnd:HWND; Msg:UINT; lParam:LPARAM; lData:TShellBrowser):integer; stdcall;
begin
  Result := lData.BrowserCallback(Wnd,Msg,lParam);
end;

function OptionsToFlags(AOptions:TShellBrowserOptions):UINT;
var
  SBO:TShellBrowserOption;
const
  SBOArray:array[TShellBrowserOption] of UINT = (
           BIF_BROWSEFORCOMPUTER,BIF_BROWSEFORPRINTER,BIF_DONTGOBELOWDOMAIN,
           BIF_RETURNFSANCESTORS,BIF_RETURNONLYFSDIRS,BIF_STATUSTEXT);
begin
  Result := 0;
  for SBO := Low(TShellBrowserOption) to High(TShellBrowserOption) do
      if SBO in AOptions then
         Result := Result or SBOArray[SBO];
end;

constructor TShellBrowser.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  fOptions := [shbReturnFSAncestors,shbReturnOnlyFSDirs];
end;

function TShellBrowser.Execute:boolean;
var
  BI:TBrowseInfo;
  RootPIDL:PItemIDList;
  IDList:PItemIDList;
  Malloc:IMalloc;
  PathSelected:array[0..MAX_PATH] of char;
begin
  FillChar(BI,Sizeof(BI),#00);
  With BI do begin
   if Owner is TWinControl then
      hwndOwner := TWinControl(Owner).Handle
   else
      hwndOwner := 0;
   if RootPath <> '' then
      if lowercase(RootPath) = 'mycomputer' then
         begin
         SHGetSpecialFolderLocation(hwndOwner,CSIDL_DRIVES,RootPIDL);
         pidlRoot := RootPIDL;
         end
      else
         begin
         RootPIDL := PathToItemIDList(RootPath);
         pidlRoot := RootPIDL;
         end
   else
      RootPIDL := nil;
   ulFlags := OptionsToFlags(fOptions);
   pszDisplayName := @PathSelected;
   if fPrompt <> '' then
      lpszTitle := Pchar(fPrompt);
   lpfn := @glBrowseCallback;
   lParam := longint(Self);
  end;
  Result := true;
  IDList := SHBrowseForFolder(BI);  // display the dialog modally
  if RootPIDL <> nil then
     begin
     SHGetMalloc(Malloc);
     Malloc.Free(RootPIDL);
     end;
  fDialogWnd := 0;
  if IDList <> nil then
     begin
     fPathName := ItemIDListToPath(IDList);
     fDisplayName := ItemIDListToDisplayName(IDList);
     SHGetMalloc(Malloc);
     Malloc.Free(IDList);
     end
  else
     begin
     fPathName := '';
     fDisplayName := '';
     Result := false;
     end;
end;

function TShellBrowser.BrowserCallback(Wnd:HWND; Msg:UINT; lParam:LPARAM):integer;
var
  Temp:String;
begin
  Result := 0;
  if Msg = BFFM_INITIALIZED then
    begin
    fDialogWnd := Wnd;
    if InitialPath <> '' then
       SetSelection(fInitialPath);
    if fStatusText <> '' then
       SetStatusText(fStatusText);
    if fCaption <> '' then
       Caption := fCaption;
    if Assigned(fOnInitialize) then
       fOnInitialize(Self);
    end
  else if Msg = BFFM_SELCHANGED then
    if fDialogWnd <> 0 then
       if Assigned(fOnSelChange) then
          begin
          Temp := ItemIDListToPath(PItemIDLIST(lParam));
          if Temp = '' then
             begin
             Temp := ItemIDListToDisplayName(PItemIDLIST(lParam));
             fOnSelChange(Self,Temp,true);
             end
          else
             fOnSelChange(Self,Temp,false);
          end;
end;

procedure TShellBrowser.SetCaption;
begin
  fCaption := Value;
  if fDialogWnd <> 0 then
     SendMessage(DialogWnd,WM_SETTEXT,0,longint(PChar(fCaption)));
end;

procedure TShellBrowser.EnableOK(Enable:boolean);
var
  wParam:Cardinal;
begin
 if Enable then wParam := 1 else wParam := 0;
 if DialogWnd <> 0 then
    SendMessage(DialogWnd,BFFM_ENABLEOK,wParam,wPAram);
end;

procedure TShellBrowser.SetSelection(const Value:String);
begin
 if DialogWnd <> 0 then
    SendMessage(DialogWnd,BFFM_SETSELECTION,1,longint(Pchar(fInitialPath)));
end;

procedure TShellBrowser.SetStatusText;
begin
  fStatusText := Value;
  if DialogWnd <> 0 then
     SendMessage(DialogWnd,BFFM_SETSTATUSTEXT,0,longint(Pchar(fStatusText)));
end;

end.