Tips (1541)

Tip Rating (20):

{Following code needs to use ShlObj, ComObj, ActiveX Units}

function TForm1.IfFolderShared(FullFolderPath: string): Boolean;

  //Convert TStrRet to string
  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;

  //Get Desktop's IShellFolder interface
  function DesktopShellFolder: IShellFolder;
  begin
    OleCheck(SHGetDesktopFolder(Result));
  end;

  //delete the first ID from IDList
  function NextPIDL(IDList: PItemIDList): PItemIDList;
  begin
    Result := IDList;
    Inc(PChar(Result), IDList^.mkid.cb);
  end;

  //get the length of 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;

  //get ID count from IDList
  function GetItemCount(IDList: PItemIDList): Integer;
  begin
    Result := 0;
    while IDList^.mkid.cb <> 0 do
    begin
      Inc(Result);
      IDList := NextPIDL(IDList);
    end;
  end;

  //create an ItemIDList object
  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;

  function CopyPIDL(IDList: PItemIDList): PItemIDList;
  var
    Size: Integer;
  begin
    Size   := GetPIDLSize(IDList);
    Result := CreatePIDL(Size);
    if Assigned(Result) then
      CopyMemory(Result, IDList, Size);
  end;

  //get the last ItemID from AbsoluteID
  function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList;
  begin
    Result := AbsoluteID;
    while GetItemCount(Result) > 1 do
      Result := NextPIDL(Result);
    Result := CopyPIDL(Result);
  end;

  //remove the last ID from IDList
  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;

  //if Flag include 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);
  //get the folder's full ItemIDList
  OleCheck(DesktopShellFolder.ParseDisplayName(0, nil, P, NumChars, NewPIDL, Flags));
  if NewPIDL <> nil then
  begin
    ParentPIDL := CopyPIDL(NewPIDL);
    StripLastID(ParentPIDL);      //get the folder's parent object's ItemIDList

    ID := RelativeFromAbsolute(NewPIDL);  //get the folder's relative ItemIDList

    //get the folder's parent object's IShellFolder interface
    OleCheck(DesktopShellFolder.BindToObject(ParentPIDL, nil, IID_IShellFolder,
      Pointer(ParentShellFolder)));

    if ParentShellFolder <> nil then
    begin
      Flags := SFGAO_SHARE;
      //get the folder's attributes
      OleCheck(ParentShellFolder.GetAttributesOf(1, ID, Flags));
      if IsElement(SFGAO_SHARE, Flags) then Result := True;
    end;
  end;
end;

{How to use the function?
 The parameter in is the full path of a folder}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if IfFolderShared('C:\My Documents\WinPopup') then ShowMessage('shared')
  else
    ShowMessage('not shared');
end;