actnmenus.pas

天涯進銷存系統

    property OnMouseUp;
    property OnPaint;
    property OnPopup;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;

{ TCustomMenuItem }

  TMenuEdges = set of TEdgeBorder;

  TCustomMenuItem = class(TCustomActionControl)
  private
    FEdges: TMenuEdges;
    FMenu: TCustomActionMenuBar;
    FMouseSelected: Boolean;
    FShortCutBounds: TRect;
    FCYMenu: Integer;
    procedure SetEdges(const Value: TMenuEdges);
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMTextchanged(var Message: TMessage); message CM_TEXTCHANGED;
  protected
    FNoPrefix: string;
    procedure CalcLayout; override;
    procedure DoDragDrop(DragObject: TObject; X: Integer; Y: Integer); override;
    procedure DrawEdge(Edges: TMenuEdges); virtual;
    procedure DrawSubMenuGlyph; virtual;
    procedure DrawShadowedText(Rect: TRect; Flags: Cardinal; Text: string;
      TextColor, ShadowColor: TColor); override;
    procedure DrawText(var ARect: TRect; var Flags: Cardinal;
      Text: String); override;
    procedure DrawUnusedEdges; virtual;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure Paint; override;
    procedure PositionChanged; override;
    procedure SetSelected(Value: Boolean); override;
    procedure DragOver(Source: TObject; X: Integer; Y: Integer;
      State: TDragState; var Accept: Boolean); override;
    property Menu: TCustomActionMenuBar read FMenu;
    property MouseSelected: Boolean read FMouseSelected;
    property ShortCutBounds: TRect read FShortCutBounds write FShortCutBounds;
  public
    constructor Create(AOwner: TComponent); override;
    procedure CalcBounds; override;
    procedure Click; override;
    destructor Destroy; override;
    procedure Keyed; override;
    procedure DragDrop(Source: TObject; X: Integer; Y: Integer); override;
    property Edges: TMenuEdges read FEdges write SetEdges;
  end;

{ TCustomMenuButton }

  TCustomMenuButton = class(TCustomButtonControl)
  private
    FCloseMenu: Boolean;
    FDoClick: Boolean;
    function GetMenu: TCustomActionMenuBar;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  protected
    procedure BeginAutoDrag; override;
    procedure DoDragDrop(DragObject: TObject; X: Integer; Y: Integer); override;
    procedure DragOver(Source: TObject; X: Integer; Y: Integer;
      State: TDragState; var Accept: Boolean); override;
    procedure DrawText(var ARect: TRect; var Flags: Cardinal; Text: string); override;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X: Integer; Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure Paint; override;
    property Menu: TCustomActionMenuBar read GetMenu;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    procedure Keyed; override;
  end;

{ TCustomAddRemoveItem }

  TCustomAddRemoveItem = class(TCustomMenuItem)
  protected
    function IsActionVisible: Boolean;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure SetEnabled(Value: Boolean); override;
  public
    procedure CalcBounds; override;
  end;

  TMenuItemControlClass = class of TCustomMenuItem;
  TAddRemoveItemClass = class of TCustomAddRemoveItem;
  TMenuButtonControlClass = class of TCustomMenuButton;

type
  TUpdateActnMenusProc = procedure;

var
  MenuItemControlClass: TMenuItemControlClass deprecated;
  MenuAddRemoveItemClass: TAddRemoveItemClass deprecated;
  MenuButtonControlClass: TMenuButtonControlClass deprecated;
  MenuPopupClass: TCustomPopupClass deprecated;
  MenuCustomizePopupClass: TCustomizeActionToolBarClass deprecated;
  UpdateActnMenusProc: TUpdateActnMenusProc;

procedure RegisterActnBarStyle(AStyle: TActionBarStyleEx);
procedure UnRegisterActnBarStyle(AStyle: TActionBarStyleEx);

implementation

uses SysUtils, Dialogs, Consts, MMSystem, GraphUtil,
  CommCtrl, ExtActns, ListActns, ActnColorMaps, ImgList;

function GetHint(Control: TControl): string;
begin
  while Control <> nil do
    if Control.Hint = '' then
      Control := Control.Parent
    else
    begin
      Result := Control.Hint;
      Exit;
    end;
  Result := '';
end;

{ TMenuStack }

constructor TMenuStack.Create(AMenu: TCustomActionMenuBar);
begin
  inherited Create;
  FMenu := AMenu;
end;

function TMenuStack.GetBars(const Index: Integer): TCustomActionMenuBar;
begin
  Result := List[Index];
