SEQMENU

Top  Previous  Next

{ TSecretMenu:

Cél: Egy titkositással védett főmenü rendszer -> SequreCode

A menüpontok (TSequreMenuitem) uj property-t kapnak -> SequreCode;

Csak az a menüpont aktiv, melynek a -> SequreCod értéke kisebb vagy egyenlő a

menürendszerre megadott globális -> GlobalSequreCode - nál

 

pl: Egy főmenüben a GlobalSequreCode = 3, akkor csak azok a menüelemek

    aktivak, melyeknek SequreCode-ja kisebb vagy egyenlő 3-nál;

}

 

 

{*******************************************************}

{                                                       }

{       Delphi Visual Component Library                 }

{                                                       }

{       Copyright (c) 1995,97 Borland International     }

{                                                       }

{*******************************************************}

 

unit SeqMenu;

 

{$S-,W-,R-}

{$C PRELOAD}

 

interface

 

uses WinTypes, WinProcs, SysUtils, Classes, Messages;

 

const

scShift = $2000;

scCtrl = $4000;

scAlt = $8000;

scNone = 0;

 

type

EMenuError = class(Exception);

TSQMenu = class;

TMenuBreak = (mbNone, mbBreak, mbBarBreak);

TShortCut = Low(Word)..High(Word);

TMenuChangeEvent = procedure (Sender: TObject; Rebuild: Boolean) of object;

TSQMenuitem = class(TComponent)

private

  FCaption: string;

  FHandle: HMENU;

  FChecked: Boolean;

  FEnabled: Boolean;

  FDefault: Boolean;

  FRadioItem: Boolean;

  FVisible: Boolean;

  FGroupIndex: Byte;

  FBreak: TMenuBreak;

  FCommand: Word;

  FHelpContext: THelpContext;

  FHint: string;

  FItems: TList;

  FShortCut: TShortCut;

  FParent: TSQMenuitem;

  FMerged: TSQMenuitem;

  FMergedWith: TSQMenuitem;

  FMenu: TSQMenu;

  FOnChange: TMenuChangeEvent;

  FOnClick: TNotifyEvent;

  procedure AppendTo(Menu: HMENU);

  procedure ClearHandles;

  procedure ReadShortCutText(Reader: TReader);

  procedure MergeWith(Menu: TSQMenuitem);

  procedure RebuildHandle;

  procedure PopulateMenu;

  procedure SubItemChanged(Sender: TObject; Rebuild: Boolean);

  procedure TurnSiblingsOff;

  procedure WriteShortCutText(Writer: TWriter);

  procedure VerifyGroupIndex(Position: Integer; Value: Byte);

protected

  procedure DefineProperties(Filer: TFiler); override;

  function GetHandle: HMENU;

  function GetCount: Integer;

{    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;}

  function GetItem(Index: Integer): TSQMenuitem;

  function GetMenuIndex: Integer;

  function GetParentComponent: TComponent;

  procedure MenuChanged(Rebuild: Boolean); virtual;

  function HasParent: Boolean; override;

  procedure SetBreak(Value: TMenuBreak);

  procedure SetCaption(const Value: string);

  procedure SetChecked(Value: Boolean);

{    procedure SetChildOrder(Child: TComponent; Order: Integer); override;}

  procedure SetDefault(Value: Boolean);

  procedure SetEnabled(Value: Boolean);

  procedure SetGroupIndex(Value: Byte);

  procedure SetMenuIndex(Value: Integer);

  procedure SetParentComponent(Value: TComponent);

  procedure SetRadioItem(Value: Boolean);

  procedure SetShortCut(Value: TShortCut);

  procedure SetVisible(Value: Boolean);

public

  constructor Create(AOwner: TComponent); override;

  destructor Destroy; override;

  procedure Insert(Index: Integer; Item: TSQMenuitem);

  procedure Delete(Index: Integer);

  procedure Click; virtual;

  function IndexOf(Item: TSQMenuitem): Integer;

  procedure Add(Item: TSQMenuitem);

  procedure Remove(Item: TSQMenuitem);

  property Command: Word read FCommand;

  property Handle: HMENU read GetHandle;

  property Count: Integer read GetCount;

  property Items[Index: Integer]: TSQMenuitem read GetItem; default;

  property MenuIndex: Integer read GetMenuIndex write SetMenuIndex;

  property Parent: TSQMenuitem read FParent;

published

  property Break: TMenuBreak read FBreak write SetBreak default mbNone;

  property Caption: string read FCaption write SetCaption;

  property Checked: Boolean read FChecked write SetChecked default False;

  property Default: Boolean read FDefault write SetDefault default False;

  property Enabled: Boolean read FEnabled write SetEnabled default True;

  property GroupIndex: Byte read FGroupIndex write SetGroupIndex default 0;

  property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;

  property Hint: string read FHint write FHint;

  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 OnClick: TNotifyEvent read FOnClick write FOnClick;

end;

 

TFindItemKind = (fkCommand, fkHandle, fkShortCut);

 

TSQMenu = class(TComponent)

private

  FItems: TSQMenuitem;

  FWindowHandle: HWND;

  FMenuImage: string;

  procedure MenuChanged(Sender: TObject; Rebuild: Boolean); virtual;

  procedure SetWindowHandle(Value: HWND);

  function UpdateImage: Boolean;

protected

{    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;}

  function GetHandle: HMENU; virtual;

{    procedure SetChildOrder(Child: TComponent; Order: Integer); override;}

