对不起，应该是着段代码unit Unit1;interfaceuses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs ,ComObj,SHDocVw, StdCtrls;
const
CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;var
Form1: TForm1;implementation{$R *.dfm}procedure TForm1.Button1Click(Sender: TObject);
var
Sh: ISHellUIHelper;
begin
Sh := CreateComObject(CLSID_SHELLUIHELPER) as ISHELLUIHELPER;
sh.ImportExportFavorites(TRUE, '');end;end.但是他提示是否保存到c:\1.htm，请问如何不显示这个提示，直接备份？
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs ,ComObj,SHDocVw, StdCtrls;
const
CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;var
Form1: TForm1;implementation{$R *.dfm}procedure TForm1.Button1Click(Sender: TObject);
var
Sh: ISHellUIHelper;
begin
Sh := CreateComObject(CLSID_SHELLUIHELPER) as ISHELLUIHELPER;
sh.ImportExportFavorites(TRUE, '');end;end.但是他提示是否保存到c:\1.htm，请问如何不显示这个提示，直接备份？
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,shdocvw,activex,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;var
Form1: TForm1;implementation
uses comobj;
{$R *.DFM}procedure TForm1.Button1Click(Sender: TObject);
var sh:ishelluihelper;
begin
sh:=coshelluihelper.create;
sh.ImportExportFavorites(false,'c:\1.htm');
end;end.
不能除去提示！除非你知道shell.dll的源代码！
{ }
{ IE Favorites Component v 1.00 by Per Linds?Larsen }
{ FREEWARE }
{ }
{ Enjoy! }
{ }
{ December 27, 1999 }
{ UPDATES: http://www.euromind.com/iedelphi }
{ [email protected] }
{ }
{*******************************************************}/// How to use:/// *** Drop component on form.
/// *** Set property for Mainmenu and webbrowser.
/// *** Add "Favorites1.CreateMenu"
/// *** to form1.OnCreate;//Modifications
//==============================================================================
//21 Dec, 1999 : Added OnNavigate event
// By : [email protected] (aka cubud)
//==============================================================================
//16 Dec, 1999 : Changed TFavorites component to TAbstractFavorites
// By : [email protected] (aka cubud)
// Reason : Favorites component will no longer be TMenu dependent as I intended
// to display the favorites in a treeview.
//==============================================================================
//16 Dec, 1999 : Made TFavorites component, which is derived from TAbstractFavorites
// By : [email protected] (aka cubud)
// Reason : This component works exactly the same as the original TFavorites
//==============================================================================
{
Caption: MenuCaption
MenuPos: Position in Mainmenu
Options:
AddFavorites: Add "Add Favorites Dialog" to Favorites-menu.
OrganizeFavorites: Add "Organize Favoerites Dialog" to favorites-menu. Works only with IE5:
ImportFavorites: Add "Import Favorites dialog" to menu.
ExportFavorites: Add "Export Favorites dialog to menu. Component ignore Import/export Favorites if IE5 is not installed.
}
// This component includes two different ways to resolve internet shortcut.
// MS recommend the use of IUniformResourceLocator since the internal structure
// of URL-files may change in the future. Define USE_INTSHCUT to use this method.{$DEFINE USE_INTSHCUT}// Delete USE_INTSHCUT if you want to use inifile to resolve internet shortcut.
// Menu-icons are not available in Delphi 3.{$IFDEF VER120} // Delphi 4
{$DEFINE SHOWICON}
{$ENDIF}
{$IFDEF VER130} // Delphi 5
{$DEFINE SHOWICON}
{$ENDIF}
unit Favorites;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Inifiles, registry, StdCtrls, Menus,{$IFDEF VER130} SHDocVw,{$ELSE}SHDocVw,{$ENDIF}
Shlobj, ActiveX,{$IFDEF USE_INTSHCUT}IntShCut,{$ENDIF} ShellApi, ComCtrls;type
TFavOptions = (AddFavorites, OrganizeFavorites, ImportFavorites, ExportFavorites);
TFavoritesNavigateEvent = procedure(Sender : TObject; Url : WideString; var Allow : Boolean) of object;
TOptions = set of TFavOptions;
TAbstractFavorites = class(TComponent)
private
{$IFDEF USE_INTSHCUT}
IUrl: IUniformResourceLocator;
PersistFile: IPersistfile;
{$ENDIF}
FOnNavigate : TFavoritesNavigateEvent;
FMainItem : TObject;
FCounter : Integer;
FOptions: TOptions;
FWebbrowser: TWebbrowser;
FAbout: String;
FavFolder: string;
FAddToFavoritesCaption,
FOrganizeFavoritesCaption,
FImportFavoritesCaption,
FExportFavoritesCaption : String;
procedure FavMenuClick(sender: TObject);
procedure OrganizeFavorite(Sender: TObject);
procedure AddFavorite(Sender: TObject);
procedure FavoritesImport(Sender: TObject);
procedure FavoritesExport(Sender: TObject);
function ResolveInternetShortcut(Filename: string): string;
{ Private declarations }
protected
{ Protected declarations }
//Abstract methods which need to be overridden in order to descend
//from this class //ClearItems, should delete all items EXCEPT FMainItem
procedure ClearItems; virtual; abstract; //CreateBlankItem should be used for seperators ('-' in a menu for example);
function CreateBlankItem : TObject; virtual; //CreateItem is used to create an instance of an Item (TMenuItem for example);
function CreateItem(const ACaption, aURL: string; AEnabled: Boolean;
AOnClick: TNotifyEvent): TObject; virtual; abstract; //CreateMainItem creates the first "parent" item
function CreateMainItem(AEnabled: Boolean; AOnClick: TNotifyEvent): TObject; virtual; abstract; //This routine is needed to find the URL
function GetURL(aItem : TObject) : String; virtual; abstract; //InsertFolder should insert an folder-item
function InsertFolder(aParent : TObject; Const Folder, Caption : String) : TObject; virtual; abstract; //InsertItem should insert a child-item
function InsertItem(aParent, aChild : TObject; aIndex : Integer) : TObject; virtual; abstract; //ParentCount should return the number of children of an item (ie, TMenuItem.Count)
function ParentCount(aParent : TObject) : Integer; virtual; abstract; //Retrive puts all favorite items into the specified parent (from a folder)
procedure Retrieve(aParent : TObject; Folder: string); virtual;
//SetIcon allows you to associate an icon with an item
procedure SetIcon(aItem : TObject; aIcon : TIcon); virtual;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override; procedure CreateMenu; virtual;
procedure UpdateMenu; virtual;
published
property About: String read FAbout write FAbout;
property AddToFavoritesCaption : String read FAddToFavoritesCaption write FAddToFavoritesCaption;
property ExportFavoritesCaption : String read FExportFavoritesCaption write FExportFavoritesCaption;
property ImportFavoritesCaption : String read FImportFavoritesCaption write FImportFavoritesCaption;
property OrganizeFavoritesCaption : String read FOrganizeFavoritesCaption write FOrganizeFavoritesCaption;
property Options: TOptions read FOptions write FOptions;
property Webbrowser: TWebbrowser read FWebbrowser write FWebbrowser;
property OnNavigate : TFavoritesNavigateEvent
read FOnNavigate
write FOnNavigate;
{ Published declarations }
end; TFavorites = class(TAbstractFavorites)
private
FCaption: string;
FMainMenu: TMainmenu;
FMenuPos: Integer;
protected
procedure ClearItems; override;
function CreateBlankItem : TObject; override;
function CreateItem(const ACaption, aURL: string; AEnabled: Boolean;
AOnClick: TNotifyEvent): TObject; override;
function CreateMainItem(AEnabled: Boolean; AOnClick: TNotifyEvent): TObject; Override;
function GetURL(aItem : TObject) : String; override;
function InsertFolder(aParent : TObject; Const Folder, Caption : String) : TObject; override;
function InsertItem(aParent, aChild : TObject; aIndex : Integer) : TObject; override;
function ParentCount(aParent : TObject) : Integer; override;
procedure SetIcon(aItem : TObject; aIcon : TIcon); override;
public
constructor Create(AOwner : TComponent); override; procedure CreateMenu; override;
published
property Caption: string read FCaption write FCaption;
property MainMenu: TMainMenu read FMainMenu write FMainMenu;
property Menupos: Integer read FMenuPos write FMenuPos;
end;implementationuses
ComObj;const
CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
FMenuMaxWidth = 40;
var
p: procedure(Handle: THandle; Path: PChar); stdcall;{ TAbstractFavorites }
constructor TAbstractFavorites.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AddToFavoritesCaption := '&Add to Favorites ...';
OrganizeFavoritesCaption := '&Organize Favorites ...';
ImportFavoritesCaption := '&Import Favorites ...';
ExportFavoritesCaption := '&Export Favorites ...';
end;function IE5_Installed: Boolean;
var
Reg: TRegistry;
S: string;
begin
Reg := TRegistry.Create;
with Reg do begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software\Microsoft\Internet Explorer', False);
if ValueExists('Version') then S := ReadString('Version')
else S := '0';
CloseKey;
Free;
end;
Result := (StrToInt(S[1]) > 4);
end;procedure TAbstractFavorites.FavoritesExport(Sender: TObject);
var
Sh: ISHellUIHelper;
begin
Sh := CreateComObject(CLSID_SHELLUIHELPER) as ISHELLUIHELPER;
sh.ImportExportFavorites(FALSE, '');
updatemenu;
end;
procedure TAbstractFavorites.FavoritesImport(Sender: TObject);
var
Sh: ISHellUIHelper;
begin
Sh := CreateComObject(CLSID_SHELLUIHELPER) as ISHELLUIHELPER;
sh.ImportExportFavorites(TRUE, '');
updatemenu;
end;procedure TAbstractFavorites.FavMenuClick(sender: TObject);
var
X: OleVariant;
Url: string;
Allow : Boolean;
begin
Url := GetURL(Sender);
Allow := (Url <> '');
if Assigned(FOnNavigate) then
FOnNavigate(Self, Url, Allow);
if Assigned(FWebbrowser) then begin
if Allow then FWebbrowser.Navigate(Url, x, x, x, x);
end else
Showmessage('No Webbrowser connected to Favorites-menu');
end;procedure TAbstractFavorites.OrganizeFavorite(Sender: Tobject);
var
H: HWnd;
begin
H := LoadLibrary(PChar('shdocvw.dll'));
if H <> 0 then begin
p := GetProcAddress(H, PChar('DoOrganizeFavDlg'));
if Assigned(p) then p(Application.Handle, PChar(FavFolder));
end;
FreeLibrary(h);
UpdateMenu;
end;procedure TAbstractFavorites.AddFavorite(Sender: TObject);
var
ShellUIHelper: ISHellUIHelper;
url, title: Olevariant;
begin
if Assigned(FWebbrowser) then begin
Title := FWebbrowser.LocationName;
Url := FWebbrowser.LocationUrl;
if Url <> '' then begin
ShellUIHelper := CreateComObject(CLSID_SHELLUIHELPER) as IShellUIHelper;
ShellUIHelper.AddFavorite(url, title);
UpdateMenu;
end;
end else
Showmessage('No Webbrowser connected to Favorites-menu');
end;{$IFDEF USE_INTSHCUT}
function TAbstractFavorites.ResolveInternetShortcut(Filename: string): String;
Var
FName: array[0..MAX_PATH] of WideChar;
p : Pchar;
begin
IUrl := CreateComObject(CLSID_InternetShortCut) as IUniformResourceLocator;
Persistfile := IUrl as IPersistFile;
StringToWideChar(FileName, FName, MAX_PATH);
PersistFile.Load(Fname, STGM_READ);
IUrl.geturl(@P);
Result:=P;
end;
{$ELSE}
function TAbstractFavorites.ResolveInternetShortcut(Filename: string): String;
var
ini : TiniFile;
begin
result := '';
ini := TIniFile.create(fileName);
try
result := ini.ReadString('InternetShortcut', 'URL', '');
finally
ini.free;
end;
end;
{$ENDIF}///*** Not implemented
{
function ResolveLink(FileName: string): string;
var
Path: array[0..MAX_PATH] of WideChar;
Url: array[0..MAX_PATH] of char;
ShellLink: IShellLink;
Persistfile: IPersistFile;
pfd: TWin32FindData;begin
ShellLink := CreateComObject(CLSID_ShellLink) as IShellLink;
PersistFile := ShellLink as IPersistFile;
StringToWideChar(FileName, Path, MAX_PATH);
PersistFile.Load(Path, STGM_READ);
FillChar(Url,SizeOf(Url),#0);
ShellLink.GetPath(Url, MAX_PATH, pfd, SLGP_UNCPRIORITY);
Result := StrPas(Url);
end;
function ResolveChannel(Folder: IShellFolder; pidl: PITEMIDLIST; lpszURL: string): HRESULT;
var
Desktop: IShellFolder;
ShellLink: IShellLink;
pShellLink: Pointer absolute ShellLink;
pidlChannel: PItemIDLIST;
StrRet: TStrRet;
begin
lpszURL := '';
Folder.GetUIObjectOf(0, 1, pidl, IID_IShellLinkW, nil, pShellLink);
ShellLink.GetIDList(pidlChannel);
SHGetDesktopFolder(Desktop);
Desktop.GetDisplayNameOf(pidlChannel, 0, strret);
SetString(lpszURL, StrRet.cStr, lStrLen(StrRet.cStr));
end;} (*
procedure TAbstractFavorites.NewRetrieve(Folder : String);
var
AdjustedName: string;
I: Integer;
Counter: Integer;
SearchRec: TSearchRec;
MenuItem: TMenuItem;
Stringlist: TStringList;
{$IFDEF SHOWICON}
FileInfo: SHFileInfo;
{$ENDIF}
procedure GetIcon;
var
Icon: TIcon;
begin
{$IFDEF SHOWICON}
Icon := TIcon.Create;
SHGetFileInfo(Pchar(Folder + Stringlist[I]), 1, FileInfo, SizeOf(FileInfo), SHGFI_ICONLOCATION or SHGFI_ICON);
if pos('.ico', fileinfo.szDisplayname) > 0 then
Icon.LoadFromFile(Fileinfo.szDisplayName) else
begin
Icon.handle := Fileinfo.HIcon;
end;
MenuItem.Bitmap.Height := Icon.Height;
MenuItem.Bitmap.Width := Icon.Width;
MenuItem.Bitmap.Canvas.Draw(0, 0, Icon);
Icon.Free;
{$ENDIF}
end;begin
Counter := 0;
StringList := TStringlist.Create;
StringList.Sorted := True;
if Folder[Length(Folder)] <> '\' then Folder := Folder + '\';
if FindFirst(Folder + '*.*', faDirectory, SearchRec) = 0
then repeat
if (SearchRec.Attr and faDirectory <> 0)
and (SearchRec.Name[1] <> '.') then StringList.Add(SearchRec.Name);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
for I := 0 to StringList.Count - 1 do begin
MenuItem := NewItem(StringList[I], 0, False, True, nil, 0, '');
{$IFDEF SHOWICON}
GetIcon;
{$ENDIF}
Menu.Insert(menu.Count - Counter, MenuItem);
Retrieve(MenuItem, Folder + StringList[I]);
end;
Stringlist.Clear;
if FindFirst(Folder + '*.url', faAnyFile, SearchRec) = 0
then repeat
if SearchRec.Attr and (faDirectory + faVolumeID) = 0 then
StringList.Add(SearchRec.Name);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
for I := 0 to StringList.Count - 1 do begin
AdjustedName := Copy(StringList[I], 1, Length(StringList[I]) - 4);
if Length(AdjustedName) > FMenuMaxWidth then
AdjustedName := Copy(AdjustedName, 1, FMenuMaxWidth) + '...';
MenuItem := NewItem(AdjustedName, 0, False, True, FavMenuClick, 0, '');
{$IFDEF SHOWICON}
GetIcon;
{$ENDIF}
MenuItem.Hint := ResolveInternetShortCut(Folder + StringList[I]);
menu.Insert(menu.Count - Counter, MenuItem);
end;
if menu.Count = 0
then menu.Add(NewItem('( Empty )', 0, False, False, nil, 0, ''));
StringList.Free;
end; *)procedure TAbstractFavorites.Retrieve(aParent : TObject; Folder: string);
var
AdjustedName: string;
I: Integer;
SearchRec: TSearchRec;
AddedItem : TObject;
Stringlist: TStringList;
URL : String;
{$IFDEF SHOWICON}
FileInfo: SHFileInfo;
{$ENDIF}
procedure GetIcon;
var
Icon: TIcon;
begin
{$IFDEF SHOWICON}
Icon := TIcon.Create;
SHGetFileInfo(Pchar(Folder + Stringlist[I]), 1, FileInfo, SizeOf(FileInfo), SHGFI_ICONLOCATION or SHGFI_ICON);
if pos('.ico', fileinfo.szDisplayname) > 0 then
Icon.LoadFromFile(Fileinfo.szDisplayName) else
begin
Icon.handle := Fileinfo.HIcon;
end;
SetIcon(AddedItem, Icon);
Icon.Free;
{$ENDIF}
end;begin
FCounter := 0;
StringList := TStringlist.Create;
StringList.Sorted := True;
if Folder[Length(Folder)] <> '\' then Folder := Folder + '\';
if FindFirst(Folder + '*.*', faDirectory, SearchRec) = 0
then repeat
if (SearchRec.Attr and faDirectory <> 0)
and (SearchRec.Name[1] <> '.') then StringList.Add(SearchRec.Name);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
for I := 0 to StringList.Count - 1 do begin
AddedItem := InsertFolder(aParent ,Folder + StringList[I], StringList[I]);
GetIcon;
Retrieve(AddedItem, Folder + StringList[I]);
end; Stringlist.Clear;
if FindFirst(Folder + '*.url', faAnyFile, SearchRec) = 0
then repeat
if SearchRec.Attr and (faDirectory + faVolumeID) = 0 then
StringList.Add(SearchRec.Name);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
for I := 0 to StringList.Count - 1 do begin
AdjustedName := Copy(StringList[I], 1, Length(StringList[I]) - 4);
if Length(AdjustedName) > FMenuMaxWidth then
AdjustedName := Copy(AdjustedName, 1, FMenuMaxWidth) + '...'; URL := ResolveInternetShortCut(Folder + StringList[I]);
AddedItem := CreateItem(AdjustedName, URL, True, FavMenuClick);
InsertItem(aParent, AddedItem, ParentCount(aParent) - FCounter);
GetIcon;
end;
if ParentCount(aParent) = 0 then
InsertItem(aParent, CreateItem('( Empty )', '', False, Nil), 0);
StringList.Free;
end;procedure TAbstractFavorites.CreateMenu;
var
AddedItem : TObject;
SFolder: pItemIDList;
SpecialPath: array[0..MAX_PATH] of Char;
URL : String;
Save_Cursor: TCursor;
begin
Save_Cursor := Screen.Cursor;
Screen.Cursor := crHourglass;
try
SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, SFolder);
SHGetPathFromIDList(SFolder, SpecialPath);
Favfolder := StrPas(SpecialPath);
FMainItem := CreateMainItem(True, nil);
if AddFavorites in FOptions then begin
AddedItem := CreateItem(AddToFavoritesCaption, '', True, AddFavorite);
InsertItem(FMainItem, AddedItem, ParentCount(FMainItem));
end;
if OrganizeFavorites in FOptions then begin
AddedItem := CreateItem(OrganizeFavoritesCaption, '', True, OrganizeFavorite);
InsertItem(FMainItem, AddedItem, ParentCount(FMainItem));
end;
if ParentCount(FMainItem) > 0 then begin
AddedItem := CreateBlankItem;
if Assigned(AddedItem) then InsertItem(FMainItem, CreateBlankItem, ParentCount(FMainItem));
end; if IE5_Installed then begin
if ImportFavorites in FOptions then begin
AddedItem := CreateItem(ImportFavoritesCaption, '', True, FavoritesImport);
InsertItem(FMainItem, AddedItem, ParentCount(FMainItem));
end; if ExportFavorites in FOptions then begin
AddedItem := CreateItem(ExportFavoritesCaption, '', True, FavoritesExport);
InsertItem(FMainItem, AddedItem, ParentCount(FMainItem));
end; if (ImportFavorites in FOptions) or (ExportFavorites in FOptions) then begin
AddedItem := CreateBlankItem;
if Assigned(AddedItem) then InsertItem(FMainItem, CreateBlankItem, ParentCount(FMainItem));
end;
end;
Retrieve(FMainItem, FavFolder);
finally
Screen.Cursor := Save_Cursor;
end;
end;procedure TAbstractFavorites.UpdateMenu;
var
Save_Cursor: TCursor;
begin
Save_Cursor := Screen.Cursor;
Screen.Cursor := crHourglass;
ClearItems;
Retrieve(FMainItem, FavFolder);
Screen.Cursor := Save_Cursor;
end;procedure TAbstractFavorites.SetIcon(aItem: TObject; aIcon: TIcon);
begin
//Do nothing for unsupported types
end;function TAbstractFavorites.CreateBlankItem: TObject;
begin
Result := nil;
end;{ TFavorites }function TFavorites.InsertFolder(aParent : TObject; const Folder, Caption: String): TObject;
begin
Result := Menus.NewItem(Caption, 0, False, True, nil, 0, '');
TMenuItem(aParent).Insert(ParentCount(aParent) - FCounter, TMenuItem(Result));
end;constructor TFavorites.Create(AOwner: TComponent);
begin
inherited;
FCaption := 'Favorites';
FMenuPos := 1;
end;
function TFavorites.CreateItem(const ACaption, aURL: string; AEnabled: Boolean;
AOnClick: TNotifyEvent): TObject;
begin
Result := Menus.NewItem(aCaption, 0, False, aEnabled, aOnClick, 0, '');
TMenuItem(Result).Hint := aURL;
end;function TFavorites.ParentCount(aParent: TObject): Integer;
begin
Result := TMenuItem(aParent).Count;
end;
function TFavorites.InsertItem(aParent, aChild: TObject;
aIndex: Integer): TObject;
begin
Result := aChild;
TMenuItem(aParent).Insert(aIndex, TMenuItem(aChild));
end;procedure TFavorites.CreateMenu;
begin
inherited;
if Fmenupos > 0 then Dec(FMenuPos);
if FmenuPos > FMainmenu.Items.count then
FMenuPos := FMainMenu.Items.Count;
FMainmenu.Items.Insert(FMenupos, TMenuItem(FMainItem));
end;function TFavorites.CreateMainItem(AEnabled: Boolean; AOnClick: TNotifyEvent): TObject;
begin
Result := CreateItem(FCaption, '', True, nil);
end;function TFavorites.CreateBlankItem: TObject;
begin
Result := CreateItem('-','',True,nil);
end;procedure TFavorites.ClearItems;
begin
with TMenuItem(FMainItem) do
while Count > 0 do
Items[Count-1].Free;
end;procedure TFavorites.SetIcon(aItem: TObject; aIcon: TIcon);
begin
with TMenuItem(aItem) do begin
Bitmap.Height := aIcon.Height;
Bitmap.Width := aIcon.Width;
Bitmap.Canvas.Draw(0, 0, aIcon);
end;
end;function TFavorites.GetURL(aItem: TObject): String;
begin
Result := TMenuItem(aItem).Hint;
end;end.
//***********************************************************
// FavoritesMenu ver 1.01 (July 27, 2000) *
// *
// For Delphi 5 *
// Freeware Component *
// by *
// Per Linds?Larsen *
// [email protected] *
// *
// *
// Contributions: *
// Pete Morris ([email protected]) *
// Rob Young ([email protected]) *
// *
// *
// Updated versions: *
// *
// http://www.euromind.com/iedelphi *
// http://www.intelligo.net/iedelphi *
//***********************************************************unit FavMenu;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
SHDocVw, Registry, menus, IEUtils, ShellApi, Shlobj, Imglist, ActiveX;type
PItem = ^TItem;
TItem = record
ID, FullID: PItemIDList;
Folder: Boolean;
Created: Boolean;
end;type TOnUrlSelectedEvent = procedure(Sender: TObject; Url: string) of object; TLocalization = class(TPersistent)
private
FAddFavorites,
FOrganizeFavorites,
FImportFavorites,
FExportFavorites: string;
published
property AddFavorites: string read FaddFavorites write FAddFavorites;
property OrganizeFavorites: string read FOrganizeFavorites write FOrganizeFavorites;
property ImportFavorites: string read FImportFavorites write FImportFavorites;
property ExportFavorites: string read FExportFavorites write FExportFavorites;
end;
TResolveUrl = (IntShCut, IniFile);
TFavOptions = (AddFavorites, OrganizeFavorites, ImportFavorites, ExportFavorites); TOptions = set of TFavOptions; TFavoritesMenu = class(TComponent)
private
{ Private declarations }
Images: TImageList;
Counter: Integer;
List: TList;
Item: PItem;
FavoritesMenu: TMenuItem;
FavoritesPidl: PItemIDList;
Desktop: IShellFolder;
FCaption: string;
FResolveUrl: TResolveUrl;
FOptions: TOptions;
FMenuPos: Integer;
FChannels : Boolean;
FMaxWidth: Integer;
Fpopupmenu: Tpopupmenu;
FLocalization: TLocalization;
FWebbrowser: TWebbrowser;
FOnUrlSelected: TOnUrlSelectedEvent;
procedure OrganizeFavorite(Sender: TObject);
procedure AddFavorite(Sender: TObject);
procedure FavoritesImport(Sender: TObject);
procedure FavoritesExport(Sender: TObject);
protected
{ Protected declarations }
procedure BuildOptionsMenu;
procedure AddMenu(Menu: TMenuItem; FullID: PItemIDList);
procedure AddDummy(menu: TMenuItem);
procedure MenuClick(Sender: TObject);
procedure AddEmpty(menu: TMenuItem);
procedure DestroyList;
public
{ Public declarations }
procedure CreateMenu;
procedure ReBuildMenu;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Webbrowser: TWebbrowser read FWebbrowser write FWebbrowser;
property Localization: TLocalization read FLocalization write FLocalization;
property Options: TOptions read FOptions write FOptions;
property popupmenu: TpopupMenu read FpopupMenu write FpopupMenu;
property Menupos: Integer read FMenuPos write FMenuPos;
property MaxWidth: Integer read FMaxWidth write FMaxWidth;
property Caption: string read FCaption write FCaption;
property ResolveUrl: TResolveUrl read FResolveUrl write FResolveUrl;
property Channels: Boolean read FChannels write FChannels;
property OnURLSelected: TOnURLSelectedEvent read FOnURLSelected write FOnURLSelected;
end;procedure Register;implementationconst
CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';var
ChannelShortcut, InternetShortcut: string;
Folder: IShellFolder;
p: procedure(Handle: THandle; Path: PChar); stdcall;
function SortFunc(Item1, Item2: Pointer): Integer;
begin
Result := SmallInt(Folder.CompareIDs(0, PItem(Item1).ID, PItem(Item2).ID));
end;procedure TFavoritesMenu.FavoritesExport(Sender: TObject);
var
Sh: ISHellUIHelper;
begin
CoCreateInstance(CLSID_SHELLUIHELPER, nil, CLSCTX_INPROC_SERVER,
IID_IShellUIHelper, Sh);
sh.ImportExportFavorites(FALSE, '');
Rebuildmenu;
end;procedure TFavoritesMenu.FavoritesImport(Sender: TObject);
var
Sh: ISHellUIHelper;
begin
CoCreateInstance(CLSID_SHELLUIHELPER, nil, CLSCTX_INPROC_SERVER,
IID_IShellUIHelper, Sh);
sh.ImportExportFavorites(TRUE, '');
Rebuildmenu;
end;procedure TFavoritesMenu.OrganizeFavorite(Sender: Tobject);
var
SpecialPath: array[0..MAX_PATH] of Char;
H: HWnd;
begin
H := LoadLibrary(PChar('shdocvw.dll'));
if H <> 0 then begin
p := GetProcAddress(H, PChar('DoOrganizeFavDlg'));
if Assigned(p) then
begin
SHGetPathFromIDList(FavoritesPidl, SpecialPath);
p(Application.Handle, SpecialPath);
end;
end;
FreeLibrary(H);
RebuildMenu;
end;procedure TFavoritesMenu.AddFavorite(Sender: TObject);
var
ShellUIHelper: ISHellUIHelper;
Url, Title: Olevariant;
begin
if Assigned(FWebbrowser) then begin
Title := FWebbrowser.LocationName;
Url := FWebbrowser.LocationUrl;
if Url <> '' then begin
CoCreateInstance(CLSID_SHELLUIHELPER, nil, CLSCTX_INPROC_SERVER,
IID_IShellUIHelper, ShellUIHelper);
ShellUIHelper.AddFavorite(Url, Title);
RebuildMenu;
end
else Showmessage('No URL selected.');
end else
Showmessage('No Webbrowser connected to Favorites-menu.');
end;procedure TFavoritesMenu.AddDummy(menu: TMenuItem);
var
Dummy: TMenuItem;
begin
Dummy := TMenuItem.Create(self);
Dummy.Visible := False;
Menu.add(Dummy);
end;procedure TFavoritesMenu.AddEmpty(menu: TMenuItem);
var
Empty: TMenuItem;
begin
Empty := TMenuItem.Create(self);
Empty.Caption := ' (Empty) ';
Empty.Enabled := False;
Menu.add(Empty);
end;procedure TFavoritesMenu.AddMenu(Menu: TMenuItem; FullID: PItemIDList);
var
MenuItem: TMenuItem;
EnumList: IEnumIDList;
ID: PItemIDList;
NumIDs: LongWord;
TempList: TList;
I: Integer;
begin
TempList := TList.Create;
Desktop.BindToObject(FullID, nil, IID_IShellFolder, Pointer(Folder));
Folder.EnumObjects(Application.Handle, SHCONTF_FOLDERS or SHCONTF_NONFOLDERS,
EnumList);
while EnumList.Next(1, ID, NumIDs) = S_OK do
begin
If not Channels and IsChannel(ChannelShortcut, Folder, ID) then continue;
Item := New(PItem);
Item.ID := CopyPidl(ID);
Item.FullID := ConcatPIDLs(FullID, ID);
Item.Folder := IsFolderEx(ChannelShortcut, Folder, ID);
Item.Created := False;
TempList.Add(Item);
end;
DisposePidl(ID);
if TempList.Count = 0 then begin
AddEmpty(Menu);
TempList.Free;
exit;
end;
TempList.Sort(SortFunc);
for I := 0 to TempList.Count - 1 do begin
List.Add(PItem(Templist[I]));
MenuItem := TMenuItem.Create(Menu);
MenuItem.SubmenuImages := Images;
MenuItem.OnClick := MenuClick;
MenuItem.Tag := Counter;
MenuItem.Caption := GetDisplayName(Folder, PItem(TempList[I])^.ID);
if Length(MenuItem.Caption) > FMaxWidth then
MenuItem.Caption := Copy(MenuItem.Caption, 1, FMaxWidth) + '...';
MenuItem.ImageIndex := GetImageIndex(PItem(TempList[I])^.FullID);
Menu.Add(MenuItem);
Inc(Counter);
if PItem(TempList[I])^.Folder then AddDummy(MenuItem);
end;
TempList.Free;
end;procedure TFavoritesMenu.MenuClick(Sender: TObject);
var
Folder: IShellFOlder;
FileInfo: TSHFileInfo;
ID: PItemIDList;
X: OleVariant;
Url: string;
Handle: THandle;
begin
if PItem(list[(Sender as TMenuItem).Tag])^.folder
then begin
if
not PItem(list[(Sender as TMenuItem).Tag]).Created then
begin
AddMenu(Sender as TMenuItem,
PItem(list[(Sender as TMenuItem).Tag])^.FULLID);
PItem(list[(Sender as TMenuItem).Tag]).Created := TRUE;
end;
end else
begin
id := CopyPidl(PItem(list[(Sender as TMenuItem).Tag])^.FULLID);
StripLastID(ID);
Desktop.BindToObject(ID, nil, IID_IShellFolder, Pointer(Folder));
SHGetFileInfo(PChar(PItem(list[(Sender as TMenuItem).Tag])^.ID), 0,
FileInfo, SizeOf(TSHFileInfo),
SHGFI_PIDL or SHGFI_TYPENAME or SHGFI_ATTRIBUTES);
if fileinfo.szTypeName = ChannelShortcut then
ResolveChannel(Folder, PItem(list[(Sender as TMenuItem).Tag])^.ID, Url)
else
if fileinfo.szTypeName = InternetShortcut then
begin
if FResolveUrl = IntshCut then
Url := ResolveUrlIntShCut(getfilename(Folder,
PItem(list[(Sender as TMenuItem).Tag])^.ID))
else
Url := ResolveUrlIni(getfilename(Folder,
PItem(list[(Sender as TMenuItem).Tag])^.ID));
end else
Url := Resolvelink(getfilename(Folder,
PItem(list[(Sender as TMenuItem).Tag])^.ID));
DisposePidl(ID);
if Assigned(FOnUrlSelected) then
FOnUrlSelected(Sender, Url) else
shellExecute(Application.handle,nil,pchar(url),nil,nil,sw_shownormal);;
end;
end;procedure TFavoritesMenu.BuildOptionsMenu;
begin
if AddFavorites in FOptions then
Favoritesmenu.Add(NewItem(FLocalization.FAddFavorites, 0,
False, True, addfavorite, 0, ''));
if OrganizeFavorites in FOptions then
Favoritesmenu.Add(NewItem(FLocalization.FOrganizeFavorites, 0,
False, True, organizefavorite, 0, ''));
if FavoritesMenu.Count > 0 then
Favoritesmenu.Add(NewItem('-', 0, False, True, nil, 0, ''));
if IE5_Installed then
begin
if ImportFavorites in FOptions then
Favoritesmenu.Add(NewItem(FLocalization.FImportFavorites, 0,
False, True, FavoritesImport, 0, ''));
if ExportFavorites in FOptions then
Favoritesmenu.Add(NewItem(FLocalization.FExportFavorites, 0,
False, True, FavoritesExport, 0, ''));
if (ImportFavorites in FOptions) or (ExportFavorites in FOptions) then
Favoritesmenu.Add(NewItem('-', 0, False, True, nil, 0, ''));
end;
end;procedure TFavoritesMenu.CreateMenu;
var
FileInfo: TSHFileInfo;
begin
Counter := 0;
List := TList.Create;
Images := TImagelist.Create(self);
Images.ShareImages := True;
Images.DrawingStyle := dsTransparent;
Images.Handle := SHGetFileInfo(Pchar(FavoritesPidl), 0, FileInfo,
SizeOf(FileInfo), SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
FavoritesMenu := TMenuitem.Create(self);
FavoritesMenu.SubmenuImages := Images;
FavoritesMenu.Caption := FCaption;
if Assigned(fpopupmenu) then begin
if FMenuPos > fpopupmenu.Items.Count + 1 then
FMenuPos := fpopupmenu.Items.Count + 1 else
if FMenuPos <= 0 then FMenuPos := 1;
fpopupmenu.Items.Insert(FMenuPos - 1, FavoritesMenu);
end;
BuildOptionsMenu;
AddMenu(FavoritesMenu, FavoritesPidl);
end;procedure TFavoritesMenu.ReBuildMenu;
begin
DestroyList;
List := TList.Create;
FavoritesMenu.Clear;
BuildOptionsMenu;
AddMenu(FavoritesMenu, FavoritesPidl);
end;constructor TFavoritesMenu.Create;
begin
FLocalization := TLocalization.Create;
FLocalization.FAddFavorites := 'Add to Favorites';
FLocalization.FOrganizeFavorites := 'Organize Favorites';
FLocalization.FImportFavorites := 'Import Favorites';
FLocalization.FExportFavorites := 'Export Favorites';
SHGetDesktopFolder(Desktop);
SHGetSpecialFolderLocation(Application.Handle, CSIDL_FAVORITES, FavoritesPIDL);
FCaption := ExtractfileName(GetFileName(Desktop, FavoritesPidl));
with TRegistry.Create do
begin
RootKey := HKEY_CLASSES_ROOT;
if OpenKey('ChannelShortcut', FALSE)
then ChannelShortCut := ReadString('') else ChannelShortcut := 'Channel Shortcut';
Closekey;
if OpenKey('InternetShortcut', FALSE)
then InternetShortCut := ReadString('') else InternetShortcut := 'Internet Shortcut';
Closekey;
Free;
end;
FMaxWidth:=50;
FMenuPos := 1;
FOptions := [addFavorites, organizeFavorites];
inherited;
end;procedure TFavoritesMenu.DestroyList;
var
I: Integer;
begin
if list <> nil then
begin
for I := 0 to List.Count - 1 do
begin
DisposePIDL(PItem(List[I]).ID);
DisposePIDL(PItem(List[i]).FULLID);
Dispose(PItem(List[i]));
end;
Counter := 0;
List.Free;
end;
end;destructor TFavoritesMenu.Destroy;
begin
FLocalization.Free;
DestroyList;
inherited;
end;procedure Register;
begin
RegisterComponents('Samples', [TFavoritesMenu]);
end;end.