Построения "браузера" на основе IE

unit FavMenu;
 
interface
 
{$I EWB.inc}
 
uses
 
  Classes, Controls, Forms, ShlObj, Imglist, Menus, EmbeddedWB;
 
 
type
  PItem = ^TItem;
  TItem = record
    ID: PItemIDList;
    FullID: PItemIDList;
    Folder: Boolean;
    Created: Boolean;
  end;
 
type
  TErrorEvent = procedure(const ErrorCode: integer; ErrMessage: string) of object;
  TFavOptions = (foAddFavorites, foOrganizeFavorites, foImportFavorites,
    foExportFavorites, foImportExportWizard);
  TOptions = set of TFavOptions;
  TOnAddFavoritesEvent = procedure(const EmbeddedWB: TEmbeddedWB; Title, URL: WideString; Success: integer) of object;
  TOnUrlSelectedEvent = procedure(Sender: TObject; Url: string) of object;
  TResolveUrl = (IntShCut, IniFile);
 
  TLocalization = class(TPersistent)
  private
    FAddFavorites: string;
    FOrganizeFavorites: string;
    FImportFavorites: string;
    FExportFavorites: string;
    FImportExportWizard: string;
    FEmptyCaption: 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;
    property ImportExportWizard: string read FImportExportWizard write FImportExportWizard;
    property EmptyCaption: string read FEmptyCaption write FEmptyCaption;
  end;
 
  TFavoritesMenu = class(TComponent)
  private
    { Private declarations }
    Counter: Integer;
    Desktop: IShellFolder;
    FavoritesMenu: TMenuItem;
    FavoritesPidl: PItemIDList;
    FAbout: string;
    FCaption: string;
    FChannels: Boolean;
    FEmbeddedWB: TEmbeddedWB;
    FEnabled: Boolean;
    FOnError: TErrorEvent;
    FLocalization: TLocalization;
    FMainMenu: TMainmenu;
    FMaxWidth: Integer;
    FMenuPosition: Integer;
    FOnAddFavorites: TOnAddFavoritesEvent;
    FOnUrlSelected: TOnUrlSelectedEvent;
    FOptions: TOptions;
    FResolveUrl: TResolveUrl;
    Images: TImageList;
    Item: PItem;
    List: TList;
    procedure AddFavorite(Sender: TObject);
    procedure FavoritesExport(Sender: TObject);
    procedure FavoritesImport(Sender: TObject);
    procedure OrganizeFavorite(Sender: TObject);
    procedure ImportExportWizard(Sender: TObject);
    procedure SetAbout(Value: string);
  protected
    { Protected declarations }
    procedure AddDummy(menu: TMenuItem);
    procedure AddEmpty(menu: TMenuItem);
    procedure AddMenu(Menu: TMenuItem; FullID: PItemIDList);
    procedure BuildOptionsMenu;
    procedure DestroyList;
    procedure MenuClick(Sender: TObject);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CreateMenu(mi: TMenuItem); overload;
    procedure CreateMenu; overload;
    procedure ReBuildMenu;
  published
    { Published declarations }
    property About: string read fAbout write SetAbout;
    property Caption: string read FCaption write FCaption;
    property Channels: Boolean read FChannels write FChannels default False;
    property EmbeddedWB: TEmbeddedWB read FEmbeddedWB write FEmbeddedWB;
    property Enabled: Boolean read FEnabled write FEnabled default True;
    property Localization: TLocalization read FLocalization write FLocalization;
    property MainMenu: TMainMenu read FMainMenu write FMainMenu;
    property MaxWidth: Integer read FMaxWidth write FMaxWidth default 50;
    property MenuPosition: Integer read FMenuPosition write FMenuPosition default 1;
    property OnAddFavorites: TOnAddFavoritesEvent read FOnAddFavorites write FOnAddFavorites;
    property OnError: TErrorEvent read FOnError write FOnError;
    property OnURLSelected: TOnURLSelectedEvent read FOnURLSelected write FOnURLSelected;
    property Options: TOptions read FOptions write FOptions default [foAddFavorites, foOrganizeFavorites];
    property ResolveUrl: TResolveUrl read FResolveUrl write FResolveUrl default IntShCut;
  end;
 