public

  constructor Create(AOwner: TComponent); override;

  destructor Destroy; override;

  function DispatchCommand(ACommand: Word): Boolean;

  function DispatchPopup(AHandle: HMENU): Boolean;

  function FindItem(Value: Integer; Kind: TFindItemKind): TSQMenuitem;

  function GetHelpContext(Value: Integer; ByCommand: Boolean): THelpContext;

  function IsShortCut(var Message: TWMKey): Boolean;

  property Handle: HMENU read GetHandle;

  property WindowHandle: HWND read FWindowHandle write SetWindowHandle;

published

  property Items: TSQMenuitem read FItems;

end;

 

TSecretMenu = class(TSQMenu)

private

  FOle2Menu: HMENU;

  FAutoMerge: Boolean;

  procedure ItemChanged;

  procedure MenuChanged(Sender: TObject; Rebuild: Boolean); override;

  procedure SetAutoMerge(Value: Boolean);

protected

  function GetHandle: HMENU; override;

public

  procedure Merge(Menu: TSecretMenu);

  procedure Unmerge(Menu: TSecretMenu);

  procedure PopulateOle2Menu(SharedMenu: HMenu; Groups: array of Integer;

    var Widths: array of Longint);

{    procedure GetOle2AcceleratorTable(var AccelTable: HAccel;

    var AccelCount: Integer; Groups: array of Integer);}

  procedure SetOle2MenuHandle(Handle: HMENU);

published

  property AutoMerge: Boolean read FAutoMerge write SetAutoMerge default False;

end;

 

TPopupAlignment = (paLeft, paRight, paCenter);

 

TSecretPopupMenu = class(TSQMenu)

private

  FAlignment: TPopupAlignment;

  FAutoPopup: Boolean;

  FPopupComponent: TComponent;

  FOnPopup: TNotifyEvent;

  procedure DoPopup(Item: TObject);

  function GetHelpContext: THelpContext;

  procedure SetHelpContext(Value: THelpContext);

public

  constructor Create(AOwner: TComponent); override;

  destructor Destroy; override;

  procedure Popup(X, Y: Integer); virtual;

  property PopupComponent: TComponent read FPopupComponent write FPopupComponent;

published

  property Alignment: TPopupAlignment read FAlignment write FAlignment default paLeft;

  property AutoPopup: Boolean read FAutoPopup write FAutoPopup default True;

  property HelpContext: THelpContext read GetHelpContext write SetHelpContext default 0;

  property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;

end;

 

function ShortCut(Key: Word; Shift: TShiftState): TShortCut;

procedure ShortCutToKey(ShortCut: TShortCut; var Key: Word; var Shift: TShiftState);

function ShortCutToText(ShortCut: TShortCut): string;

function TextToShortCut(Text: string): TShortCut;

 

function NewMenu(Owner: TComponent; const AName: string; Items: array of TSQMenuitem): TSecretMenu;

function NewPopupMenu(Owner: TComponent; const AName: string;

Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TSQMenuitem): TSecretPopupMenu;

function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string;

Items: array of TSQMenuitem): TSQMenuitem;

function NewItem(const ACaption: string; AShortCut: TShortCut;

AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;

const AName: string): TSQMenuitem;

function NewLine: TSQMenuitem;

 

procedure Register;

 

implementation

 

uses Controls, Forms, Consts;

 

procedure Register;

begin

   RegisterComponents('AL',[TSecretMenu]);

end;

 

procedure Error(const S: string);

begin

raise EMenuError.Create(S);

end;

 

procedure IndexError;

begin

Error('Téves menü index!');

end;

 

{ TShortCut processing routines }

 

function ShortCut(Key: Word; Shift: TShiftState): TShortCut;

begin

Result := 0;

if WordRec(Key).Hi <> 0 then Exit;

Result := Key;

if ssShift in Shift then Inc(Result, scShift);

if ssCtrl in Shift then Inc(Result, scCtrl);

if ssAlt in Shift then Inc(Result, scAlt);

end;

 

procedure ShortCutToKey(ShortCut: TShortCut; var Key: Word; var Shift: TShiftState);

begin

Key := ShortCut and not (scShift + scCtrl + scAlt);

Shift := [];

if ShortCut and scShift <> 0 then Include(Shift, ssShift);

if ShortCut and scCtrl <> 0 then Include(Shift, ssCtrl);

if ShortCut and scAlt <> 0 then Include(Shift, ssAlt);

end;

 

type

TMenuKeyCap = (mkcBkSp, mkcTab, mkcEsc, mkcEnter, mkcSpace, mkcPgUp,

  mkcPgDn, mkcEnd, mkcHome, mkcLeft, mkcUp, mkcRight, mkcDown, mkcIns,

  mkcDel, mkcShift, mkcCtrl, mkcAlt);

 

const

MenuKeyCaps: array[TMenuKeyCap] of string = (

  'SmkcBkSp', 'SmkcTab', 'SmkcEsc', 'SmkcEnter', 'SmkcSpace', 'SmkcPgUp',

  'SmkcPgDn', 'SmkcEnd', 'SmkcHome', 'SmkcLeft', 'SmkcUp', 'SmkcRight',

  'SmkcDown', 'SmkcIns', 'SmkcDel', 'SmkcShift', 'SmkcCtrl', 'SmkcAlt');

 

function GetSpecialName(ShortCut: TShortCut): string;

var

ScanCode: Integer;

KeyName: array[0..255] of Char;

begin

Result := '';

ScanCode := MapVirtualKey(WordRec(ShortCut).Lo, 0) shl 16;

if ScanCode <> 0 then

