Chip 2001 December/Chip_2001-12_cd1.bin/zkuste/delphi/kolekce/d345/JWTOOL.ZIP/jwtool/jwShellBrowseFolder.pas

Pascal/Delphi Source File | 2001-09-29 | 7.6 KB | 225 lines

unit jwShellBrowseFolder;

//  Version History
//     Num     Date                 Notes
//     1.00  September 27, 2001    Initial Release

//  Created By:
//    Joseph Wilcock
//    [e-mail]
//    http://msnhomepages.talkcity.com/RedmondAve/coockoo/

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TBrowseKind = ( bkError, bkComputers, bkPrinters, bkAncestors, bkFolders );
  TRootStart = ( rsError, rsNone, rsCONTROLS, rsDESKTOP, rsDESKTOPDIRECTORY,
        rsDRIVES, rsFONTS, rsNETHOOD, rsNETWORK, rsPERSONAL, rsPRINTERS,
        rsPROGRAMS, rsRECENT, rsSENDTO, rsSTARTMENU, rsSTARTUP, rsTEMPLATES );

  TjwShellBrowseFolder = class(TComponent)
  private
    { Private declarations }
    FHandle: THandle;
    FBrowseKind: TBrowseKind;
    FDontGoBelowDomain: Boolean;
    FStatusText: Boolean;
    FCaptionText: String;
    FSelectedFolder: String;
    FRootStart: TRootStart;
    procedure SetBrowseKind(const Value: TBrowseKind);
    procedure SetCaptionText(const Value: String);
    procedure SetDontGoBelowDomain(const Value: Boolean);
    procedure SetStatusText(const Value: Boolean);
    procedure SetRootStart(const Value: TRootStart);
  protected
    { Protected declarations }
    Function SetSelection( hwnd: THandle; const Value: String ): Boolean;
    function EnableOK( hwnd: THandle ): Boolean;
    Function BrowseCallbackProc( hwnd: THandle; uMsg: UINT; lParam, lpData: LPARAM ): Integer; stdcall;
    Function GetFolder( aHandle: THandle; Caption: String; Flags: UINT; RootStart: TRootStart ): String;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    Function Execute: Boolean;
    Property SelectedFolder: String Read FSelectedFolder;
    Property CarryHandle: THandle Read FHandle Write FHandle;
  published
    { Published declarations }
    Property BrowseKind: TBrowseKind Read FBrowseKind Write SetBrowseKind default bkFolders;
    Property DontGoBelowDomain: Boolean Read FDontGoBelowDomain Write SetDontGoBelowDomain Default True;
    Property StatusText: Boolean Read FStatusText Write SetStatusText Default False;
    Property CaptionText: String Read FCaptionText Write SetCaptionText;
    Property RootStart: TRootStart Read FRootStart Write SetRootStart Default rsDESKTOP;
  end;

procedure Register;

implementation

uses ShlObj;

procedure Register;
begin
  RegisterComponents('JwTools', [TjwShellBrowseFolder]);
end;

{ TjwShellBrowseFolder }

Function TjwShellBrowseFolder.GetFolder( aHandle: THandle; Caption: String; Flags: UINT; RootStart: TRootStart ): String;
var
  BrowseInfo: TBrowseInfo;
  PIDL,RIDL: PItemIDList;
  DisplayName: Array[0..MAX_PATH] of Char;
  RootFlag: Integer;
