Как проверить папку на shared?

Previous  Top  Next

    
 

 

 

Code:

{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;

 

 

©Drkb::03162

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php