扩展Delphi主菜单

 新建一个设计期包，将下面的代码拷贝的一个新单元中加入到包，编译并安装包即可。方法参考RemObjects的菜单生成方式。

unit IDEHelpMenu;

interface

procedure Register;

implementation

uses Windows, Classes, SysUtils, ToolsAPI, Dialogs, ShellApi, TLHelp32, Menus,
  Registry;

type
  THelpClass = class
  public
    class function ReadEvnVariant(const AName: string): string;
  end;
  TIDEHelpMenu_ASPack = class(TNotifierObject,IOTAWizard,IOTAMenuWizard)
  protected
    function GetIDString: string;
    function GetName: string;
    function GetState: TWizardState;
    procedure Execute;
    {IOTAMenuWizard的方法}
    function GetMenuText: string;
  end;

  TIDEHelpMenu_Kill = class(TNotifierObject,IOTAWizard,IOTAMenuWizard)
  protected
    function GetIDString: string;
    function GetName: string;
    function GetState: TWizardState;
    procedure Execute;
    {IOTAMenuWizard的方法}
    function GetMenuText: string;
  end;

  TIDEExtend = class(TNotifierObject)
  private
    class procedure OnASPackMenuClick(Sender: TObject);
    class procedure OnKillMenuClick(Sender: TObject);
    class procedure OnPjtOutputDirMenuClick(Sender: TObject);
    class procedure OnExecProceXPMenuClick(Sender: TObject);
    class procedure OnDependsMenuClick(Sender: TObject);
    class procedure OnResourceBuildMenuClick(Sender: TObject);
    class procedure OnIBExpertMenuClick(Sender: TObject);
    class procedure OnDelphiHelpMenuClick(Sender: TObject);
    class procedure OnDelphiVCLHelpMenuClick(Sender: TObject);
  public
    class procedure CreateMenus;
  end;

{ TIDEHelpMenu }

function GetActiveProjectGroup: IOTAProjectGroup;
var
  I: Integer;
begin
  Result := nil;
 
  with BorlandIDEServices as IOTAModuleServices do
    for I := 0 to ModuleCount - 1 do
      if Supports(Modules[I], IOTAProjectGroup, Result) then
        Exit;
end;
 
function GetActiveProject: IOTAProject;
var
  ProjectGroup: IOTAProjectGroup;
  I: Integer;
begin
  Result := nil;
 
  ProjectGroup := GetActiveProjectGroup;
  if Assigned(ProjectGroup) then
    Result := ProjectGroup.ActiveProject
  else
    with BorlandIDEServices as IOTAModuleServices do
      for I := 0 to ModuleCount - 1 do
        if Supports(Modules[I], IOTAProject, Result) then
          Break;
end;

procedure TIDEHelpMenu_ASPack.Execute;
var
  oDlg: TOpenDialog;
  sFileName, sOutPutFileName, sCommand: string;
  iProject: IOTAProject;
begin
  oDlg := TOpenDialog.Create(nil);
  try
    oDlg.Filter := '可执行文件|*.exe;*.dll;*.bpl';
    iProject := GetActiveProject;
    if iProject <> nil then
      oDlg.FileName := GetActiveProject.ProjectOptions.TargetName;
    if oDlg.Execute then
    begin                                                               
      sFileName := oDlg.FileName;
      sOutPutFileName := ExtractFilePath(sFileName) + 'ASPack_' + ExtractFileName(sFileName);
      sCommand := Format('ASPack %s /O%s', [sFileName, sOutPutFileName]);
      WinExec(PChar(sCommand), SW_HIDE);
    end
    else
      WinExec(PChar('ASPack'), SW_HIDE);
  finally
    oDlg.Free;
  end;
end;

function TIDEHelpMenu_ASPack.GetIDString: string;
begin
  Result := 'Henreash.ASPack';
end;

function TIDEHelpMenu_ASPack.GetMenuText: string;
begin
  Result := 'ASPack快捷方式';
end;

function TIDEHelpMenu_ASPack.GetName: string;
begin
  Result := 'ASPack快捷方式';
end;

function TIDEHelpMenu_ASPack.GetState: TWizardState;
begin
  Result := [wsEnabled];
end;