begin

  GetKeyNameText(ScanCode, KeyName, SizeOf(KeyName));

  if (KeyName[1] = #0) and (KeyName[0] <> #0) then

    GetSpecialName := StrPas( KeyName );

end;

end;

 

function ShortCutToText(ShortCut: TShortCut): string;

var

Name: string;

begin

case WordRec(ShortCut).Lo of

  $08, $09:

    Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcBkSp) + WordRec(ShortCut).Lo - $08)];

  $0D: Name := MenuKeyCaps[mkcEnter];

  $1B: Name := MenuKeyCaps[mkcEsc];

  $20..$28:

    Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcSpace) + WordRec(ShortCut).Lo - $20)];

  $2D..$2E:

    Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcIns) + WordRec(ShortCut).Lo - $2D)];

  $30..$39: Name := Chr(WordRec(ShortCut).Lo - $30 + Ord('0'));

  $41..$5A: Name := Chr(WordRec(ShortCut).Lo - $41 + Ord('A'));

  $60..$69: Name := Chr(WordRec(ShortCut).Lo - $60 + Ord('0'));

  $70..$87: Name := 'F' + IntToStr(WordRec(ShortCut).Lo - $6F);

else

  Name := GetSpecialName(ShortCut);

end;

if Name <> '' then

begin

  Result := '';

  if ShortCut and scShift <> 0 then Result := Result + MenuKeyCaps[mkcShift];

  if ShortCut and scCtrl <> 0 then Result := Result + MenuKeyCaps[mkcCtrl];

  if ShortCut and scAlt <> 0 then Result := Result + MenuKeyCaps[mkcAlt];

  Result := Result + Name;

end

else Result := '';

end;

 

{ This function is *very* slow.  Use sparingly.  Return 0 if no VK code was

found for the text }

 

function TextToShortCut(Text: string): TShortCut;

 

{ If the front of Text is equal to Front then remove the matching piece

  from Text and return True, otherwise return False }

 

function CompareFront(var Text: string; const Front: string): Boolean;

begin

  Result := False;

  if (Length(Text) >= Length(Front)) and

    (AnsiStrLIComp(PChar(Text), PChar(Front), Length(Front)) = 0) then

  begin

    Result := True;

    Delete(Text, 1, Length(Front));

  end;

end;

 

var

Key: TShortCut;

Shift: TShortCut;

begin

Result := 0;

Shift := 0;

while True do

begin

  if CompareFront(Text, MenuKeyCaps[mkcShift]) then Shift := Shift or scShift

  else if CompareFront(Text, '^') then Shift := Shift or scCtrl

  else if CompareFront(Text, MenuKeyCaps[mkcCtrl]) then Shift := Shift or scCtrl

  else if CompareFront(Text, MenuKeyCaps[mkcAlt]) then Shift := Shift or scAlt

  else Break;

end;

if Text = '' then Exit;

for Key := $08 to $255 do { Copy range from table in ShortCutToText }

  if AnsiCompareText(Text, ShortCutToText(Key)) = 0 then

  begin

    Result := Key or Shift;

    Exit;

  end;

end;

 

{ Menu command managment }

 

var

CommandPool: TBits;

 

function UniqueCommand: Word;

begin

Result := CommandPool.OpenBit;

CommandPool[Result] := True;

end;

 

{ Used to populate or merge menus }

 

procedure IterateMenus(Func: Pointer; Menu1, Menu2: TSQMenuitem);

var

I, J: Integer;

IIndex, JIndex: Byte;

Menu1Size, Menu2Size: Integer;

Done: Boolean;

 

function Iterate(var I: Integer; TSQMenuitem: TSQMenuitem; AFunc: Pointer): Boolean;

var

  Item: TSQMenuitem;

begin

  if TSQMenuitem = nil then Exit;

  Result := False;

  while not Result and (I < TSQMenuitem.Count) do

  begin

    Item := TSQMenuitem[I];

    if Item.GroupIndex > IIndex then Break;

    asm

              MOV     EAX,Item

              MOV     EDX,[EBP+8]

              PUSH    DWORD PTR [EDX]

              CALL    DWORD PTR AFunc

              ADD     ESP,4

              MOV     Result,AL

    end;

    Inc(I);

  end;

end;

 

begin

I := 0;

J := 0;

Menu1Size := 0;

Menu2Size := 0;

if Menu1 <> nil then Menu1Size := Menu1.Count;

if Menu2 <> nil then Menu2Size := Menu2.Count;

Done := False;

while not Done and ((I < Menu1Size) or (J < Menu2Size)) do

begin

  IIndex := High(Byte);

  JIndex := High(Byte);

  if (I < Menu1Size) then IIndex := Menu1[I].GroupIndex;

  if (J < Menu2Size) then JIndex := Menu2[J].GroupIndex;

  if IIndex <= JIndex then Done := Iterate(I, Menu1, Func)

  else

  begin

    IIndex := JIndex;

    Done := Iterate(J, Menu2, Func);

  end;

  while (I < Menu1Size) and (Menu1[I].GroupIndex <= IIndex) do Inc(I);

  while (J < Menu2Size) and (Menu2[J].GroupIndex <= IIndex) do Inc(J);

end;

end;

 

{ TSQMenuitem }

 

constructor TSQMenuitem.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FVisible := True;

FEnabled := True;

FCommand := UniqueCommand;

end;

 

destructor TSQMenuitem.Destroy;

begin

if FParent <> nil then

begin

  FParent.Remove(Self);

  FParent := nil;

end;

if FHandle <> 0 then

begin

  MergeWith(nil);

  DestroyMenu(FHandle);

  ClearHandles;

end;

while Count > 0 do Items[0].Free;

FItems.Free;

if FCommand <> 0 then CommandPool[FCommand] := False;

inherited Destroy;

end;

 

