Delphi palette menu for Delphi 5

a delphi 5 wizard to add a palette tab submenu to the palette's (right-click) popup-menu. facilitates opening a specific tab without having to scroll through all the tabs. includes source. 資料來源:http://www.base2ti.com 下載點1 下載點2

{*****************************************************************************
*  PaletteMenuWizard.pas                                                     *
*  copyright (c) 2001 base2 technologies                                     *
*                                                                            *
*  revision history                                                          *
*    2001.10.01  original                                                    *
*****************************************************************************}    unit PaletteMenuWizard;    interface    uses
  Windows, SysUtils, Classes, Forms, Menus, ComCtrls, ToolsApi;    type
  TPaletteMenuWizard = class(TInterfacedObject, IOTAWizard, IOTANotifier)
  private
    FMenu         : TMenuItem;
    FMenuSeparator: TMenuItem;
                FMenuOnPopup  : TNotifyEvent;        procedure BuildMenuItems;
    procedure ClearMenuItems;        procedure MenuPopup(sender: TObject);
    procedure MenuItemClick(sender: TObject);
  protected
    // IOTANotifier        procedure AfterSave;
    procedure BeforeSave;
    procedure Destroyed;
    procedure Modified;        // IOTAWizard        function  GetIDString: String;
    function  GetName: String;
    function  GetState: TWizardState;
    procedure Execute;
  public
    constructor Create;
    destructor  Destroy; override;
  end;    procedure Register;    implementation    {** TPaletteMenuWizard ******************************************************}    constructor TPaletteMenuWizard.Create;
var
  mainForm   : TCustomForm;
  paletteMenu: TPopupMenu;
begin
  inherited Create;      FMenu := NewItem('Tabs',0,False,True,Nil,0,'PaletteTabsMenuItem');
  FMenuSeparator := NewItem('-',0,False,True,Nil,0,'PaletteTabsSeparatorMenuItem');      FMenuOnPopup := Nil;      mainForm := TCustomForm(Application.FindComponent('AppBuilder'));      if Assigned(mainForm) then
  begin
    paletteMenu := TPopupMenu(mainForm.FindComponent('PaletteMenu'));        if Assigned(paletteMenu) then
    begin
      FMenuOnPopup := paletteMenu.OnPopup;
      paletteMenu.OnPopup := MenuPopup;          paletteMenu.Items.Insert(0,FMenu);
      paletteMenu.Items.Insert(1,FMenuSeparator);
    end;
  end;
end;    destructor TPaletteMenuWizard.Destroy;
var
  mainForm   : TCustomForm;
  paletteMenu: TPopupMenu;
begin
  mainForm := TCustomForm(Application.FindComponent('AppBuilder'));      if Assigned(mainForm) then
  begin
    paletteMenu := TPopupMenu(mainForm.FindComponent('PaletteMenu'));        if Assigned(paletteMenu) then
    begin
      paletteMenu.OnPopup := FMenuOnPopup;
    end;
  end;      ClearMenuItems;      FMenuOnPopup := Nil;      FMenuSeparator.Free;
  FMenuSeparator := Nil;      FMenu.Free;
  FMenu := Nil;      inherited Destroy;
end;    procedure TPaletteMenuWizard.AfterSave;
begin
  // do nothing
end;    procedure TPaletteMenuWizard.BeforeSave;
begin
  // do nothing
end;    procedure TPaletteMenuWizard.Destroyed;
begin
  // do nothing
end;    procedure TPaletteMenuWizard.Modified;
begin
  // do nothing
end;    function TPaletteMenuWizard.GetIDString: String;
begin
  result := 'base2 technologies.palette menu wizard';
end;    function TPaletteMenuWizard.GetName: String;
begin
  result := 'Palette Menu Wizard';
end;    function TPaletteMenuWizard.GetState: TWizardState;
begin
  result := [];
end;    procedure TPaletteMenuWizard.Execute;
begin
  // do nothing
end;    procedure TPaletteMenuWizard.BuildMenuItems;
var
        tabs      : TStringList;
  mainForm  : TCustomForm;
  tabControl: TTabControl;
  item      : TMenuItem;
  i         : Integer;
begin
  ClearMenuItems;      mainForm := TCustomForm(Application.FindComponent('AppBuilder'));      if not Assigned(mainForm) then Exit;      tabControl := TTabControl(mainForm.FindComponent('TabControl'));      if not Assigned(tabControl) then Exit;      tabs := TStringList.Create;
  tabs.Sorted := True;      for i := 0 to tabControl.Tabs.Count - 1 do
  begin
          tabs.AddObject(tabControl.Tabs,Pointer(i));
  end;      for i := 0 to tabs.Count - 1 do
  begin
    item := NewItem(tabs[i],0,(tabControl.TabIndex = Integer(tabs.Objects[i])),
      True,MenuItemClick,0,'');        item.Tag := Integer(tabs.Objects[i]);        FMenu.Add(item);
  end;      tabs.Free;
end;    procedure TPaletteMenuWizard.ClearMenuItems;
var
  item: TMenuItem;
  i   : Integer;
begin
  for i := FMenu.Count - 1 downto 0 do
  begin
    item := FMenu[i];
    FMenu.Delete(i);
    item.Free;
  end;
end;    procedure TPaletteMenuWizard.MenuPopup(sender: TObject);
begin
        if Assigned(FMenuOnPopup) then FMenuOnPopup(sender);      BuildMenuItems;
end;    procedure TPaletteMenuWizard.MenuItemClick(sender: TObject);
var
  mainForm  : TCustomForm;
  tabControl: TTabControl;
begin
  mainForm := TCustomForm(Application.FindComponent('AppBuilder'));      if not Assigned(mainForm) then Exit;      tabControl := TTabControl(mainForm.FindComponent('TabControl'));      if not Assigned(tabControl) then Exit;      tabControl.TabIndex := TMenuItem(sender).Tag;      if Assigned(tabControl.OnChange) then tabControl.OnChange(tabControl);
end;    {****************************************************************************}    procedure Register;
begin
  RegisterPackageWizard(TPaletteMenuWizard.Create);
end;    end.

[i]HAVE A NICE DAY FOR YOU 發表人 - axsoft 於 2003/06/25 14:32:32