procedure Register;
begin
  TIDEExtend.CreateMenus;
  //RegisterPackageWizard(TIDEHelpMenu_ASPack.Create);
  //RegisterPackageWizard(TIDEHelpMenu_Kill.Create);
end;

{ TIDEHelpMenu_Kill }

procedure TIDEHelpMenu_Kill.Execute;
  procedure EndProcess(AFileName: string);
  const
    PROCESS_TERMINATE = $0001;
  var
    ContinueLoop: BOOL;
    FSnapShotHandle: THandle;
    FProcessEntry32: TProcessEntry32;
  begin
    FSnapShotHandle := CreateToolhelp32SnapShot(TH32CS_SNAPPROCESS, 0);
    FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
    ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  while integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(AFileName))
      or (UpperCase(FProcessEntry32.szExeFile ) = UpperCase(AFileName))) then
      TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0),
                      FProcessEntry32.th32ProcessID), 0);
    ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
  end;

var
  sFileName: string;
begin
  if GetActiveProject = nil then
    Exit;
  sFileName := ExtractFileName(GetActiveProject.ProjectOptions.TargetName);
  EndProcess(sFileName);
end;

function TIDEHelpMenu_Kill.GetIDString: string;
begin
  Result := 'Henreash.Kill';
end;

function TIDEHelpMenu_Kill.GetMenuText: string;
begin
  Result := '结束当前项目进程';
end;

function TIDEHelpMenu_Kill.GetName: string;
begin
  Result := '结束当前项目进程';
end;

function TIDEHelpMenu_Kill.GetState: TWizardState;
begin
  Result := [wsEnabled];
end;

{ TIDEExtend }

class procedure TIDEExtend.CreateMenus;
var
  iServices: INTAServices;
  oMainMenu: TMainMenu;
  oMainItem: TMenuItem;
  oASPackItem: TMenuItem;
  oKillItem: TMenuItem;
  oPjtOutputDirItem: TMenuItem;
  oProceXPItem: TMenuItem;
  oDependsItem: TMenuItem;
  oResourceBuild: TMenuItem;
  oIBExpert: TMenuItem;
  oToolsItem: TMenuItem;
  oDelphiVCLHelpTtem: TMenuItem;
begin
  iServices := (BorlandIDEServices as INTAServices);
  oMainMenu := iServices.MainMenu;
  oMainItem := TMenuItem.Create(oMainMenu);
  oMainItem.AutoHotkeys := maManual;
  oMainItem.Caption := '扩展功能(&g)';
  oMainMenu.Items.Add(oMainItem);

  oKillItem := TMenuItem.Create(oMainMenu);
  oKillItem.Caption := '结束当前项目进程(&k)';
  oKillItem.OnClick := OnKillMenuClick;
  oMainItem.Add(oKillItem);

  oPjtOutputDirItem := TMenuItem.Create(oMainMenu);
  oPjtOutputDirItem.Caption := '项目输出目录(&o)';
  oPjtOutputDirItem.OnClick := OnPjtOutputDirMenuClick;
  oMainItem.Add(oPjtOutputDirItem);

  oToolsItem := TMenuItem.Create(oMainMenu);
  oToolsItem.Caption := '常用工具(&t)';
  oMainItem.Add(oToolsItem);

  oASPackItem := TMenuItem.Create(oMainMenu);
  oASPackItem.Caption := '&ASPack快捷方式';
  oASPackItem.OnClick := OnASPackMenuClick;
  oToolsItem.Add(oASPackItem);

  oProceXPItem := TMenuItem.Create(oMainMenu);
  oProceXPItem.Caption := 'ProceX&P';
  oProceXPItem.OnClick := OnExecProceXPMenuClick;
  oToolsItem.Add(oProceXPItem);

  oDependsItem := TMenuItem.Create(oMainMenu);
  oDependsItem.Caption := '&Depends';
  oDependsItem.OnClick := OnDependsMenuClick;
  oToolsItem.Add(oDependsItem);

  oResourceBuild := TMenuItem.Create(oMainMenu);
  oResourceBuild.Caption := '资源编译器(&r)';
  oResourceBuild.OnClick := OnResourceBuildMenuClick;
  oToolsItem.Add(oResourceBuild);

  oIBExpert := TMenuItem.Create(oMainMenu);
  oIBExpert.Caption := '&IBExpert';
  oIBExpert.OnClick := OnIBExpertMenuClick;
  oToolsItem.Add(oIBExpert);

  oDelphiVCLHelpTtem := TMenuItem.Create(oMainMenu);
  oDelphiVCLHelpTtem.Caption := 'Delphi VCL Help';
  oDelphiVCLHelpTtem.OnClick := OnDelphiVCLHelpMenuClick;
  oMainItem.Add(oDelphiVCLHelpTtem);