implementation
 
uses
  ImportFavorites, ExportFavorites, Windows, ShellApi, SysUtils, SHDocVw_EWB, ActiveX, Registry, EwbTools;
 
var
  ChannelShortcut, InternetShortcut: string;
  Folder: IShellFolder;
  Procedur: procedure(Handle: THandle; Path: PAnsiChar); stdcall;
 
function SortFunc(Item1, Item2: Pointer): Integer;
begin
  Result := SmallInt(Folder.CompareIDs(0, PItem(Item1).ID, PItem(Item2).ID));
end;
 
function CheckShortcut(Shortcut, Flag: Integer): Boolean;
begin
  Result := ShortCut and Flag <> 0;
end;
 
function GetImageIndex(PIDL: PItemIDList; Large, Open: Boolean): Integer;
var
  FileInfo: TSHFileInfo;
  Flags: Integer;
begin
  Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX;
  if Open then
    Flags := Flags or SHGFI_OPENICON;
  if Large then
    Flags := Flags or SHGFI_LARGEICON
  else
    Flags := Flags or SHGFI_SMALLICON;
  SHGetFileInfo(PChar(PIDL), 0, FileInfo, SizeOf(FileInfo), Flags);
  Result := FileInfo.iIcon;
end;
 
constructor TFavoritesMenu.Create;
begin
  FAbout := 'TFavoritesMenu - from [url]http://www.bsalsa.com/';[/url]
  FEnabled := True;
  FLocalization := TLocalization.Create;
  FLocalization.FAddFavorites := 'Add to Favorites';
  FLocalization.FOrganizeFavorites := 'Organize Favorites';
  FLocalization.FImportFavorites := 'Import Favorites';
  FLocalization.FExportFavorites := 'Export Favorites';
  FLocalization.FImportExportWizard := 'Import Export Favorites Wizard';
  FLocalization.FEmptyCaption := ' (empty) ';
  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;
  FMenuPosition := 1;
  FOptions := [foAddFavorites, foOrganizeFavorites];
  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 TFavoritesMenu.SetAbout(Value: string);
begin
  Exit;
end;
 
procedure TFavoritesMenu.FavoritesExport(Sender: TObject);
var
  ExportFav: TExportFavorite;
begin
  if FEnabled and Assigned(FEmbeddedWB) then
  begin
    if not FEmbeddedWB.DocumentLoaded then
      FEmbeddedWB.AssignEmptyDocument(True);
    ExportFAv := TExportFavorite.Create(Self);
    with ExportFav do
    begin
      ExportFavorites;
      Free;
    end;
  end;
end;
 
procedure TFavoritesMenu.FavoritesImport(Sender: TObject);
var
  ImportFav: TImportFavorite;
begin
  if FEnabled and Assigned(FEmbeddedWB) then
  begin
    if not FEmbeddedWB.DocumentLoaded then
      FEmbeddedWB.AssignEmptyDocument(True);
    ImportFav := TImportFavorite.Create(Self);
    with ImportFav do
    begin
      ImportFavorites;
      Free;
    end;
  end;
end;
 
procedure TFavoritesMenu.ImportExportWizard(Sender: TObject);
begin
  if FEnabled and Assigned(FEmbeddedWB) then
  begin
    if not FEmbeddedWB.DocumentLoaded then
    begin
      FEmbeddedWB.AssignEmptyDocument;
      FEmbeddedWB.Wait;
    end;
    FEmbeddedWB.ShowImportExportFavoritesAndCookies;
  end;
end;
 
procedure TFavoritesMenu.OrganizeFavorite(Sender: Tobject);
var
  SpecialPath: array[0..MAX_PATH] of Char;
  H: Cardinal;
  bGet: Boolean;