end;

function TMenuStack.Peek: TCustomActionMenuBar;
begin
  Result := inherited PeekItem;
end;

function TMenuStack.Pop: TCustomActionMenuBar;
begin
  Result := PopItem;
  if csDesigning in FMenu.ComponentState then
    FreeAndNil(Result)
  else
  if Assigned(Result.ActionClient) then
  begin
    Result.ActionClient.ChildActionBar := nil;
    Result.FChildMenu := nil;
    Result.ActionClient := nil;
    if (Count = 1) and not (FMenu is TCustomActionPopupMenu) then
      Peek.FCachedMenu := Result as TCustomActionPopupMenu
    else
      FreeAndNil(Result);
  end;
end;

procedure TMenuStack.Push(Container: TCustomActionMenuBar);
begin
  PushItem(Pointer(Container));
end;

type
  TApplicationClass = class(TApplication);

{ TMenuList }

  TMenuList = class(TList)
  private
    function GetMenu(const Index: Integer): TCustomActionMenuBar;
  protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
  public
    property Menus[const Index: Integer]: TCustomActionMenuBar read GetMenu;
  end;

  TMDIAction = (maActivate, maClose, maRestore, maMinimize);

  TInternalMDIAction = class(TWindowAction)
  private
    FClientItem: TActionClientItem;
    FMenu: TCustomActionMainMenuBar;
    FMDIAction: TMDIAction;
  public
    destructor Destroy; override;
    procedure ExecuteTarget(Target: TObject); override;
    function HandlesTarget(Target: TObject): Boolean; override;
    procedure UpdateTarget(Target: TObject); override;
    property MDIAction: TMDIAction read FMDIAction write FMDIAction;
    property ClientItem: TActionClientItem read FClientItem write FClientItem;
    property Menu: TCustomActionMainMenuBar read FMenu write FMenu;
  end;

{ TMenuList }

function TMenuList.GetMenu(const Index: Integer): TCustomActionMenuBar;
begin
  Result := TCustomActionMenuBar(Items[Index]);
end;

{ TInternalMDIAction }

destructor TInternalMDIAction.Destroy;
begin
  if Assigned(FClientItem) then
    FClientItem.Free;
  inherited;
end;

type
  TCustomFormClass = class(TCustomForm);

procedure TInternalMDIAction.ExecuteTarget(Target: TObject);
begin
  case MDIAction of
    maActivate: SendMessage(GetParent(Form.Handle), WM_MDIACTIVATE, Form.Handle, 0);
    maClose: Form.Close;
    maRestore: SendMessage(GetParent(Form.Handle), WM_MDIRESTORE, Form.Handle, 0);
    maMinimize: Form.Close;
  end;
end;

function TInternalMDIAction.HandlesTarget(Target: TObject): Boolean;
begin
  Result := True;
end;

procedure TInternalMDIAction.UpdateTarget(Target: TObject);
begin
  Enabled := True;
end;

var
  MenuCallWndHook: HHOOK;
  MenuList: TMenuList;
  ActiveMenu: TCustomActionMenuBar;

{ Hook required for Main Menu Support }

function CallWndHook(Code: Integer; WParam: wParam; Msg: PCWPStruct): Longint; stdcall;
begin
  if Code = HC_ACTION then
    case Msg.message of
      WM_ACTIVATE:
        if ActiveMenu is TCustomActionPopupMenu then
          ActiveMenu.CloseMenu;
      WM_SETTINGCHANGE:
        if Assigned(UpdateActnMenusProc) then
          UpdateActnMenusProc;
    end;
  Result := CallNextHookEx(MenuCallWndHook, Code, WParam, Longint(Msg));
end;

procedure AddMenuToList(Menu: TCustomActionMenuBar);
begin
  if MenuList = nil then
    MenuList := TMenuList.Create;
  if Assigned(Menu) and (MenuList.IndexOf(Menu) = -1) then
    MenuList.Add(Menu);
end;

procedure RemoveMenuFromList(Menu: TCustomActionMenuBar);
begin
  if Assigned(MenuList) then
  begin
    MenuList.Remove(Menu);
    if MenuList.Count = 0 then
      FreeAndNil(MenuList);
  end;
end;

procedure TMenuList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  if (Action = lnAdded) and (Count = 1) then
    MenuCallWndHook := SetWindowsHookEx(WH_CALLWNDPROC, @CallWndHook, 0,
      GetCurrentThreadID)
  else if (Action = lnDeleted) and (Count = 0) and (MenuCallWndHook <> 0) then
    begin
      UnHookWindowsHookEx(MenuCallWndHook);
      MenuCallWndHook := 0;
    end;
  inherited Notify(Ptr, Action);