end;

class procedure TIDEExtend.OnASPackMenuClick(Sender: TObject);
var
  oASPack: TIDEHelpMenu_ASPack;
begin
  oASPack := TIDEHelpMenu_ASPack.Create;
  try
    oASPack.Execute;
  finally
    oASPack.Free;
  end;
end;

class procedure TIDEExtend.OnDelphiHelpMenuClick(Sender: TObject);
var
  sMyToolsDir: string;
  oReg: TRegistry;
begin
  sMyToolsDir := THelpClass.ReadEvnVariant('MyTools');
  ShellExecute(0, 'Open', pchar(sMyToolsDir + '\Delphi2007Help.chm'), nil, nil, SW_SHOWNORMAL)
end;

class procedure TIDEExtend.OnDelphiVCLHelpMenuClick(Sender: TObject);
var
  sMyToolsDir: string;
  oReg: TRegistry;
begin
  sMyToolsDir := THelpClass.ReadEvnVariant('MyTools');
  ShellExecute(0, 'Open', pchar(sMyToolsDir + '\delphi2007vclwin32.chm'), nil, nil, SW_SHOWNORMAL)
end;

class procedure TIDEExtend.OnDependsMenuClick(Sender: TObject);
var
  sMyToolsDir: string;
  oReg: TRegistry;
begin
  sMyToolsDir := THelpClass.ReadEvnVariant('MyTools');
  WinExec(PChar(sMyToolsDir + '\Depends.exe'), SW_SHOW);
end;

class procedure TIDEExtend.OnExecProceXPMenuClick(Sender: TObject);
var
  sMyToolsDir: string;
  oReg: TRegistry;
begin
  sMyToolsDir := THelpClass.ReadEvnVariant('MyTools');
  WinExec(PChar(sMyToolsDir + '\ProceXP.exe'), SW_SHOW);
end;

class procedure TIDEExtend.OnIBExpertMenuClick(Sender: TObject);
var
  sMyToolsDir: string;
  oReg: TRegistry;
begin
  sMyToolsDir := THelpClass.ReadEvnVariant('MyTools');
  WinExec(PChar(sMyToolsDir + '\IBExpert\IBExpert.exe'), SW_SHOW);
end;

class procedure TIDEExtend.OnKillMenuClick(Sender: TObject);
var
  oKill: TIDEHelpMenu_Kill;
begin
  oKill := TIDEHelpMenu_Kill.Create;
  try
    oKill.Execute;
  finally
    oKill.Free;
  end;
end;

class procedure TIDEExtend.OnPjtOutputDirMenuClick(Sender: TObject);
var
  sDir: string;
  iProject: IOTAProject;
begin
  iProject := GetActiveProject;
  if iProject = nil then
    Exit;
  sDir := ExtractFilePath(iProject.ProjectOptions.TargetName);
  WinExec(PChar('explorer ' + sDir), SW_SHOW);
end;

class procedure TIDEExtend.OnResourceBuildMenuClick(Sender: TObject);
var
  sMyToolsDir: string;
  oReg: TRegistry;
begin
  sMyToolsDir := THelpClass.ReadEvnVariant('MyTools');
  WinExec(PChar(sMyToolsDir + '\xasoftBrcc32\ResBuild.exe'), SW_SHOW);
end;

{ THelpClass }

class function THelpClass.ReadEvnVariant(const AName: string): string;
var
  oReg: TRegistry;
const
  REG_ENVIRONMENT = 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment';
begin
  oReg := TRegistry.Create;
  try
    oReg.RootKey := HKEY_LOCAL_MACHINE;
    if not oReg.OpenKey(REG_ENVIRONMENT, True) then
    begin
      MessageDlg('打开注册表发生错误', mtInformation, [mbYes], 0);
      Exit;
    end;
    Result := oReg.ReadString(AName);
  finally
    oReg.Free;
  end;
end;

end.