IE历史记录菜单控件

***************
Drop the component and a mainmenu-component on a form. Set Historymenu's Mainmenu-property to your mainmenu and add a single line of code:
procedure TForm1.FormCreate(Sender: TObject);
begin
HistoryMenu1.CreateMenu;
end;
　
Properties:
Caption
Menutitle to appear in mainmenu. (Default: Localized).
　
MenuPos
Where to place the History-menu in mainmenu.
　
MainMenu
Your mainmenu (ex. MainMenu1)
Events:
OnUrlSelected(Sender : TObject; Url: String);
Trigger when a Url is selcted in the History-menu.
Methods:
ReBuildMenu
Call this function to rebuild the menu.
Feel free to contribute your enhancements and/or bug fixes...
NB: Ver 1.00 of the history-menu has only been tested in Delphi 5. Please e-mail me a copy for upload, if you modify the component for Delphi 3 or 4!
Enjoy!
***************
//***********************************************************
// HistoryMenu ver 1.00 (July 27, 2000) *
// *
// For Delphi 5 *
// Freeware Component *
// by *
// Per Linds?Larsen *
// per.lindsoe@larsen.dk *
// *
// *
// Documentation and updated versions: *
// *
// http://www.euromind.com/iedelphi *
// http://www.intelligo.net/iedelphi *
//***********************************************************
unit HistoryMenu;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Registry, menus, IEUtils, SHellApi, shlobj, imglist, ActiveX;
　
type
PItem = ^TItem;
TItem = record
ID, FullID: PItemIDList;
Folder: Boolean;
Created: Boolean;
end;
TOnUrlSelectedEvent = procedure(Sender: TObject; Url: string) of object;
THistoryMenu = class(TComponent)
private
{ Private declarations }
FCaption: string;
FMenuPos: Integer;
FMainMenu: TMainmenu;
FOnUrlSelected: TOnUrlSelectedEvent;
protected
procedure AddMenu(Menu: TMenuItem; MenuTag: Integer);
procedure AddDummy(menu: TMenuItem);
procedure MenuClick(Sender: TObject);
procedure AddEmpty(menu: TMenuItem);
procedure DestroyList;
procedure BuildMenu;
{ Protected declarations }
public
{ Public declarations }
procedure CreateMenu;
procedure RebuildMenu;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property MainMenu: TMainMenu read FMainMenu write FMainMenu;
property Menupos: Integer read FMenuPos write FMenuPos;
property Caption: string read FCaption write FCaption;
property OnURLSelected: TOnURLSelectedEvent read FOnURLSelected write FOnURLSelected;
end;
procedure Register;
implementation
var
Images: TImageList;
Counter: Integer;
List: TList;
Item: PItem;
HistMenu: TMenuItem;
HistoryPidl: PItemIDList;
Folder, Desktop: IShellFolder;
　
function SortFunc(Item1, Item2: Pointer): Integer;
begin
Result := SmallInt(Folder.CompareIDs(0, PItem(Item1).ID, PItem(Item2).ID));
end;
procedure THistoryMenu.AddDummy(menu: TMenuItem);
var
Dummy: TMenuItem;
begin
Dummy := TMenuItem.Create(self);
Dummy.Visible := False;
Menu.add(Dummy);
end;
procedure THistoryMenu.AddEmpty(menu: TMenuItem);
var
Empty: TMenuItem;
begin
Empty := TMenuItem.Create(self);
Empty.Caption := ' (Empty) ';
Empty.Enabled := False;
Menu.add(Empty);
end;
procedure THistoryMenu.AddMenu(Menu: TMenuItem; MenuTag: Integer);
var
MenuItem: TMenuItem;
EnumList: IEnumIDList;
FullID, ID: PItemIDList;
NumIDs: LongWord;
TempList: TList;
I: Integer;
begin
TempList := TList.Create;
FullID := CopyPidl(PItem(List[menuTag])^.FullID);
Desktop.BindToObject(FullID, nil, IID_IShellFolder, Pointer(Folder));
Folder.EnumObjects(Application.Handle, SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN, EnumList);
while EnumList.Next(1, ID, NumIDs) = S_OK do
begin
Item := New(PItem);
Item.ID := CopyPidl(ID);
Item.FullID := ConcatPIDLs(FullID, ID);
Item.Folder := IsFolder(Folder, ID);
Item.Created := False;
TempList.Add(Item);
end;
if TempList.Count = 0 then begin
AddEmpty(Menu);
exit;
end;
TempList.Sort(SortFunc);
for I := 0 to TempList.Count - 1 do begin
List.Add(PItem(Templist));
MenuItem := TMenuItem.Create(Menu);
MenuItem.SubmenuImages := Images;
MenuItem.OnClick := MenuClick;
MenuItem.Tag := Counter;
MenuItem.Caption := GetDisplayName(Folder, PItem(TempList)^.ID);
MenuItem.ImageIndex := GetImageIndex(PItem(TempList)^.FullID);
if not PItem(TempList)^.Folder then
Menuitem.Hint := ExtractUrl(Folder, PItem(TempList)^.ID);
Menu.Add(MenuItem);
Inc(Counter);
if Item.Folder then AddDummy(MenuItem);
end;
TempList.Free;
end;
procedure THistoryMenu.MenuClick(Sender: TObject);
begin
if not PItem(list[(Sender as TMenuItem).Tag])^.Folder then
begin
if Assigned(FOnUrlSelected) then
FOnUrlSelected(Sender, (Sender as TMenuItem).Hint);
rebuildmenu;
end else if
not PItem(list[(Sender as TMenuItem).Tag]).Created then
begin
AddMenu(Sender as TMenuItem, (Sender as TMenuItem).Tag);
PItem(list[(Sender as TMenuItem).Tag]).Created := TRUE;
end;
end;
procedure THistoryMenu.BuildMenu;
var
DateFolder: IShellFolder;
DateEnumList: IEnumIDList;
DateMenuItem: TMenuItem;
DateId: PItemIDList;
NumIDs: UINT;
begin
List := TList.Create;
Counter := 0;
Desktop.BindToObject(HistoryPidl, nil, IID_IShellFolder, Pointer(DateFolder));
DateFolder.EnumObjects(Application.Handle,
SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN, DateEnumList);
while DateEnumList.Next(1, DateID, NumIDs) = S_OK do
begin
DateMenuItem := TMenuItem.Create(Application);
DateMenuItem.SubmenuImages := Images;
DateMenuItem.OnClick := MenuClick;
DateMenuItem.Tag := Counter;
Inc(Counter);
DateMenuItem.Caption := GetDisplayName(DateFolder, DateID);
Item := New(PItem);
Item.Id := CopyPidl(DateID);
Item.FullID := ConcatPIDLs(HistoryPidl, DateID);
DateMenuItem.ImageIndex := GetImageIndex(Item.FullID);
Item.Folder := IsFolder(DateFolder, DateID);
Item.Created := False;
List.Add(Item);
HistMenu.Add(DateMenuItem);
if Item.Folder then AddDummy(DateMenuItem);
end;
end;
procedure THistoryMenu.RebuildMenu;
begin
DestroyList;
Histmenu.Clear;
BuildMenu;
end;
procedure THistoryMenu.CreateMenu;
var
FileInfo: TSHFileInfo;
begin
SHGetDesktopFolder(Desktop);
SHGetSpecialFolderLocation(Application.Handle, CSIDL_HISTORY, HistoryPIDL);
Images := TImagelist.Create(self);
Images.ShareImages := True;
Images.DrawingStyle := dsTransparent;
Images.Handle := SHGetFileInfo(Pchar(HistoryPidl), 0, FileInfo, SizeOf(FileInfo),
SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
HistMenu := TMenuitem.Create(self);
HistMenu.SubmenuImages := Images;
HistMenu.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, HistMenu);
end;
buildMenu;
end;
constructor THistoryMenu.Create;
begin
FMenuPos := 1;
with TRegistry.Create do
begin
RootKey := HKEY_CLASSES_ROOT;
OpenKey('CLSID/{FF393560-C2A7-11CF-BFF4-444553540000}', FALSE);
FCaption := ReadString('');
Closekey;
Free;
end;
inherited;
end;
procedure THistoryMenu.DestroyList;
var
I: Integer;
begin
if list <> nil then
begin
for I := 0 to List.Count - 1 do
begin
DisposePIDL(PItem(List).ID);
DisposePIDL(PItem(List).FULLID);
Dispose(PItem(List));
end;
List.Free;
end;
end;
destructor THistoryMenu.Destroy;
begin
DestroyList;
inherited;
end;
procedure Register;
begin
RegisterComponents('Samples', [THistoryMenu]);
end;
end.