procedure TSQMenuitem.ClearHandles;

 

procedure Clear(Item: TSQMenuitem);

var

  I: Integer;

begin

  with Item do

  begin

    FHandle := 0;

    for I := 0 to GetCount - 1 do Clear(FItems[I]);

  end;

end;

 

begin

Clear(Self);

end;

 

const

Checks: array[Boolean] of LongInt = (MF_UNCHECKED, MF_CHECKED);

Enables: array[Boolean] of LongInt = (MF_DISABLED or MF_GRAYED, MF_ENABLED);

Breaks: array[TMenuBreak] of Longint = (0, MF_MENUBREAK, MF_MENUBARBREAK);

Separators: array[Boolean] of LongInt = (MF_STRING, MF_SEPARATOR);

 

procedure TSQMenuitem.AppendTo(Menu: HMENU);

const

IBreaks: array[TMenuBreak] of Longint = (MFT_STRING, MFT_MENUBREAK, MFT_MENUBARBREAK);

IChecks: array[Boolean] of Longint = (MFS_UNCHECKED, MFS_CHECKED);

IDefaults: array[Boolean] of Longint = (0, MFS_DEFAULT);

IEnables: array[Boolean] of Longint = (MFS_DISABLED or MFS_GRAYED, MFS_ENABLED);

IRadios: array[Boolean] of Longint = (MFT_STRING, MFT_RADIOCHECK);

ISeparators: array[Boolean] of Longint = (MFT_STRING, MFT_SEPARATOR);

var

TSQMenuitemInfo: TSQMenuitemInfo;

Caption: string;

NewFlags: Integer;

begin

if FVisible then

begin

  Caption := FCaption;

  if GetCount > 0 then TSQMenuitemInfo.hSubMenu := GetHandle

  else if (FShortCut <> scNone) and ((Parent = nil) or

    (Parent.Parent <> nil) or not (Parent.Owner is TSecretMenu)) then

    Caption := Caption + #9 + ShortCutToText(FShortCut);

  if Lo(GetVersion) >= 4 then

  begin

    TSQMenuitemInfo.cbSize := SizeOf(TSQMenuitemInfo);

    TSQMenuitemInfo.fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or

      MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;

    TSQMenuitemInfo.fType := IRadios[FRadioItem] or IBreaks[FBreak] or

      ISeparators[FCaption = '-'];

    TSQMenuitemInfo.fState := IChecks[FChecked] or IEnables[FEnabled]

      or IDefaults[FDefault];

    TSQMenuitemInfo.wID := Command;

    TSQMenuitemInfo.hSubMenu := 0;

    TSQMenuitemInfo.hbmpChecked := 0;

    TSQMenuitemInfo.hbmpUnchecked := 0;

    TSQMenuitemInfo.dwTypeData := PChar(Caption);

    if GetCount > 0 then TSQMenuitemInfo.hSubMenu := GetHandle;

    InserTSQMenuitem(Menu, -1, True, TSQMenuitemInfo);

  end

  else

  begin

    NewFlags := Breaks[FBreak] or Checks[FChecked] or Enables[FEnabled] or

      Separators[FCaption = '-'] or MF_BYPOSITION;

    if GetCount > 0 then

      InsertMenu(Menu, -1, MF_POPUP or NewFlags, GetHandle,

        PChar(FCaption))

    else

      InsertMenu(Menu, -1, NewFlags, Command, PChar(Caption));

  end;

end;

end;

 

procedure TSQMenuitem.PopulateMenu;

 

function AddIn(TSQMenuitem: TSQMenuitem): Boolean;

begin

  TSQMenuitem.AppendTo(FHandle);

  Result := False;

end;

 

begin

IterateMenus(@AddIn, FMerged, Self);

end;

 

procedure TSQMenuitem.ReadShortCutText(Reader: TReader);

begin

ShortCut := TextToShortCut(Reader.ReadString);

end;

 

procedure TSQMenuitem.MergeWith(Menu: TSQMenuitem);

begin

if FMerged <> Menu then

begin

  if FMerged <> nil then FMerged.FMergedWith := nil;

  FMerged := Menu;

  if FMerged <> nil then FMerged.FMergedWith := Self;

  RebuildHandle;

end;

end;

 

procedure TSQMenuitem.RebuildHandle;

begin

if FMergedWith <> nil then

  FMergedWith.RebuildHandle

else

begin

  while GeTSQMenuitemCount(Handle) > 0 do RemoveMenu(Handle, 0, MF_BYPOSITION);

  PopulateMenu;

  MenuChanged(False);

end;

end;

 

procedure TSQMenuitem.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(SGroupIndexTooLow)

  end

  else

    { Ripple change to menu items at Position and after }

    if Items[I].GroupIndex < Value then Items[I].FGroupIndex := Value;

end;

 

procedure TSQMenuitem.WriteShortCutText(Writer: TWriter);

begin

{Writer.WriteString(ShortCutToText(ShortCut));}

end;

 

function TSQMenuitem.GetHandle: HMENU;

begin

if FHandle = 0 then

begin

  if Owner is TSecretPopupMenu then

    FHandle := CreatePopupMenu

  else

    FHandle := CreateMenu;

  if FHandle = 0 then raise EMenuError.Create(SOutOfResources);

  PopulateMenu;

end;

Result := FHandle;

end;

 

procedure TSQMenuitem.DefineProperties(Filer: TFiler);

begin

inherited DefineProperties(Filer);

Filer.DefineProperty('ShortCutText', ReadShortCutText, WriteShortCutText, False);

end;

 

function TSQMenuitem.HasParent: Boolean;

begin

Result := True;

