// Install in a package
// provided “as is”, no warranty, use at your own risk, bla bla
// tested with Berlin U2 (parent.owner.owner... :)

unit IconWizard;

interface

uses
  Winapi.Windows,

  System.SysUtils,
  System.Classes,
  System.IOUtils,

  Vcl.Menus,
  Vcl.Forms,
  Vcl.Controls,
  Vcl.Dialogs,

  ToolsAPI;

type
  TIconWizard = class(TInterfacedObject, IOTAWizard)
  private
    FMainMenuItem: TMenuItem;
    procedure DoChangeIcon(Sender: TObject);
  public
    // TObject
    constructor Create;
    destructor Destroy; override;

    // IOTANotifier
    procedure AfterSave;
    procedure BeforeSave;
    procedure Destroyed;
    procedure Modified;

    // IOTAWizard
    function GetIDString: string;
    function GetName: string;
    function GetState: TWizardState;
    procedure Execute;
  end;

procedure Register;

implementation

uses
  Vcl.Clipbrd,
  System.StrUtils;

procedure Register;
begin
  RegisterPackageWizard(TIconWizard.Create);
end;

{ Anything else }

// from http://www.gexperts.org/open-tools-api-faq/
function GetCurrentProject: IOTAProject;
var
  ModServices: IOTAModuleServices;
  Module: IOTAModule;
  Project: IOTAProject;
  ProjectGroup: IOTAProjectGroup;
  i: Integer;
begin
  Result := nil;
  ModServices := BorlandIDEServices as IOTAModuleServices;
  for i := 0 to ModServices.ModuleCount - 1 do
  begin
    Module := ModServices.Modules[i];
    if Supports(Module, IOTAProjectGroup, ProjectGroup) then
    begin
      Result := ProjectGroup.ActiveProject;
      Exit;
    end
    else if Supports(Module, IOTAProject, Project) then
    begin // In the case of unbound packages, return the 1st
      if Result = nil then
        Result := Project;
    end;
  end;
end;

constructor TIconWizard.Create;
var
  NTAServices: INTAServices;
begin
  NTAServices := BorlandIDEServices as INTAServices;
  // Main Menu
  FMainMenuItem := TMenuItem.Create(nil);
  FMainMenuItem.Caption := 'Icon';
  FMainMenuItem.OnClick := DoChangeIcon;
  NTAServices.MainMenu.Items.Add(FMainMenuItem);
end;

destructor TIconWizard.Destroy;
begin
  if Assigned(FMainMenuItem) then
    FreeAndNil(FMainMenuItem);
  inherited;
end;

{ IOTANotifier }
procedure TIconWizard.AfterSave;
begin
end;

procedure TIconWizard.BeforeSave;
begin
end;

procedure TIconWizard.Destroyed;
begin
end;

procedure TIconWizard.DoChangeIcon(Sender: TObject);
var
  Project: IOTAProject;
  s, ficon: string;
  od: TOpenDialog;
begin
  // ShowMessage(FMainMenuItem.Parent.Owner.Owner.Owner.ClassName);
  if (FMainMenuItem <> nil) and //
    (FMainMenuItem.Parent <> nil) and //
    (FMainMenuItem.Parent.Owner <> nil) and //
    (FMainMenuItem.Parent.Owner.Owner <> nil) and //
    (FMainMenuItem.Parent.Owner.Owner.Owner <> nil) and //
    (FMainMenuItem.Parent.Owner.Owner.Owner is TApplication) then
  begin
    Project := GetCurrentProject;
    ficon := '';
    if Project <> nil then
    begin
      s := TPath.GetDirectoryName(Project.FileName);
      if FileExists(s + '\bds.ico') then
        ficon := s + '\bds.ico';
    end;

    if ficon = '' then
    begin
      od := TOpenDialog.Create(FMainMenuItem.Parent.Owner.Owner.Owner);
      od.Filter := 'Icon|*.ico';
      try
        if od.Execute then
          ficon := od.FileName;
      finally
        od.Free;
      end;
    end;

    if ficon <> '' then
      TApplication(FMainMenuItem.Parent.Owner.Owner.Owner).Icon.LoadFromFile(ficon);
  end;
end;

procedure TIconWizard.Modified;
begin
end;

{ IOTAWizard }

function TIconWizard.GetIDString: string;
begin
  Result := 'Icon.Wizard7';
end;

function TIconWizard.GetName: string;
begin
  Result := 'Icon Wizard7';
end;

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

procedure TIconWizard.Execute;
begin
end;

end.