Delphi TWebBrowser[3] IE收藏夹操作

Delphi TWebBrowser[3] IE收藏夹操作 

1、添加到收藏夹

?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

const     CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}'; procedure AddFavorite(Webbrowser:TWebBrowser); var ShellUIHelper: ISHellUIHelper; url, title: Olevariant; begin   Title := Webbrowser.LocationName;   Url :=  Webbrowser.LocationUrl;    if Url <> '' then     begin       ShellUIHelper := CreateComObject(CLSID_SHELLUIHELPER) as IShellUIHelper;       ShellUIHelper.AddFavorite(url, title);     end; end;

　

2、整理收藏夹

?

1 2 3 4 5 6 7 8 9 10 11 12 13

procedure OrganizeFavorite(); var  H: HWnd;  p:procedure(Handle: THandle; Path: PChar); stdcall; begin   H := LoadLibrary(PChar('shdocvw.dll'));   if H <> 0 then    begin     p := GetProcAddress(H, PChar('DoOrganizeFavDlg'));    if Assigned(p) then p(Application.Handle, PChar(''));    end;    FreeLibrary(h); end;

　　

3、显示收藏夹列表

?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47

uses     ShlObj, ActiveX;   function GetIEFavourites(const favpath: string): TStrings;       {获取IE收藏夹} var   searchrec: TSearchRec;   str: TStrings;   path, dir, FileName: string;   Buffer: array[0..2047] of Char;   found: Integer; begin   str := TStringList.Create; // Get all file names in the favourites path   path := FavPath + '\*.url';   dir := ExtractFilepath(path);   found := FindFirst(path, faAnyFile, searchrec);   while found = 0 do   begin // Get now URLs from files in variable files     Setstring(FileName, Buffer, GetPrivateProfilestring('InternetShortcut', PChar('URL'), nil, Buffer, SizeOf(Buffer), PChar(dir + searchrec.Name)));     str.Add(FileName);     found := FindNext(searchrec);   end; // find Subfolders   found := FindFirst(dir + '\*.*', faAnyFile, searchrec);   while found = 0 do   begin     if ((searchrec.Attr and faDirectory) > 0) and (searchrec.Name[1] <> '.') then       str.Addstrings(GetIEFavourites(dir + '\' + searchrec.Name));     found := FindNext(searchrec);   end;   FindClose(searchrec);   Result := str; end;   procedure FreePidl(pidl: PItemIDList); var   allocator: IMalloc; begin   if Succeeded(SHGetMalloc(allocator)) then   begin     allocator.Free(pidl); {$IFDEF VER100}     allocator.Release; {$ENDIF}   end; end;

调用示例：

?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

procedure TForm1.BitBtn1Click(Sender: TObject); var   pidl: PItemIDList;   FavPath: array[0..MAX_PATH] of Char; begin   ListBox1.Visible:=not ListBox1.Visible;   if Succeeded(ShGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl)) then   begin     if ShGetPathfromIDList(pidl, FavPath) then       ListBox1.Items := GetIEFavourites(StrPas(FavPath)); // The calling application is responsible for freeing the PItemIDList-pointer // with the Shell's IMalloc interface     FreePIDL(pidl);   end; end;

　　

4、获取收藏夹目录

?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17

//取特殊文件夹目录 function   GetSpecialFolderDir(const   folderid:   integer):   string; var     pidl                             :   pItemIDList;     buffer                         :   array[0..255]   of   char; begin     SHGetSpecialFolderLocation(Application.Handle,   folderid,   pidl);     SHGetPathFromIDList(pidl,   buffer);         //转换成文件系统的路径     result   :=   strpas(buffer); end;   //取收藏夹目录   function   GetFavPath:   string; begin     result   :=   GetSpecialFolderDir(CSIDL_FAVORITES); end;

或者：

?

1 2 3 4 5 6

var    buffer:array[0..255] of char; begin   SHGetSpecialFolderPath(Application.Handle,buffer,CSIDL_FAVORITES,True);   ShowMessage(buffer); end;

　　

　　

　

创建时间：2020.11.19　　更新时间：