begin
  if FEnabled then
  begin
    H := LoadLibrary('shdocvw.dll');
    if H <> 0 then
    begin
      Procedur := GetProcAddress(H, 'DoOrganizeFavDlg');
      if Assigned(Procedur) then
      begin
        bGet := SHGetPathFromIDList(FavoritesPidl, SpecialPath);
        if (not bGet) and Assigned(FOnError) then
          FOnError(E_FAIL, 'Failed while getting path for the favorites!');
        Procedur(Application.Handle, PAnsiChar(AnsiString(SpecialPath)));
      end;
    end
    else
      if Assigned(FOnError) then
        FOnError(E_FAIL, 'Failed while loading library!');
    FreeLibrary(H);
    RebuildMenu;
  end;
end;
 
procedure TFavoritesMenu.AddFavorite(Sender: TObject);
const
  CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
var
  ShellUIHelper: ISHellUIHelper;
  Url, Title: OleVariant;
  Success: integer;
begin
  if (FEnabled) and (Assigned(FEmbeddedWB)) then
  begin
    Title := FEmbeddedWB.LocationName;
    Url := FEmbeddedWB.LocationUrl;
    if (Url <> EmptyStr) and (url <> 'about:blank') then
    begin
      Success := CoCreateInstance(CLSID_SHELLUIHELPER, nil, CLSCTX_INPROC_SERVER,
        IID_IShellUIHelper, ShellUIHelper);
      if Assigned(FOnAddFavorites) then
        FOnAddFavorites(FEmbeddedWB, Title, URL, Success);
      if (Success <> S_OK) and (Assigned(FOnError)) then
        FOnError(Success, 'Failed  while adding to favorites!');
      ShellUIHelper.AddFavorite(Url, Title);
      RebuildMenu;
    end
    else
      if (Assigned(FOnError)) then
        FOnError(E_FAIL, 'Failed - Empty URL string!');
  end
  else
    if (Assigned(FOnError)) then
      FOnError(E_FAIL, 'Please assign a browser');
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 := FLocalization.FEmptyCaption;
  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, J: Integer;
  sfi: TShFileInfo;
  Success: integer;
begin
  if FEnabled then
  begin
    TempList := TList.Create;
    try
      Success := Desktop.BindToObject(FullID, nil, IID_IShellFolder, Pointer(Folder));
      if (Success <> S_OK) and (Assigned(FOnError)) then
        FOnError(Success, 'Failed to retrieve an IShellFolder object for a subfolder!');
      Success := Folder.EnumObjects(Application.Handle, SHCONTF_FOLDERS or SHCONTF_NONFOLDERS,
        EnumList);
      if (Success <> S_OK) and (Assigned(FOnError)) then
        FOnError(Success, 'Failed Enum objects!');
      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);
        Exit;
      end;
      TempList.Sort(SortFunc);
      for I := 0 to TempList.Count - 1 do
      begin
        List.Add(PItem(Templist[I]));
        MenuItem := TMenuItem.Create(Menu);
        with MenuItem do
        begin
          SubMenuImages := Images;
          OnClick := MenuClick;
          Tag := Counter;
          Caption := GetDisplayName(Folder, PItem(TempList[I])^.ID);
        end;
        if Length(MenuItem.Caption) > FMaxWidth then
          MenuItem.Caption := Copy(MenuItem.Caption, 1, FMaxWidth) + '...';
        J := GetImageIndex(PItem(TempList[I])^.FullID, False, False);
        if (J = 3) and (CheckShortCut(SFGAO_LINK, SFGAO_DISPLAYATTRMASK)) then
        begin
          ShGetFileInfo('*.htm', FILE_ATTRIBUTE_NORMAL, sfi, SizeOf(sfi),
            SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or SHGFI_SMALLICON);
          J := sfi.iIcon;
          DestroyIcon(sfi.iIcon);
        end;
        MenuItem.ImageIndex := J;
        Menu.Add(MenuItem);
        Inc(Counter);
        if PItem(TempList[I])^.Folder then
          AddDummy(MenuItem);
      end;
 
    finally
      TempList.Free;
    end;
  end;
end;
 
