Shell编程---如何判断一目录是否共享？


下面函数要额外引用 ShlObj, ComObj, ActiveX 单元。
function TForm1.IfFolderShared(FullFolderPath: string): Boolean;
  //将TStrRet类型转换为字符串
  function StrRetToString(PIDL: PItemIDList; StrRet: TStrRet; Flag:string=): string;
  var
    P: PChar;
  begin
    case StrRet.uType of
      STRRET_CSTR:
        SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
      STRRET_OFFSET:
        begin
          P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
          SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
        end;
      STRRET_WSTR:
        if Assigned(StrRet.pOleStr) then
          Result := StrRet.pOleStr
        else
          Result := ;
    end;
    { This is a hack bug fix to get around Windows Shell Controls returning
      spurious "?"s in date/time detail fields }
    if (Length(Result) > 1) and (Result[1] = ?) and (Result[2] in [0..9]) then
      Result := StringReplace(Result,?,,[rfReplaceAll]);
  end;
  //返回Desktop的IShellFolder接口
  function DesktopShellFolder: IShellFolder;
  begin
    OleCheck(SHGetDesktopFolder(Result));
  end;
  //返回IDList去掉第一个ItemID后的IDList
  function NextPIDL(IDList: PItemIDList): PItemIDList;
  begin
    Result := IDList;
    Inc(PChar(Result), IDList^.mkid.cb);
  end;
  //返回IDList的长度
  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;
  //取得IDList中ItemID的个数
  function GetItemCount(IDList: PItemIDList): Integer;
  begin
    Result := 0;
    while IDList^.mkid.cb <> 0 do
    begin
      Inc(Result);
      IDList := NextPIDL(IDList);
    end;
  end;
  //创建一ItemIDList对象
  function CreatePIDL(Size: Integer): PItemIDList;
  var
    Malloc: IMalloc;
  begin
    OleCheck(SHGetMalloc(Malloc));
    Result := Malloc.Alloc(Size);
    if Assigned(Result) then
      FillChar(Result^, Size, 0);
  end;
  //返回IDList的一个内存拷贝
  function CopyPIDL(IDList: PItemIDList): PItemIDList;
  var
    Size: Integer;
  begin
    Size := GetPIDLSize(IDList);
    Result := CreatePIDL(Size);
    if Assigned(Result) then
      CopyMemory(Result, IDList, Size);
  end;
  //返回AbsoluteID最后一个ItemID，即此对象相对于父对象的ItemID
  function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList;
  begin
    Result := AbsoluteID;
    while GetItemCount(Result) > 1 do
       Result := NextPIDL(Result);
    Result := CopyPIDL(Result);
  end;
  //将IDList的最后一个ItemID去掉，即得到IDList的父对象的ItemID
  procedure StripLastID(IDList: PItemIDList);
  var
    MarkerID: PItemIDList;
  begin
    MarkerID := IDList;
    if Assigned(IDList) then
    begin
      while IDList.mkid.cb <> 0 do
      begin
        MarkerID := IDList;
        IDList := NextPIDL(IDList);
      end;
      MarkerID.mkid.cb := 0;
    end;
  end;
  //判断返回值Flag中是否包含属性Element
  function IsElement(Element, Flag: Integer): Boolean;
  begin
    Result := Element and Flag <> 0;
  end;
var
  P: Pointer;
  NumChars, Flags: LongWord;
  ID, NewPIDL, ParentPIDL: PItemIDList;
  ParentShellFolder: IShellFolder;
begin
  Result := false;
  NumChars := Length(FullFolderPath);
  P := StringToOleStr(FullFolderPath);
  //取出该目录的绝对ItemIDList
  OleCheck(DesktopShellFolder.ParseDisplayName(0, nil, P, NumChars, NewPIDL, Flags));
  if NewPIDL <> nil then
  begin
    ParentPIDL := CopyPIDL(NewPIDL);
    StripLastID(ParentPIDL);      //得到该目录上一级目录的ItemIDList
    ID := RelativeFromAbsolute(NewPIDL);  //得到该目录相对于上一级目录的ItemIDList
    //取得该目录上一级目录的IShellFolder接口
    OleCheck(DesktopShellFolder.BindToObject(ParentPIDL, nil, IID_IShellFolder,
      Pointer(ParentShellFolder)));
    if ParentShellFolder <> nil then
    begin
      Flags := SFGAO_SHARE;
      //取得该目录的属性
      OleCheck(ParentShellFolder.GetAttributesOf(1, ID, Flags));
      if IsElement(SFGAO_SHARE, Flags) then Result := true;
    end;
  end;
end;
此函数的用法：
  //传进的参数为一目录的全路经
  if IfFolderShared(C:My DocumentsWinPopup) then showmessage(shared)
  else showmessage(not shared);
  另外，有一函数 SHBindToParent 可以直接取得此目录的上一级目录的IShellFolder接口和此目录相对于上一级目录的ItemIDList，这样一来就省去了上面多个对ItemIDList进行操作的函数（这些函数从delphi6的TShellTreeView所在的单元拷贝而来），但是此函数为新加入的API，只在win2000、winxp和winme下可以使用（这么有用的函数微软怎么就没早点想出来呢）.
欢迎大家来讨论

补充：软件开发 , Delphi ,