end;

 

procedure TSQMenuitem.SetBreak(Value: TMenuBreak);

begin

if FBreak <> Value then

begin

  FBreak := Value;

  MenuChanged(True);

end;

end;

 

procedure TSQMenuitem.SetCaption(const Value: string);

begin

if FCaption <> Value then

begin

  FCaption := Value;

  MenuChanged(True);

end;

end;

 

procedure TSQMenuitem.TurnSiblingsOff;

var

I: Integer;

Item: TSQMenuitem;

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 TSQMenuitem.SetChecked(Value: Boolean);

 

begin

if FChecked <> Value then

begin

  FChecked := Value;

  if FParent <> nil then

    CheckTSQMenuitem(FParent.Handle, FCommand, MF_BYCOMMAND or Checks[Value]);

  if Value and FRadioItem then

    TurnSiblingsOff;

end;

end;

 

procedure TSQMenuitem.SetEnabled(Value: Boolean);

begin

if FEnabled <> Value then

begin

  FEnabled := Value;

  if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Count <> 0)) or

    ((Parent <> nil) and Assigned(Parent.FMergedWith)) then

    MenuChanged(True)

  else

  begin

    if FParent <> nil then

      EnableTSQMenuitem(FParent.Handle, FCommand, MF_BYCOMMAND or Enables[Value]);

    MenuChanged(False);

  end;

end;

end;

 

procedure TSQMenuitem.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 TSQMenuitem.GetCount: Integer;

begin

if FItems = nil then Result := 0

else Result := FItems.Count;

end;

 

function TSQMenuitem.GetItem(Index: Integer): TSQMenuitem;

begin

if FItems = nil then IndexError;

Result := FItems[Index];

end;

 

procedure TSQMenuitem.SetShortCut(Value: TShortCut);

begin

FShortCut := Value;

MenuChanged(True);

end;

 

procedure TSQMenuitem.SetVisible(Value: Boolean);

begin

FVisible := Value;

MenuChanged(True);

end;

 

function TSQMenuitem.GetMenuIndex: Integer;

begin

Result := -1;

if FParent <> nil then Result := FParent.IndexOf(Self);

end;

 

procedure TSQMenuitem.SetMenuIndex(Value: Integer);

var

Parent: TSQMenuitem;

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 TSQMenuitem.GetChildren(Proc: TGetChildProc; Root: TComponent);

var

I: Integer;

begin

for I := 0 to Count - 1 do Proc(Items[I]);

end;}

 

{procedure TSQMenuitem.SetChildOrder(Child: TComponent; Order: Integer);

begin

(Child as TSQMenuitem).MenuIndex := Order;

end;}NN

 

procedure TSQMenuitem.SetDefault(Value: Boolean);

var

I: Integer;

begin

if FDefault <> Value then

begin

  if Value and (FParent <> nil) then

    for I := 0 to FParent.Count - 1 do

      if FParent[I].Default then FParent[I].FDefault := False;

  FDefault := Value;

  MenuChanged(True);

end;

end;

 

procedure TSQMenuitem.Insert(Index: Integer; Item: TSQMenuitem);

begin

if Item.FParent <> nil then

  raise EMenuError.Create(SMenuReinserted);

if FItems = nil then FItems := TList.Create;

if (Index - 1 >= 0) and (Index - 1 < FItems.Count) then

  if Item.GroupIndex < TSQMenuitem(FItems[Index - 1]).GroupIndex then

    Item.GroupIndex := TSQMenuitem(FItems[Index - 1]).GroupIndex;

VerifyGroupIndex(Index, Item.GroupIndex);

FItems.Insert(Index, Item);

Item.FParent := Self;

Item.FOnChange := SubItemChanged;

if FHandle <> 0 then RebuildHandle;

MenuChanged(Count = 1);

end;

 

procedure TSQMenuitem.Delete(Index: Integer);

var

Cur: TSQMenuitem;

begin

if (Index < 0) or (FItems = nil) or (Index >= GetCount) then IndexError;

Cur := FItems[Index];

FItems.Delete(Index);

Cur.FParent := nil;

Cur.FOnChange := nil;

if FHandle <> 0 then RebuildHandle;

MenuChanged(Count = 0);

end;

 

procedure TSQMenuitem.Click;

begin

if FEnabled and Assigned(FOnClick) then FOnClick(Self);

end;

 

function TSQMenuitem.IndexOf(Item: TSQMenuitem): Integer;

begin

Result := -1;

if FItems <> nil then Result := FItems.IndexOf(Item);

end;

 

procedure TSQMenuitem.Add(Item: TSQMenuitem);

begin

Insert(GetCount, Item);

end;

 

procedure TSQMenuitem.Remove(Item: TSQMenuitem);

var

I: Integer;

begin

I := IndexOf(Item);

if I = -1 then raise EMenuError.Create(SMenuNotFound);

Delete(I);

end;

 

procedure TSQMenuitem.MenuChanged(Rebuild: Boolean);

begin

if Assigned(FOnChange) then FOnChange(Self, Rebuild);

end;

 

procedure TSQMenuitem.SubItemChanged(Sender: TObject; Rebuild: Boolean);

begin

if Rebuild and ((FHandle <> 0) or Assigned(FMergedWith)) then RebuildHandle;

if Parent <> nil then Parent.SubItemChanged(Self, False)

else if Owner is TSecretMenu then TSecretMenu(Owner).ItemChanged;

end;

 

function TSQMenuitem.GetParentComponent: TComponent;

begin

if (FParent <> nil) and (FParent.FMenu <> nil) then

  Result := FParent.FMenu else

  Result := FParent;

