Форум программистов [Powered by Invision Power Board]

Код
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
uses ShlObj,ActiveX,ShellApi;

const CSIDL_NETWORK = $0012;

var pidlItself:PItemIDList;

function CreatePIDL(Size: Integer): PItemIDList;
var
  Malloc: IMalloc;
begin
  SHGetMalloc(Malloc);

  Result := Malloc.Alloc(Size);
  if Assigned(Result) then
    FillChar(Result^, Size, 0);
end;

function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
  Result := IDList;
  Inc(PChar(Result), IDList^.mkid.cb);
end;

function GetPIDLSize(IDList: PItemIDList): Integer;
begin
  Result := 0;
  if Assigned(IDList) then
  begin
    Result := SizeOf(IDList^.mkid.cb);
    while IDList^.mkid.cb <> 0 do
    begin
      Result := Result + IDList^.mkid.cb;
      IDList := NextPIDL(IDList);
    end;
  end;
end;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
var
  cb1, cb2: Integer;
begin
  if Assigned(IDList1) then
    cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb)
  else
    cb1 := 0;

  cb2 := GetPIDLSize(IDList2);

  Result := CreatePIDL(cb1 + cb2);
  if Assigned(Result) then
  begin
    if Assigned(IDList1) then
      CopyMemory(Result, IDList1, cb1);
    CopyMemory(PChar(Result) + cb1, IDList2, cb2);
  end;
end; 

function GetName(pidl:PItemIDList;const sr:STRRET):string;
var p:PChar;
begin
  Result:='';
  case sr.uType of
   STRRET_CSTR: Result:=sr.cStr;
   STRRET_WSTR: Result:=sr.pOleStr;
   STRRET_OFFSET: begin
                   p:=@pidl.mkid.abID[sr.uOffset-SizeOf(pidl.mkid.cb)];
                   SetString(Result,p,pidl.mkid.cb-sr.uOffset);
                  end;
   end;                  
end;

function OpenFolder(folder:IShellFolder; var Level:integer; const FF:String):Boolean;
var pidlChild:PItemIDList;
    Value:STRRET;
    Iterator:IEnumIDList;
    celtFetched:ULONG;
    child:IShellFolder;
    hr:HRESULT;
    M:IMAlloc;
    SEI:ShellExecuteInfo;
begin
 Result:=false;
 if (Level=0)or(trim(FF)='') then exit;
 hr:=folder.EnumObjects(0,SHCONTF_FOLDERS or SHCONTF_INCLUDEHIDDEN,Iterator);
 if Succeeded(hr) then
  try
   dec(Level);
   while true do
    begin
     hr:=Iterator.Next(1,pidlChild,celtFetched);
     if hr<>NOERROR then Break;
      try
       hr:=folder.GetDisplayNameOf(pidlChild,SHGDN_INFOLDER or SHGDN_INCLUDE_NONFILESYS,Value);
       if Succeeded(hr) then
        begin
         if AnsiCompareText(GetName(pidlChild,Value),FF)=0 then
          begin
           Form1.Caption:=GetName(pidlChild,Value);
           Result:=true;
           FillChar(SEI,SizeOf(SEI),#0);
           SEI.cbSize:=SizeOf(SEI);
           SEI.fMask:=SEE_MASK_IDLIST;
           SEI.lpVerb:='Open';
           SEI.nShow:=SW_NORMAL;
           SEI.lpIDList:=ConcatPIDLs(pidlItself,pidlChild);
           ShellExecuteEx(@SEI);
           SHGetMAlloc(M);
           M.Free(SEI.lpIDList);
           M:=nil;
           exit;
          end;
         SHGetMAlloc(M);
         M.Free(Value.pOleStr);
         M:=nil;
        end;
       hr:=folder.BindToObject(pidlChild,nil,IID_IShellFolder,Pointer(child));
       if Succeeded(hr) then
        try
         Result:=OpenFolder(child,Level,FF);
         if Result then exit;
        finally
         child:=nil;
        end;
      finally
       SHGetMAlloc(M);
       M.Free(pidlChild);
       M:=nil;
      end;
    end;
    inc(Level);
  finally
   Iterator:=nil;
  end;
end;


procedure GetFolderPath(nFolder:Integer);
var hr:HResult;
    M:IMAlloc;
    dISF,ISF:IShellFolder;
    r:Boolean;
    Level:integer;
begin
 CoInitializeEx(nil,COINIT_MULTITHREADED);
 if SHGetDesktopFolder(dISF)<>S_OK then exit;
 hr:=SHGetSpecialFolderLocation(0,nFolder,pidlItself);
 if Succeeded(hr)and(dISF.BindToObject(pidlItself,nil,IID_IShellFolder,Pointer(ISF))=S_OK) then
  begin
   Level:=4; //На всяк пожарный ограничиваем глубину погружения :)
   r:=OpenFolder(ISF,Level,'Microsoft Windows Network'); //Как пример открываем: Microsoft Windows Network
   if r then
    begin
     Form1.Caption:='+';
    end;
   SHGetMAlloc(M);
   M.Free(pidlItself);
   M:=nil;
   ISF:=nil;
  end;
 dISF:=nil;
 CoUninitialize;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 GetFolderPath(CSIDL_NETWORK); 
end;

end.