下面函数要额外引用 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 Documents\WinPopup'''') then showmessage(''''shared'''') else showmessage(''''not shared'''');
另外,有一函数 SHBindToParent 可以直接取得此目录的上一级目录的IShellFolder接口和此目录相对于上一级目录的ItemIDList,这样一来就省去了上面多个对ItemIDList进行操作的函数(这些函数从delphi6的TShellTreeView所在的单元拷贝而来),但是此函数为新加入的API,只在win2000、winxp和winme下可以使用(这么有用的函数微软怎么就没早点想出来呢).
欢迎大家来讨论
没有相关教程
|