end;

 

procedure TSQMenuitem.SetParentComponent(Value: TComponent);

begin

if FParent <> nil then FParent.Remove(Self);

if Value <> nil then

  if Value is TSQMenu then

    TSQMenu(Value).Items.Add(Self)

  else if Value is TSQMenuitem then

    TSQMenuitem(Value).Add(Self);

end;

 

procedure TSQMenuitem.SetRadioItem(Value: Boolean);

begin

if FRadioItem <> Value then

begin

  FRadioItem := Value;

  if FChecked and FRadioItem then

    TurnSiblingsOff;

  MenuChanged(True);

end;

end;

 

{ TSQMenu }

 

constructor TSQMenu.Create(AOwner: TComponent);

begin

FItems := TSQMenuitem.Create(Self);

FItems.FOnChange := MenuChanged;

FItems.FMenu := Self;

inherited Create(AOwner);

end;

 

destructor TSQMenu.Destroy;

begin

FItems.Free;

inherited Destroy;

end;

 

{procedure TSQMenu.GetChildren(Proc: TGetChildProc; Root: TComponent);

begin

FItems.GetChildren(Proc, Root);

end;}

 

function TSQMenu.GetHandle: HMENU;

begin

Result := FItems.GetHandle;

end;

 

{procedure TSQMenu.SetChildOrder(Child: TComponent; Order: Integer);

begin

FItems.SetChildOrder(Child, Order);

end;}

 

function TSQMenu.FindItem(Value: Integer; Kind: TFindItemKind): TSQMenuitem;

var

FoundItem: TSQMenuitem;

 

function Find(Item: TSQMenuitem): Boolean;

var

  I: Integer;

begin

  Result := False;

  if ((Kind = fkCommand) and (Value = Item.Command)) or

    ((Kind = fkHandle) and (Value = Item.FHandle)) or

    ((Kind = fkShortCut) and (Value = Item.ShortCut)) then

  begin

    FoundItem := Item;

    Result := True;

    Exit;

  end

  else

    for I := 0 to Item.GetCount - 1 do

      if Find(Item[I]) then

      begin

        Result := True;

        Exit;

      end;

end;

 

begin

FoundItem := nil;

IterateMenus(@Find, Items.FMerged, Items);

Result := FoundItem;

end;

 

function TSQMenu.GetHelpContext(Value: Integer; ByCommand: Boolean): THelpContext;

var

Item: TSQMenuitem;

Kind: TFindItemKind;

begin

Result := 0;

Kind := fkHandle;

if ByCommand then Kind := fkCommand;

if (Kind = fkHandle) and (Self is TSecretPopupMenu) and

  (TSecretPopupMenu(Self).Handle = Value) then

  Result := TSecretPopupMenu(Self).HelpContext

else

begin

  Item := FindItem(Value, Kind);

  while (Item <> nil) and (Item.FHelpContext = 0) do

    Item := Item.FParent;

  if Item <> nil then Result := Item.FHelpContext;

end;

end;

 

function TSQMenu.DispatchCommand(ACommand: Word): Boolean;

var

Item: TSQMenuitem;

begin

Result := False;

Item := FindItem(ACommand, fkCommand);

if Item <> nil then

begin

  Item.Click;

  Result := True;

end;

end;

 

function TSQMenu.DispatchPopup(AHandle: HMENU): Boolean;

var

Item: TSQMenuitem;

begin

Result := False;

Item := FindItem(AHandle, fkHandle);

if Item <> nil then

begin

  Item.Click;

  Result := True;

end;

end;

 

function TSQMenu.IsShortCut(var Message: TWMKey): Boolean;

type

TClickResult = (crDisabled, crClicked, crShortCutMoved);

const

AltMask = $20000000;

var

ShortCut: TShortCut;

ShortCutItem: TSQMenuitem;

ClickResult: TClickResult;

 

function DoClick(Item: TSQMenuitem): TClickResult;

begin

  Result := crClicked;

  if Item.Parent <> nil then Result := DoClick(Item.Parent);

  if Result = crClicked then

    if Item.Enabled then

      try

        Item.Click;

        if ShortCutItem.ShortCut <> ShortCut then

          Result := crShortCutMoved;

      except

        Application.HandleException(Self);

      end

    else Result := crDisabled;

end;

 

begin

Result := False;

if FWindowHandle <> 0 then

begin

  ShortCut := Byte(Message.CharCode);

  if GetKeyState(VK_SHIFT) < 0 then Inc(ShortCut, scShift);

  if GetKeyState(VK_CONTROL) < 0 then Inc(ShortCut, scCtrl);

  if Message.KeyData and AltMask <> 0 then Inc(ShortCut, scAlt);

  repeat

    ClickResult := crDisabled;

    ShortCutItem := FindItem(ShortCut, fkShortCut);

    if ShortCutItem <> nil then ClickResult := DoClick(ShortCutItem);

  until ClickResult <> crShortCutMoved;

  Result := ShortCutItem <> nil;

end;

end;

 

function TSQMenu.UpdateImage: Boolean;

var

Image: array[0..511] of Char;

 

procedure BuildImage(Menu: HMENU);

var

  P, ImageEnd: PChar;

  I, C: Integer;

  State: Word;

begin

  C := GeTSQMenuitemCount(Menu);

  P := Image;

  ImageEnd := @Image[SizeOf(Image) - 5];

  I := 0;

  while (I < C) and (P < ImageEnd) do

  begin

    GetMenuString(Menu, I, P, ImageEnd - P, MF_BYPOSITION);

    P := StrEnd(P);

    State := GetMenuState(Menu, I, MF_BYPOSITION);

    if State and MF_DISABLED <> 0 then P := StrECopy(P, '$');

    if State and MF_MENUBREAK <> 0 then P := StrECopy(P, '@');

    if State and MF_GRAYED <> 0 then P := StrECopy(P, '#');

    P := StrECopy(P, ';');

    Inc(I);

  end;

