unit UIShellFolder;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, AppEvnts, ExtCtrls,
  ShlObj;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    ComboBox1: TComboBox;
    ListBox1: TListBox;
    Label1: TLabel;
    Label2: TLabel;
    RadioGroup1: TRadioGroup;
    ApplicationEvents1: TApplicationEvents;
    procedure ComboBox1CloseUp(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure ApplicationEvents1ShowHint(var HintStr: String;
      var CanShow: Boolean; var HintInfo: THintInfo);
  private
    { Private declarations }
    function NameOfFolder(ShellFolder: IShellFolder; pidl: PItemIDList): string;
    procedure ListOfFolder(ShellFolder: IShellFolder;
                           Flags: Cardinal = SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
var Apidl: array of PItemIDList; // массив PItemIDList текущей папки
    AFolder: array of IShellFolder; // массив последовательности папок
    LListBox: boolean = true;

function TForm1.NameOfFolder(ShellFolder: IShellFolder; pidl: PItemIDList): string;
var lpName: TStrRet;
    grfFlags: DWORD;
begin
 case RadioGroup1.ItemIndex of
  0: grfFlags := SHGDN_NORMAL;
  1: grfFlags := SHGDN_INFOLDER;
  2: grfFlags := SHGDN_FORPARSING;
 end;
 ShellFolder.GetDisplayNameOf(pidl,grfFlags,lpName);
 case lpName.uType of
  STRRET_WSTR:   Result := lpName.pOleStr;
  STRRET_OFFSET: Result := PChar(pidl.mkid.abID[lpName.uOffset - sizeof(pidl.mkid.cb)]);
  STRRET_CSTR:   Result := lpName.cStr;
 end;
end;

procedure TForm1.ListOfFolder(ShellFolder: IShellFolder; Flags: Cardinal = SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN);
var pidl: PItemIDList;
    Num: Cardinal;
    Enum: IEnumIDList;
begin
 if LListBox
  then begin
   SetLength(Apidl,0);
   ListBox1.Clear;
   ListBox1.Items.Add('Назад');
  end;
 Memo1.Clear;
 ShellFolder.EnumObjects(Application.Handle, Flags, Enum);
 while Enum.Next(1,pidl,Num) = S_OK do
 begin
  Memo1.Lines.Add(NameOfFolder(ShellFolder, pidl));
  if LListBox
  then begin
   SetLength(Apidl, High(Apidl) + 2);
   Apidl[High(Apidl)] := pidl;
   ListBox1.Items.Add(NameOfFolder(ShellFolder, pidl));
  end; 
 end;
end;

procedure TForm1.ComboBox1CloseUp(Sender: TObject);
var nFolder: Integer;
    pidl: PItemIDList;
    ISF1: IShellFolder;
begin
 case ComboBox1.ItemIndex of
  0: nFolder := CSIDL_BITBUCKET;
  1: nFolder := CSIDL_CONTROLS;
  2: nFolder := CSIDL_DESKTOPDIRECTORY;
  3: nFolder := CSIDL_DRIVES;
  4: nFolder := CSIDL_FONTS;
  5: nFolder := CSIDL_NETHOOD;
  6: nFolder := CSIDL_NETWORK;
  7: nFolder := CSIDL_PERSONAL;
  8: nFolder := CSIDL_PRINTERS;
  9: nFolder := CSIDL_PROGRAMS;
  10: nFolder := CSIDL_RECENT;
  11: nFolder := CSIDL_SENDTO;
  12: nFolder := CSIDL_STARTMENU;
  13: nFolder := CSIDL_STARTUP;
  14: nFolder := CSIDL_TEMPLATES;
 end;
 SHGetSpecialFolderLocation(Handle, nFolder, pidl);
 AFolder[0].BindToObject(pidl, nil, IID_IShellFolder, Pointer(ISF1));
 LListBox := false;
 ListOfFolder(ISF1);
 LListBox := true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 SetLength(AFolder, 1);
 if(SHGetDesktopFolder(AFolder[0]) <> NOERROR)
  then ShowMessage('Корневая папка недоступна')
  else ListOfFolder(AFolder[0]);
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
var pidl: PItemIDList;
    Flags: UINT;
begin
 if ListBox1.ItemIndex > 0
 then begin
  pidl := Apidl[ListBox1.ItemIndex - 1];
  Flags := SFGAO_FOLDER or SFGAO_FILESYSANCESTOR;
  AFolder[High(AFolder)].GetAttributesOf(1, pidl, Flags);
  if ((SFGAO_FOLDER and Flags) <> 0) and
     ((SFGAO_FILESYSANCESTOR and Flags) <> 0)
  then begin
   Label2.Caption := Label2.Caption + '\' + NameOfFolder(AFolder[High(AFolder)], pidl);
   SetLength(AFolder, High(AFolder) + 2);
   AFolder[High(AFolder) - 1].BindToObject(
           pidl, nil, IID_IShellFolder, AFolder[High(AFolder)]);
   ListOfFolder(AFolder[High(AFolder)]);
  end
  else ShowMessage('"' + NameOfFolder(AFolder[High(AFolder)], pidl) +
                   '" не папка');
 end
 // если выбрана строка "Назад"
 else if High(AFolder) > 0
 then begin
  SetLength(AFolder, High(AFolder));
  Label2.Caption := Copy(Label2.Caption, 1, LastDelimiter('\', Label2.Caption) - 1);
  ListOfFolder(AFolder[High(AFolder)]);
 end
 else ListOfFolder(AFolder[0]);
end;

procedure TForm1.ApplicationEvents1ShowHint(var HintStr: String;
  var CanShow: Boolean; var HintInfo: THintInfo);
begin
if (HintInfo.HintControl = ListBox1) and (ListBox1.ItemIndex >= 0)
  then if (Label1.Canvas.TextWidth(ListBox1.Items[ListBox1.ItemIndex]) >
           ListBox1.ClientWidth)
  then begin
    HintStr:=ListBox1.Items[ListBox1.ItemIndex];
    ApplicationEvents1.CancelDispatch;
  end;
end;

end.
