CD Actual Thematic 25: Programming/pc_actual_25.iso/Delphi/eXpertDevelopmentKit/SOURCE/XDKMENU.PAS

Pascal/Delphi Source File | 1998-01-26 | 16.6 KB | 601 lines

{*******************************************************}
{                                                       }
{       eXpert Development Kit                          }
{                                                       }
{       Copyright (c) 1996,97 Sergey Orlik              }
{       - product manager of Borland Russia             }
{                                                       }
{       This unit based on source code Menus.pas        }
{       by Borland International (TMenuItem component)  }
{                                                       }
{*******************************************************}

unit XDKMenu;

interface
uses
  Windows, SysUtils, Classes, Graphics, Forms, Dialogs, Menus,
  DsgnIntf, ExptIntf, EditIntf, FileIntf, ToolIntf, LibIntf;

type
  ExdkAddInMenuError = class(Exception);
  TxdkAddInMenu = class;
  TxdkAddInMenuItem = class(TComponent)
  private
    FCaption    : string;
    FParent     : TxdkAddInMenuItem;
    FMenu       : TxdkAddInMenu;
    FMenuIntf   : TIMenuItemIntf;
    FParentIntf : string;
    FRoot       : Boolean;
    FChecked    : Boolean;
    FEnabled    : Boolean;
    FRadioItem  : Boolean;
    FVisible    : Boolean;
    FGroupIndex : Byte;
    FBreak      : Boolean;
    FBarBreak   : Boolean;
    FHelpContext: THelpContext;
    FShortCut   : TShortCut;
    FHint       : string;
    FItems      : TList;
    FOnClick: TNotifyEvent;
    procedure TurnSiblingsOff;
    procedure VerifyGroupIndex(Position: Integer; Value: Byte);
    function  GetFlags:TIMenuFlags;
    procedure Activate;
  protected
    function GetCount: Integer;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    function GetItem(Index: Integer): TxdkAddInMenuItem;
    function GetMenuIndex: Integer;
    function GetParentComponent: TComponent; override;
    function HasParent: Boolean; override;
    procedure SetCaption(const Value: string);
    procedure ChangeFlags(const Value: TIMenuFlag; SetFlag: boolean);
    procedure SetChecked(Value: Boolean);
    procedure SetChildOrder(Child: TComponent; Order: Integer); override;
    procedure SetEnabled(Value: Boolean);
    procedure SetGroupIndex(Value: Byte);
    procedure SetMenuIndex(Value: Integer);
    procedure SetParentComponent(Value: TComponent); override;
    procedure SetRadioItem(Value: Boolean);
    procedure SetShortCut(Value: TShortCut);
    procedure SetVisible(Value: Boolean);
    procedure SetHelpContext(Value: THelpContext);
    procedure SetBreak(Value: Boolean);
    procedure SetBarBreak(Value: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Insert(Index: Integer; Item: TxdkAddInMenuItem);
    procedure Delete(Index: Integer);
    procedure Click(Sender:TIMenuItemIntf); virtual;
    function IndexOf(Item: TxdkAddInMenuItem): Integer;
    procedure Add(Item: TxdkAddInMenuItem);
    procedure Remove(Item: TxdkAddInMenuItem);
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TxdkAddInMenuItem read GetItem; default;
    property MenuIndex: Integer read GetMenuIndex write SetMenuIndex;
    property Parent: TxdkAddInMenuItem read FParent;
  published
    property Caption: string read FCaption write SetCaption;
    property Checked: Boolean read FChecked write SetChecked default False;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property GroupIndex: Byte read FGroupIndex write SetGroupIndex default 0;
//    property Hint: string read FHint write FHint; // Note: The IDE currently ignores this property !
    property RadioItem: Boolean read FRadioItem write SetRadioItem default False;
    property ShortCut: TShortCut read FShortCut write SetShortCut default 0;
    property Visible: Boolean read FVisible write SetVisible default True;
    property HelpContext: THelpContext read FHelpContext write SetHelpContext default 0;
    property Break: Boolean read FBreak write SetBreak default False;
    property BarBreak: Boolean read FBarBreak write SetBarBreak default False;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
  end;

  TxdkAddInMenu = class(TComponent)
  private
    FItems       : TxdkAddInMenuItem;
    FIDEMenuItem : string;
    FAppended    : boolean;
  protected
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    procedure SetChildOrder(Child: TComponent; Order: Integer); override;
    procedure SetIDEMenuItem(Value:string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
    property Items: TxdkAddInMenuItem read FItems;
    property IDEMenuItem:string read FIDEMenuItem write SetIDEMenuItem;
    property Appended: boolean read FAppended write FAppended;
  end;

function xdkAddInNewMenuItem(AOwner:TComponent; AName:string):TxdkAddInMenuItem;

//====================================================================
implementation
//====================================================================

const
  sAddInIndexError = 'Invalid index';
  sAddInGroupIndexTooLow = 'Index is too low';
  sAddInReinserted = 'Menu item has parent already';
  sAddInNotFound = 'Menu item isn''t found';

procedure Error(const S: string);
begin
  raise ExdkAddInMenuError.Create(S);
end;

procedure IndexError;
begin
  Error(sAddInIndexError);
end;

//====================================================================
const
  ALLFlags : TIMenuFlags = [mfInvalid, mfEnabled, mfVisible, mfChecked,
    mfBreak, mfBarBreak, mfRadioItem];

constructor TxdkAddInMenuItem.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FVisible := True;
  FEnabled := True;
  FRoot:=false;
end;

destructor TxdkAddInMenuItem.Destroy;
begin
  if (FParent<>nil) and not FRoot then
  begin
    FParent.Remove(Self);
    FParent := nil;
  end;
  while Count > 0 do Items[0].Free;
  FItems.Free;
  if (FMenuIntf<>nil) and not FRoot then
  begin
    FMenuIntf.Free;
    FMenuIntf:=nil;
  end;
  inherited Destroy;
end;

function TxdkAddInMenuItem.GetFlags:TIMenuFlags;
begin
  Result:=[];
  if FEnabled then
    Result:=Result+[mfEnabled];
  if FVisible then
    Result:=Result+[mfVisible];
  if FChecked then
    Result:=Result+[mfChecked];
  if FRadioItem then
    Result:=Result+[mfRadioItem];
  if FBreak then
    Result:=Result+[mfBreak];
  if FBarBreak then
    Result:=Result+[mfBarBreak];
end;

procedure TxdkAddInMenuItem.Activate;
var
  MainMenu : TIMainMenuIntf;
  MenuItems,
  AddToMenu,
  AddToMenuParent : TIMenuItemIntf;
  InsertIndex : integer;
  i  : integer;
begin
  if (csDesigning in ComponentState) then
    Exit;
  if FRoot then
  begin
    for i:=0 to Count-1 do
    begin
      Items[i].FParentIntf:=FParentIntf;
      Items[i].Activate;
    end;
    Exit;
  end;
  if Parent.FRoot then
  begin
    if Assigned(FMenuIntf) then
      Exit;
    MainMenu:=nil;
    MenuItems:=nil;
    AddToMenu:=nil;
    AddToMenuParent:=nil;
    MainMenu:=ToolServices.GetMainMenu;
    if Assigned(MainMenu) then
    try
      MenuItems:=MainMenu.GetMenuItems;
      if Assigned(MenuItems) then
      try
        AddToMenu:=MainMenu.FindMenuItem(Parent.FParentIntf);
        if Assigned(AddToMenu) then
        try
          AddToMenuParent:=AddToMenu.GetParent;
          if Assigned(AddToMenuParent) then
          try
            if not Parent.FMenu.FAppended then
              InsertIndex:=AddToMenu.GetIndex
            else
              InsertIndex:=-1;
            FMenuIntf:=AddToMenuParent.InsertItem(InsertIndex,
                       FCaption,Name,FHint,FShortCut,FHelpContext,
                       FGroupIndex,GetFlags,Click);
            for i:=0 to Count-1 do
              Items[i].Activate;
          finally
            AddToMenuParent.Free;
          end;
        finally
          AddToMenu.Free;
        end;
      finally
        MenuItems.Free;
      end;
    finally;
      MainMenu.Free;
    end
  end else // if Self is not Root Item
    try
      if Assigned(Parent.FMenuIntf) then
      begin
        InsertIndex:=-1;
        FMenuIntf:=Parent.FMenuIntf.InsertItem(InsertIndex,
               FCaption,Name,FHint,FShortCut,FHelpContext,
               FGroupIndex,GetFlags,Click);
        for i:=0 to Count-1 do
          Items[i].Activate;
      end;
    except
    end;
end;

procedure TxdkAddInMenuItem.VerifyGroupIndex(Position: Integer; Value: Byte);
var
  I: Integer;
begin
  for I := 0 to GetCount - 1 do
    if I < Position then
    begin
      if Items[I].GroupIndex > Value then Error(SAddInGroupIndexTooLow)
    end
    else
      if Items[I].GroupIndex < Value then Items[I].FGroupIndex := Value;
end;

procedure TxdkAddInMenuItem.ChangeFlags(const Value: TIMenuFlag; SetFlag: boolean);
var
  Cur : TIMenuFlags;
begin
  if not (csDesigning in ComponentState)
    and not (csLoading in ComponentState) then
  begin
    if Assigned(FMenuIntf) and not FRoot then
    begin
      Cur:=FMenuIntf.GetFlags;
      if SetFlag and not (Value in Cur) then
      begin
        Cur:=Cur+[Value];
        FMenuIntf.SetFlags(AllFlags,Cur);
      end else
        if not SetFlag and (Value in Cur) then
        begin
          Cur:=Cur-[Value];
          FMenuIntf.SetFlags(AllFlags,Cur);
        end;
    end;
  end;
end;

function TxdkAddInMenuItem.HasParent: Boolean;
begin
  Result := True;
end;

procedure TxdkAddInMenuItem.SetCaption(const Value: string);
begin
  if FCaption<>Value then
  begin
    if not (csDesigning in ComponentState)
      and not (csLoading in ComponentState) then
    begin
      if Assigned(FMenuIntf) then
      begin
        if FMenuIntf.SetCaption(Value) then
          FCaption:=Value;
      end;
    end else
      FCaption:=Value;
  end;
end;

procedure TxdkAddInMenuItem.TurnSiblingsOff;
var
  I: Integer;
  Item: TxdkAddInMenuItem;
begin
  if FParent <> nil then
    for I := 0 to FParent.Count - 1 do
    begin
      Item := FParent[I];
      if (Item <> Self) and Item.FRadioItem and (Item.GroupIndex = GroupIndex) then
        Item.SetChecked(False);
    end;
end;

procedure TxdkAddInMenuItem.SetChecked(Value: Boolean);

begin
  if FChecked<>Value then
  begin
    FChecked:=Value;
    if FParent<>nil then
      ChangeFlags(mfChecked,Value);
    if Value and FRadioItem then
      TurnSiblingsOff;
  end;
end;

procedure TxdkAddInMenuItem.SetEnabled(Value: Boolean);
begin
  if FEnabled <> Value then
  begin
    FEnabled := Value;
    if FParent <> nil then
      ChangeFlags(mfEnabled,Value);
  end;
end;

procedure TxdkAddInMenuItem.SetGroupIndex(Value: Byte);
begin
  if FGroupIndex <> Value then
  begin
    if Parent <> nil then Parent.VerifyGroupIndex(Parent.IndexOf(Self), Value);
    FGroupIndex := Value;
    if FChecked and FRadioItem then
      TurnSiblingsOff;
  end;
end;

function TxdkAddInMenuItem.GetCount: Integer;
begin
  if FItems = nil then Result := 0
  else Result := FItems.Count;
end;

function TxdkAddInMenuItem.GetItem(Index: Integer): TxdkAddInMenuItem;
begin
  if FItems = nil then IndexError;
  Result := FItems[Index];
end;

procedure TxdkAddInMenuItem.SetShortCut(Value: TShortCut);
begin
  if FShortCut<>Value then
    FShortCut:=Value;
end;

procedure TxdkAddInMenuItem.SetVisible(Value: Boolean);
begin
  if FVisible <> Value then
  begin
    FVisible := Value;
    if FParent <> nil then
      ChangeFlags(mfVisible,Value);
  end;
end;

procedure TxdkAddInMenuItem.SetHelpContext(Value: THelpContext);
begin
  if FHelpContext <> Value then
  begin
    if not (csDesigning in ComponentState)
      and not (csLoading in ComponentState) then
    begin
      if Assigned(FMenuIntf) then
      begin
        if FMenuIntf.SetContext(Value) then
          FHelpContext:=Value;
      end;
    end else
      FHelpContext:=Value;
  end;
end;

procedure TxdkAddInMenuItem.SetBreak(Value: Boolean);
begin
  if FBreak <> Value then
  begin
    FBreak := Value;
    if FParent <> nil then
      ChangeFlags(mfBreak,Value);
  end;
end;

procedure TxdkAddInMenuItem.SetBarBreak(Value: Boolean);
begin
  if FBarBreak <> Value then
  begin
    FBarBreak := Value;
    if FParent <> nil then
      ChangeFlags(mfBarBreak,Value);
  end;
end;

function TxdkAddInMenuItem.GetMenuIndex: Integer;
begin
  Result := -1;
  if FParent <> nil then Result := FParent.IndexOf(Self);
end;

procedure TxdkAddInMenuItem.SetMenuIndex(Value: Integer);
var
  Parent: TxdkAddInMenuItem;
  Count: Integer;
begin
  if FParent <> nil then
  begin
    Count := FParent.Count;
    if Value < 0 then Value := 0;
    if Value >= Count then Value := Count - 1;
    if Value <> MenuIndex then
    begin
      Parent := FParent;
      Parent.Remove(Self);
      Parent.Insert(Value, Self);
    end;
  end;
end;

procedure TxdkAddInMenuItem.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
  I: Integer;
begin
  for I := 0 to Count - 1 do Proc(Items[I]);
end;

procedure TxdkAddInMenuItem.SetChildOrder(Child: TComponent; Order: Integer);
begin
  (Child as TxdkAddInMenuItem).MenuIndex := Order;
end;

procedure TxdkAddInMenuItem.Insert(Index: Integer; Item: TxdkAddInMenuItem);
begin
  if Item.FParent <> nil then
    raise ExdkAddInMenuError.Create(sAddInReinserted);
  if FItems = nil then FItems := TList.Create;
  if (Index - 1 >= 0) and (Index - 1 < FItems.Count) then
    if Item.GroupIndex < TxdkAddInMenuItem(FItems[Index - 1]).GroupIndex then
      Item.GroupIndex := TxdkAddInMenuItem(FItems[Index - 1]).GroupIndex;
  VerifyGroupIndex(Index, Item.GroupIndex);
  FItems.Insert(Index, Item);
  Item.FParent := Self;
end;

procedure TxdkAddInMenuItem.Delete(Index: Integer);
var
  Cur: TxdkAddInMenuItem;
begin
  if (Index < 0) or (FItems = nil) or (Index >= GetCount) then IndexError;
  Cur := FItems[Index];
  FItems.Delete(Index);
  Cur.FParent := nil;
end;

function TxdkAddInMenuItem.IndexOf(Item: TxdkAddInMenuItem): Integer;
begin
  Result := -1;
  if FItems <> nil then Result := FItems.IndexOf(Item);
end;

procedure TxdkAddInMenuItem.Add(Item: TxdkAddInMenuItem);
begin
  Insert(GetCount, Item);
end;

procedure TxdkAddInMenuItem.Remove(Item: TxdkAddInMenuItem);
var
  I: Integer;
begin
  I := IndexOf(Item);
  if I = -1 then raise ExdkAddInMenuError.Create(sAddInNotFound);
  Delete(I);
end;

function TxdkAddInMenuItem.GetParentComponent: TComponent;
begin
  if (FParent <> nil) and (FParent.FMenu <> nil) then
    Result := FParent.FMenu else
    Result := FParent;
end;

procedure TxdkAddInMenuItem.SetParentComponent(Value: TComponent);
begin
  if FParent <> nil then FParent.Remove(Self);
  if Value <> nil then
    if Value is TxdkAddInMenu then
      TxdkAddInMenu(Value).Items.Add(Self)
    else if Value is TxdkAddInMenuItem then
      TxdkAddInMenuItem(Value).Add(Self);
end;

procedure TxdkAddInMenuItem.SetRadioItem(Value: Boolean);
begin
  if FRadioItem <> Value then
  begin
    FRadioItem := Value;
    ChangeFlags(mfRadioItem,Value);
    if FChecked and FRadioItem then
      TurnSiblingsOff;
  end;
end;

procedure TxdkAddInMenuItem.Click(Sender:TIMenuItemIntf);
begin
  if (Count=0) and FEnabled and Assigned(FOnClick)then
    FOnClick(Self);
end;

//=========================================================
// TxdkAddInMenu

constructor TxdkAddInMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FItems := TxdkAddInMenuItem.Create(Self);
  FItems.FMenu := Self;
  FItems.FRoot:=True;
end;

destructor TxdkAddInMenu.Destroy;
begin
  FItems.Free;
  inherited Destroy;
end;

procedure TxdkAddInMenu.Loaded;
begin
  inherited Loaded;
  if FIDEMenuItem<>EmptyStr then
  begin
    FItems.FParentIntf:=FIDEMenuItem;
    if not (csDesigning in ComponentState) then
      FItems.Activate;
  end;
end;

procedure TxdkAddInMenu.GetChildren(Proc: TGetChildProc; Root: TComponent);
begin
  FItems.GetChildren(Proc, Root);
end;

procedure TxdkAddInMenu.SetChildOrder(Child: TComponent; Order: Integer);
begin
  FItems.SetChildOrder(Child, Order);
end;

procedure TxdkAddInMenu.SetIDEMenuItem(Value:string);
begin
  if Value<>FIDEMenuItem then
    FIDEMenuItem:=Value;        //  ?!
end;

//====================================================

function xdkAddInNewMenuItem(AOwner:TComponent; AName:string):TxdkAddInMenuItem;
begin
  Result:=TxdkAddInMenuItem.Create(AOwner);
  Result.Name:=AName;
end;

initialization
  RegisterClasses([TxdkAddInMenuItem]);
end.