procedure TFavoritesMenu.MenuClick(Sender: TObject);
var
  Folder: IShellFOlder;
  FileInfo: TSHFileInfo;
  ID: PItemIDList;
  X: OleVariant;
  Url: string;
  Success: integer;
begin
  if FEnabled and not (csDesigning in ComponentState) then
  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);
      Success := Desktop.BindToObject(ID, nil, IID_IShellFolder, Pointer(Folder));
      if (Success <> S_OK) and (Assigned(FOnError)) then
        FOnError(Success, 'Failed to retrieve an IShellFolder object for a subfolder!');
      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
        if Assigned(FEmbeddedWB) then
          FEmbeddedWB.Navigate(Url, X, X, X, X);
    end;
  end;
end;
 
procedure TFavoritesMenu.BuildOptionsMenu;
begin
  if FEnabled and not (csDesigning in ComponentState) then
  begin
    if foAddFavorites in FOptions then
      FavoritesMenu.Add(NewItem(FLocalization.FAddFavorites, 0,
        False, True, addfavorite, 0, ''));
    if foOrganizeFavorites 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 foImportFavorites in FOptions then
        FavoritesMenu.Add(NewItem(FLocalization.FImportFavorites, 0,
          False, True, FavoritesImport, 0, ''));
      if foExportFavorites in FOptions then
        FavoritesMenu.Add(NewItem(FLocalization.FExportFavorites, 0,
          False, True, FavoritesExport, 0, ''));
      if foImportExportWizard in FOptions then
        FavoritesMenu.Add(NewItem(FLocalization.FImportExportWizard, 0,
          False, True, ImportExportWizard, 0, ''));
 
      if (foImportFavorites in FOptions) or (foExportFavorites in FOptions) then
        FavoritesMenu.Add(NewItem('-', 0, False, True, nil, 0, ''));
    end;
  end;
end;
 
procedure TFavoritesMenu.CreateMenu;
var
  FileInfo: TSHFileInfo;
begin
  if FEnabled and not (csDesigning in ComponentState) then
  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);
    with FavoritesMenu do
    begin
      SubMenuImages := Images;
      Caption := FCaption;
    end;
    if Assigned(FMainMenu) then
    begin
      if FMenuPosition > FMainMenu.Items.Count + 1 then
        FMenuPosition := FMainMenu.Items.Count + 1
      else
        if FMenuPosition <= 0 then
          FMenuPosition := 1;
      FMainMenu.Items.Insert(FMenuPosition - 1, FavoritesMenu);
    end;
    BuildOptionsMenu;
    AddMenu(FavoritesMenu, FavoritesPidl);
  end;
end;
 
procedure TFavoritesMenu.CreateMenu(mi: TMenuItem);
var
  FileInfo: TSHFileInfo;
begin
  if FEnabled and not (csDesigning in ComponentState) then
  begin
    Counter := 0;
    List := TList.Create;
    Images := TImagelist.Create(self);
    with images do
    begin
      ShareImages := True;
      DrawingStyle := dsTransparent;
      Handle := SHGetFileInfo(Pchar(FavoritesPidl), 0, FileInfo,
        SizeOf(FileInfo), SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
    end;
    if mi = nil then
    begin
      FavoritesMenu := TMenuitem.Create(self);
      FavoritesMenu.Caption := FCaption;
    end
    else
      FavoritesMenu := mi;
    FavoritesMenu.SubmenuImages := Images;
    if Assigned(FMainMenu) then
    begin
      if FMenuPosition > FMainMenu.Items.Count + 1 then
        FMenuPosition := FMainMenu.Items.Count + 1
      else
        if FMenuPosition <= 0 then
          FMenuPosition := 1;
      FMainMenu.Items.Insert(FMenuPosition - 1, FavoritesMenu);
    end;
    BuildOptionsMenu;
    AddMenu(FavoritesMenu, FavoritesPidl);
  end;
end;
 
procedure TFavoritesMenu.ReBuildMenu;
begin
  DestroyList;
  List := TList.Create;
  FavoritesMenu.Clear;
  BuildOptionsMenu;
  AddMenu(FavoritesMenu, FavoritesPidl);
end;
 
end.