begin
  // this is an interesting way to do it, but DON'T do this to a pointer
  //   ....it turns it null....
  RootFlag := 0;
  Case RootStart of
    rsCONTROLS: RootFlag := CSIDL_CONTROLS;
    rsDESKTOP: RootFlag := CSIDL_DESKTOP;
    rsDESKTOPDIRECTORY: RootFlag := CSIDL_DESKTOPDIRECTORY;
    rsDRIVES: RootFlag := CSIDL_DRIVES;
    rsFONTS: RootFlag := CSIDL_FONTS;
    rsNETHOOD: RootFlag := CSIDL_NETHOOD;
    rsNETWORK: RootFlag := CSIDL_NETWORK;
    rsPERSONAL: RootFlag := CSIDL_PERSONAL;
    rsPRINTERS: RootFlag := CSIDL_PRINTERS;
    rsPROGRAMS: RootFlag := CSIDL_PROGRAMS;
    rsRECENT: RootFlag := CSIDL_RECENT;
    rsSENDTO: RootFlag := CSIDL_SENDTO;
    rsSTARTMENU: RootFlag := CSIDL_STARTMENU;
    rsSTARTUP: RootFlag := CSIDL_STARTUP;
    rsTEMPLATES: RootFlag := CSIDL_TEMPLATES;
  end;
  SHGetSpecialFolderLocation( aHandle, RootFlag, RIDL );
  FillChar( BrowseInfo, SizeOF(BrowseInfo), #0 );
  with BrowseInfo do
    begin
      hwndOwner := aHandle;  // Handle of the owner window for the dialog box
      pidlRoot := RIDL;      // Pointer to an item identifier list (an ITEMIDLIST structure)
                             //   specifying the location of the "root" folder to browse from
      pszDisplayName := @DisplayName[0];   // Pointer to a buffer that receives the display
                                           //   name of the folder selected by the user
      lpszTitle := @Caption[1];  // Pointer to a null-terminated string that is displayed
                                 //   above the tree view control in the dialog box
      ulFlags := Flags;          // Value specifying the types of folders
                                 //   to be listed in the dialog box as well as other options
      //lpfn := @BrowseCallbackProc;             // Address an application-defined function that
                                 //   the dialog box calls when events occur.
      //lParam: LPARAM;          // extra info that's passed back in callbacks
      //iImage: Integer;         // output var: where to return the Image index.
    end;
  PIDL := ShlObj.SHBrowseForFolder( BrowseInfo );
  Result := '';
  if Assigned( PIDL ) then
    begin
      if ShlObj.SHGetPathFromIDList( PIDL, Displayname ) then
        Result := StrPas( DisplayName );
      GlobalFreePtr(PIDL);
    end;
  //  I'm not sure if I can use this function or if I need to get the SHMalloc
  //     object to do it.  This seems to work, but... I'm not sure...
  GlobalFreePtr(RIDL);
end;

function TjwShellBrowseFolder.BrowseCallbackProc(hwnd: THandle; uMsg: UINT;
  lParam, lpData: LPARAM): Integer;
begin
//  Obviously, this isn't implimented... the API is *very* poorly documented.
  case uMsg of
    BFFM_INITIALIZED:;
     BFFM_SELCHANGED:;
  end;
  Result := 0;
end;

constructor TjwShellBrowseFolder.Create(AOwner: TComponent);
begin
  inherited Create( aOwner );
  FBrowseKind := bkFolders;
  FDontGoBelowDomain := True;
  FStatusText := False;
  FCaptionText := 'Select a folder';
  FSelectedFolder := '';
  FRootStart := rsDESKTOP;

  // You know, this is good to have, yet not exactly necessary.
  //   Therefore, I decided to do this and allow the value to
  //   be overridden.
  if ( Owner is TForm ) then
    FHandle := ( Owner as TForm ).Handle
  else
    FHandle := 0;
end;

function TjwShellBrowseFolder.EnableOK( hwnd: THandle ): Boolean;
begin
  // Yet again, another function undefined...
  //SendMessage(hwnd, BFFM_ENABLEOK, 1, 0);
  Result := False;
end;

function TjwShellBrowseFolder.Execute: Boolean;
var
  Flags: UINT;
begin
  Result := False;
  Flags := 0;
  case FBrowseKind of
    bkComputers: Flags := BIF_BROWSEFORCOMPUTER;
     bkPrinters: Flags := BIF_BROWSEFORPRINTER;
    bkAncestors: Flags := BIF_RETURNFSANCESTORS;
      bkFolders: Flags := BIF_RETURNONLYFSDIRS;
  end;
  if FDontGoBelowDomain then
    Flags := Flags and BIF_DONTGOBELOWDOMAIN;
  if FStatusText then
    Flags := Flags and BIF_STATUSTEXT;
  FSelectedFolder := GetFolder( 0, FCaptionText, Flags, FRootStart );
  Result := Length( FSelectedFolder ) > 0;
end;

procedure TjwShellBrowseFolder.SetBrowseKind(const Value: TBrowseKind);
begin
  FBrowseKind := Value;
end;

procedure TjwShellBrowseFolder.SetCaptionText(const Value: String);
begin
  FCaptionText := Value;
end;

procedure TjwShellBrowseFolder.SetDontGoBelowDomain(const Value: Boolean);
begin
  FDontGoBelowDomain := Value;
end;

procedure TjwShellBrowseFolder.SetRootStart(const Value: TRootStart);
begin
  FRootStart := Value;
end;

procedure TjwShellBrowseFolder.SetStatusText(const Value: Boolean);
begin
  FStatusText := Value;
end;

function TjwShellBrowseFolder.SetSelection(hwnd: THandle;
  const Value: String): Boolean;
begin
  // ...ibdib...
  Result := True;
  try
   // SendMessage(hwnd, BFFM_SETSELECTION, 1, PChar(@Value[1]+#0));
  except
    Result := False;
  end;
end;

end.