unit FavMenu;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Shdocvw_tlb, 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;
FMainMenu: TMainmenu;
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 MainMenu: TMainMenu read FMainMenu write FMainMenu;
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;
implementation
const
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.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.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(FMainMenu) then begin
if FMenuPos > FMainMenu.Items.Count + 1 then
FMenuPos := FMainMenu.Items.Count + 1 else
if FMenuPos <= 0 then FMenuPos := 1;
FMainMenu.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.