end;

{ TCustomActionMenuBar }

constructor TCustomActionMenuBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAnimationStyle := asDefault;
  EdgeOuter := esNone;
  // Expand delay interval should probably come from the registry (somewhere)
  FExpandDelay := 4000;
  FDefaultFont := True;
  FAnimatePopups := True;
  AddMenuToList(Self);
  FAnimateDuration := 150;
  FUseSystemFont := True;
  Font.Assign(Screen.MenuFont);  
end;

destructor TCustomActionMenuBar.Destroy;
begin
  RemoveMenuFromList(Self);
  if Assigned(FParentMenu) then
    FParentMenu.FChildMenu := nil;
  FreeAndNil(FCachedMenu);
  inherited Destroy;
end;

procedure TCustomActionMenuBar.Animate(Show: Boolean = True);
type
  TAnimationStyle = array[Boolean] of Integer;
var
  Animate: BOOL;
  P: TPoint;
const
  HideShow: array[Boolean] of Integer = (AW_HIDE, 0);
  UnfoldAnimationStyle: TAnimationStyle =
    (AW_VER_POSITIVE or AW_HOR_POSITIVE or AW_SLIDE,
     AW_VER_NEGATIVE or AW_HOR_POSITIVE or AW_SLIDE);
  SlideAnimationStyle: TAnimationStyle =
    (AW_VER_POSITIVE or AW_SLIDE, AW_VER_NEGATIVE or AW_SLIDE);
  FadeAnimationStyle: TAnimationStyle = (AW_BLEND, AW_BLEND);

  procedure DefaultSystemAnimation;
  begin
    SystemParametersInfo(SPI_GETMENUANIMATION, 0, @Animate, 0);
    if Assigned(AnimateWindowProc) and (FParentMenu.FAnimatePopups or
       not Show) and Animate then
    begin
      SystemParametersInfo(SPI_GETMENUFADE, 0, @Animate, 0);
      if Animate then
        AnimateWindowProc(Handle, FAnimateDuration, AW_BLEND or HideShow[Show])
      else
      begin
        P := FParentControl.Parent.ClientToScreen(FParentControl.BoundsRect.TopLeft);
        AnimateWindowProc(Handle, FAnimateDuration, UnfoldAnimationStyle[Top < P.Y - 5] or
          HideShow[Show]);
      end;
    end;
  end;

  procedure DoAnimation(Style: TAnimationStyle);
  begin
    if Assigned(AnimateWindowProc) and FParentMenu.FAnimatePopups or not Show then
    begin
      P := FParentControl.ClientToScreen(Point(FParentControl.Left, FParentControl.Top));
      if (FAnimationStyle = asSlide) and not Show then exit;
      if FParentControl is TCustomMenuItem then
        P := Point(FParentControl.Left + FParentControl.Parent.Left,
          FParentControl.Top + FParentControl.Parent.Top)
      else
        P := FParentControl.Parent.ClientToScreen(FParentControl.BoundsRect.TopLeft);
      AnimateWindowProc(Handle, FAnimateDuration, Style[P.Y > Top + 2] or HideShow[Show]);
    end;
  end;

begin
  if DesignMode or RootMenu.FItemKeyed then exit;
  case FAnimationStyle of
    asDefault: DefaultSystemAnimation;
    asUnFold : DoAnimation(UnfoldAnimationStyle);
    asSlide  :
      begin
        if FAnimateDuration > 100 then
        begin
          Dec(FAnimateDuration, 100);
          DoAnimation(SlideAnimationStyle);
          Inc(FAnimateDuration, 100);
        end
        else
          DoAnimation(SlideAnimationStyle);
      end;
    asFade   : DoAnimation(FadeAnimationStyle);
  end;
end;

procedure TCustomActionMenuBar.CleanupStack;
begin
  if not FPopupStack.Peek.FInMenuLoop then
    FPopupStack.Peek.CloseMenu;
end;

procedure TCustomActionMenuBar.ClearSubMenus;
var
  I: Integer;
begin
  if not FInMenuLoop or not Assigned(FPopupStack) then exit;
  for I := 1 to FPopupStack.Count - 1 do
    FPopupStack.Peek.CloseMenu;   // CloseMenu pops the top menu off the stack
end;

procedure TCustomActionMenuBar.CloseMenu;
begin
  if Assigned(RootMenu) then
  begin
    RootMenu.DelayItem := nil;