end;

 

begin

Result := False;

Image[0] := #0;

if FWindowHandle <> 0 then BuildImage(Handle);

if (FMenuImage = '') or (StrComp(PChar(FMenuImage), Image) <> 0) then

begin

  Result := True;

  FMenuImage := Image;

end;

end;

 

procedure TSQMenu.SetWindowHandle(Value: HWND);

begin

FWindowHandle := Value;

UpdateImage;

end;

 

procedure TSQMenu.MenuChanged(Sender: TObject; Rebuild: Boolean);

begin

end;

 

{ TSecretMenu }

 

procedure TSecretMenu.SetAutoMerge(Value: Boolean);

begin

if FAutoMerge <> Value then

begin

  FAutoMerge := Value;

  if FWindowHandle <> 0 then

    SendMessage(FWindowHandle, CM_MENUCHANGED, 0, 0);

end;

end;

 

procedure TSecretMenu.MenuChanged(Sender: TObject; Rebuild: Boolean);

begin

if (FWindowHandle <> 0) and UpdateImage then DrawMenuBar(FWindowHandle);

end;

 

procedure TSecretMenu.Merge(Menu: TSecretMenu);

begin

if Menu <> nil then

  FItems.MergeWith(Menu.FItems) else

  FItems.MergeWith(nil);

end;

 

procedure TSecretMenu.Unmerge(Menu: TSecretMenu);

begin

if (Menu <> nil) and (FItems.FMerged = Menu.FItems) then

  FItems.MergeWith(nil);

end;

 

procedure TSecretMenu.ItemChanged;

begin

MenuChanged(nil, False);

if FWindowHandle <> 0 then

  SendMessage(FWindowHandle, CM_MENUCHANGED, 0, 0);

end;

 

function TSecretMenu.GetHandle: HMENU;

begin

if FOle2Menu <> 0 then

  Result := FOle2Menu else

  Result := inherited GetHandle;

end;

 

{procedure TSecretMenu.GetOle2AcceleratorTable(var AccelTable: HAccel;

var AccelCount: Integer; Groups: array of Integer);

var

NumAccels: Integer;

AccelList, AccelPtr: PAccel;

 

procedure ProcessAccels(Item: TSQMenuitem);

var

  I: Integer;

  Virt: Byte;

begin

  if Item.ShortCut <> 0 then

    if AccelPtr <> nil then

    begin

      Virt := FNOINVERT or FVIRTKEY;

      if Item.ShortCut and scCtrl <> 0 then Virt := Virt or FCONTROL;

      if Item.ShortCut and scAlt <> 0 then Virt := Virt or FALT;

      if Item.ShortCut and scShift <> 0 then Virt := Virt or FSHIFT;

      AccelPtr^.fVirt := Virt;

      AccelPtr^.key := Item.ShortCut and $FF;

      AccelPtr^.cmd := Item.Command;

      Inc(AccelPtr);

    end else

      Inc(NumAccels)

  else

    for I := 0 to Item.GetCount - 1 do ProcessAccels(Item[I]);

end;

 

function ProcessAccelItems(Item: TSQMenuitem): Boolean;

var

  I: Integer;

begin

  for I := 0 to High(Groups) do

    if Item.GroupIndex = Groups[I] then

    begin

      ProcessAccels(Item);

      Break;

    end;

  Result := False;

end;

 

begin

NumAccels := 0;

AccelPtr := nil;

IterateMenus(@ProcessAccelItems, Items.FMerged, Items);

AccelTable := 0;

if NumAccels <> 0 then

begin

  GetMem(AccelList, NumAccels * SizeOf(TAccel));

  AccelPtr := AccelList;

  IterateMenus(@ProcessAccelItems, Items.FMerged, Items);

  AccelTable := CreateAcceleratorTable(AccelList^, NumAccels);

  FreeMem(AccelList);

end;

AccelCount := NumAccels;

end;}

 

{ Similar to regular TSQMenuitem.PopulateMenus except that it only adds

the specified groups to the menu handle }

 

procedure TSecretMenu.PopulateOle2Menu(SharedMenu: HMenu;

Groups: array of Integer; var Widths: array of Longint);

var

NumGroups: Integer;

J: Integer;

 

function AddOle2(Item: TSQMenuitem): Boolean;

var

  I: Integer;

begin

  for I := 0 to NumGroups do

  begin

    if Item.GroupIndex = Groups[I] then

    begin

      Inc(Widths[Item.GroupIndex]);

      Item.AppendTo(SharedMenu);

    end;

  end;

  Result := False;

end;

 

begin

NumGroups := High(Groups);

for J := 0 to High(Widths) do Widths[J] := 0;

IterateMenus(@AddOle2, Items.FMerged, Items);

end;

 

procedure TSecretMenu.SetOle2MenuHandle(Handle: HMENU);

begin

FOle2Menu := Handle;

ItemChanged;

end;

 

{ TSecretPopupMenu }

 

type

TPopupList = class(TList)

private

  procedure WndProc(var Message: TMessage);

public

  Window: HWND;

  procedure Add(Popup: TSecretPopupMenu);

  procedure Remove(Popup: TSecretPopupMenu);

end;

 

var

PopupList: TPopupList;

 

procedure TPopupList.WndProc(var Message: TMessage);

var

I: Integer;

