Проверить, расшарена ли папка

Delphi , Файловая система , Директории

Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

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

Программный код на Delphi проверяет, является ли папка общей или нет, используя Windows Shell API. Вот шаг за шагом, как работает код:

1. Функция IfFolderShared принимает полный путь к папке в качестве входных данных.
2. Она использует функцию SHGetDesktopFolder для получения интерфейса к десктопному шеллу.
3. Она парсит путь папки в ItemIDList с помощью метода ParseDisplayName.
4. Она получает список идентификаторов родительского объекта, удалив последний элемент из списка идентификаторов.
5. Она получает относительный список идентификаторов, удалив родительский элемент из списка идентификаторов.
6. Она привязывается к родительскому шеллу и получает его атрибуты с помощью метода GetAttributesOf.
7. Она проверяет, установлен ли атрибут SFGAO_SHARE, который указывает, является ли папка общей или нет.

Функция возвращает булевое значение, указывающее, является ли папка общей или нет.

В примере кода есть форма с кнопкой, которая вызывает функцию IfFolderShared с путём 'C:\My Documents\WinPopup'. Если папка общая, то выводится сообщение об ошибке "shared", иначе - "not shared".

Обратите внимание, что код использует Windows Shell API (ShlObj) и COM-объекты (ComObj), которые могут требовать дополнительной настройки или зависимостей в вашем проекте Delphi. Кроме того, код предполагает, что система имеет доступ к пути папки.

Некоторые потенциальные проблемы с этим кодом:

• Он не обрабатывает ошибки должным образом; например, он использует OleCheck для проверки успешности вызова функции, но не возвращает значение ошибки или сообщение.
• Он предполагает, что папка существует и может быть парсирована в список идентификаторов. Если папка отсутствует или имеет неправильный путь, код может выйти из строя или производить неправильные результаты.
• Код использует StringToOleStr для конвертации строки в строку Unicode, но не проверяет, была ли конверсия успешной.

В целом, этот код предоставляет основное пример использования Windows Shell API для проверки, является ли папка общей или нет. Однако он может требовать дополнительной обработки ошибок и тестирования для обеспечения его надежности в различных сценариях.

Проверка наличия доступа к папке по сети: функция проверяет, является ли указанная папка общедоступной.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Директории ::