TSQMenuitem: TSQMenuitem;

FindKind: TFindItemKind;

ContextID: Integer;

begin

try

  case Message.Msg of

    WM_COMMAND:

      for I := 0 to Count - 1 do

        if TSecretPopupMenu(Items[I]).DispatchCommand(Message.wParam) then Exit;

    WM_INITMENUPOPUP:

      for I := 0 to Count - 1 do

        with TWMInitMenuPopup(Message) do

          if TSecretPopupMenu(Items[I]).DispatchPopup(MenuPopup) then Exit;

    WM_MENUSELECT:

      with TWMMenuSelect(Message) do

      begin

        FindKind := fkCommand;

        if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle;

        for I := 0 to Count - 1 do

        begin

          TSQMenuitem := TSecretPopupMenu(Items[I]).FindItem(IDItem, FindKind);

          if TSQMenuitem <> nil then

          begin

            Application.Hint := TSQMenuitem.Hint;

            Exit;

          end;

        end;

        Application.Hint := '';

      end;

    WM_HELP:

      with PHelpInfo(Message.LParam)^ do

      begin

        for I := 0 to Count - 1 do

          if TSecretPopupMenu(Items[I]).Handle = hItemHandle then

          begin

            ContextID := TSQMenu(Items[I]).GetHelpContext(iCtrlID, True);

            if ContextID = 0 then

              ContextID := TSQMenu(Items[I]).GetHelpContext(hItemHandle, False);

            if Screen.ActiveForm = nil then Exit;

            if (biHelp in Screen.ActiveForm.BorderIcons) then

              Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID)

            else

              Application.HelpContext(ContextID);

            Exit;

          end;

      end;

  end;

  with Message do Result := DefWindowProc(Window, Msg, wParam, lParam);

except

  Application.HandleException(Self);

end;

end;

 

procedure TPopupList.Add(Popup: TSecretPopupMenu);

begin

if Count = 0 then Window := AllocateHWnd(WndProc);

inherited Add(Popup);

end;

 

procedure TPopupList.Remove(Popup: TSecretPopupMenu);

begin

inherited Remove(Popup);

if Count = 0 then DeallocateHWnd(Window);

end;

 

constructor TSecretPopupMenu.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FItems.OnClick := DoPopup;

FWindowHandle := Application.Handle;

FAutoPopup := True;

PopupList.Add(Self);

end;

 

destructor TSecretPopupMenu.Destroy;

begin

PopupList.Remove(Self);

inherited Destroy;

end;

 

procedure TSecretPopupMenu.DoPopup(Item: TObject);

begin

if Assigned(FOnPopup) then FOnPopup(Item);

end;

 

function TSecretPopupMenu.GetHelpContext: THelpContext;

begin

Result := FItems.HelpContext;

end;

 

procedure TSecretPopupMenu.SetHelpContext(Value: THelpContext);

begin

FItems.HelpContext := Value;

end;

 

procedure TSecretPopupMenu.Popup(X, Y: Integer);

const

Flags: array[TPopupAlignment] of Word = (TPM_LEFTALIGN, TPM_RIGHTALIGN,

  TPM_CENTERALIGN);

begin

DoPopup(Self);

TrackPopupMenu(FItems.Handle, Flags[FAlignment] or TPM_RIGHTBUTTON, X, Y,

  0 { reserved}, PopupList.Window, nil);

end;

 

{ Menu building functions }

 

procedure IniTSQMenuitems(AMenu: TSQMenu; Items: array of TSQMenuitem);

var

I: Integer;

 

procedure SetOwner(Item: TSQMenuitem);

var

  I: Integer;

begin

  if Item.Owner = nil then AMenu.Owner.InsertComponent(Item);

  for I := 0 to Item.Count - 1 do

    SetOwner(Item[I]);

end;

 

begin

for I := Low(Items) to High(Items) do

begin

  SetOwner(Items[I]);

  AMenu.FItems.Add(Items[I]);

end;

end;

 

function NewMenu(Owner: TComponent; const AName: string; Items: array of TSQMenuitem): TSecretMenu;

begin

Result := TSecretMenu.Create(Owner);

Result.Name := AName;

IniTSQMenuitems(Result, Items);

end;

 

function NewPopupMenu(Owner: TComponent; const AName: string;

Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TSQMenuitem): TSecretPopupMenu;

begin

Result := TSecretPopupMenu.Create(Owner);

Result.Name := AName;

Result.AutoPopup := AutoPopup;

Result.Alignment := Alignment;

IniTSQMenuitems(Result, Items);

end;

 

function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string;

Items: array of TSQMenuitem): TSQMenuitem;

var

I: Integer;

begin

Result := TSQMenuitem.Create(nil);

for I := Low(Items) to High(Items) do

  Result.Add(Items[I]);

Result.Caption := ACaption;

Result.HelpContext := hCtx;

Result.Name := AName;

end;

 

function NewItem(const ACaption: string; AShortCut: TShortCut;

AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;

const AName: string): TSQMenuitem;

begin

Result := TSQMenuitem.Create(nil);

with Result do

begin

  Caption := ACaption;

  ShortCut := AShortCut;

  OnClick := AOnClick;

  HelpContext := hCtx;

  Checked := AChecked;

  Enabled := AEnabled;

  Name := AName;

end;

end;

 

function NewLine: TSQMenuitem;

begin

Result := TSQMenuitem.Create(nil);

Result.Caption := '-';

end;

 

initialization

RegisterClasses([TSQMenuitem]);

CommandPool := TBits.Create;

PopupList := TPopupList.Create;

finalization

PopupList.Free;

CommandPool.Free;

end.