actnmenus.pas

这是不可多得的源代码

end;

procedure TCustomActionMenuBar.DoActionIdle;
var
  I: Integer;
begin
  for I := 0 to Screen.CustomFormCount - 1 do
    with TCustomFormClass(Screen.CustomForms[I]) do
      if HandleAllocated and IsWindowVisible(Handle) and
        IsWindowEnabled(Handle) then
        UpdateActions;
end;

procedure TCustomActionMenuBar.Idle(const Msg: TMsg);
var
  Done: Boolean;
begin
  DoMouseIdle;
  if Application.ShowHint and (MouseControl = nil) then
    Application.CancelHint;
  if (Selected <> nil) and Assigned(Selected.Action) then
    Application.Hint := GetLongHint(TCustomAction(Selected.Action).Hint)
  else
    Application.CancelHint;
  Done := True;
  try
    if Assigned(Application.OnIdle) then Application.OnIdle(Self, Done);
    if Done then DoActionIdle;
  except
    Application.HandleException(Self);
  end;
  if (GetCurrentThreadID = MainThreadID) and CheckSynchronize then
    Done := False;
  if Done then WaitMessage;
end;

function TCustomActionMenuBar.ProcessMessage(var Msg: TMsg): Boolean;
var
  App: TApplicationClass;
begin
  App := TApplicationClass(Application);
  Result := False;
  if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
  begin
    Result := True;
    if Msg.Message <> WM_QUIT then
      if not App.IsHintMsg(Msg) and not App.IsMDIMsg(Msg) then
      begin
        // Do not process keyboard messages
        if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
        begin
          Result := False;
          exit;
        end;
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
  end;
end;

procedure TCustomActionMenuBar.ProcessMessages;
var
  Msg: TMsg;
begin
  while ProcessMessage(Msg) do;
end;

function TCustomActionMenuBar.Style: TActionBarStyle;
begin
  if Assigned(RootMenu) and (Self <> RootMenu) then
    Result := RootMenu.Style
  else
    Result := inherited Style;
end;

procedure TCustomActionMenuBar.SetUseSystemFont(const Value: Boolean);
begin
  if FUseSystemFont <> Value then
  begin
    FUseSystemFont := Value;
    if Value then
      Font.Assign(Screen.MenuFont);
  end;
end;

procedure TCustomActionMenuBar.Loaded;
begin
  inherited;
  if FUseSystemFont then
    Font.Assign(Screen.MenuFont);
end;

procedure TCustomActionMenuBar.RecreateControls;
begin
  FreeAndNil(FCachedMenu);
  inherited;
end;

procedure TCustomActionMenuBar.SetMouseControl(const Value: TControl);
begin
  if Value <> MouseControl then
  begin
    if Assigned(FMouseControl) then
      FMouseControl.RemoveFreeNotification(Self);
    FMouseControl := Value;
    if Assigned(FMouseControl) then
      FMouseControl.FreeNotification(Self);
  end;
end;

{ TCustomMenuExpandBtn }

constructor TCustomMenuExpandBtn.Create(AOwner: TComponent);
begin
  inherited;
  Align := alCustom;
  AutoScroll := True;
  ArrowSize := 2;
  Hint := SExpand;
  ArrowType := atArrows;
  Direction := sdDown;
  ControlStyle := ControlStyle + [csNoDesignVisible];
end;

procedure TCustomMenuExpandBtn.DragOver(Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  // This control should not participate in drag/drop at all
  Accept := False;
end;

procedure TCustomMenuExpandBtn.DrawBackground(var PaintRect: TRect);
begin
  OffsetRect(PaintRect, 0, 1);
  InflateRect(PaintRect, -2, -4);
  if MouseInControl then
    Canvas.Brush.Color := Menu.ColorMap.UnusedColor
  else
    Canvas.Brush.Color := Menu.ColorMap.Color;
  inherited DrawBackGround(PaintRect);
end;

procedure TCustomMenuExpandBtn.DrawFrame(ARect: TRect; Down: Boolean);
begin
  OffsetRect(ARect, 0, 1);
  InflateRect(ARect, -2, -4);
  inherited DrawFrame(ARect, Down);
end;

function TCustomMenuExpandBtn.GetMenu: TCustomActionMenuBar;
begin
  Result := ActionBar as TCustomActionMenuBar;
end;

{ TCustomActionPopupMenu }

constructor TCustomActionPopupMenu.Create(AOwner: TComponent);
var
  DisplayShadow: BOOL;
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csNoDesignVisible];
  Visible := False;
  Align := alNone;
  Orientation := boTopToBottom;
  BorderWidth := 0;
  EdgeBorders := [ebLeft, ebTop, ebRight, ebBottom];
  EdgeInner := esRaised;
  EdgeOuter := esRaised;
  VertMargin := 0;
  HorzMargin := 0;
  AutoSize := True;
  if AOwner is TCustomActionBar then
    ActionManager := TCustomActionBar(AOwner).ActionManager;
  if SystemParametersInfo(SPI_GETDROPSHADOW, 0, @DisplayShadow, 0) then
    Shadow := DisplayShadow;
end;

destructor TCustomActionPopupMenu.Destroy;
begin
  if Assigned(ActionClient) then
    ActionClient.ChildActionBar := nil;
  Visible := False;
  FreeAndNil(FExpandBtn);
  inherited Destroy;
end;

procedure TCustomActionPopupMenu.AddEdges(AnItem: TCustomMenuItem);
var
  PrevItem: TActionClientItem;
  NextItem: TActionClientItem;
  Edges: TMenuEdges;
begin
  if (AnItem = nil) or (AnItem.ActionClient = nil) then exit;
  PrevItem := FindPreviousVisibleItem(AnItem.ActionClient);
  NextItem := FindNextVisibleItem(AnItem.ActionClient);
  if AnItem.ActionClient.Unused then
  begin
    Edges := [];
    if FExpanded and ((PrevItem = nil) or not PrevItem.Unused) then
      if AnItem.ActionClient <> FindFirst then
        Edges := Edges + [ebTop];
    if FExpanded and ((NextItem = nil) or not NextItem.Unused) then
      if AnItem.ActionClient <> FindLast then
        Edges := Edges + [ebBottom];
    AnItem.Edges := Edges;
  end
  else
  begin
    if Assigned(PrevItem) and PrevItem.Unused then
      if PrevItem.Control is TCustomMenuItem then
        with PrevItem.Control as TCustomMenuItem do
          Edges := Edges + [ebBottom];
    if Assigned(NextItem) and NextItem.Unused then
      if NextItem.Control is TCustomMenuItem then
        with NextItem.Control as TCustomMenuItem do
          Edges := Edges + [ebTop];
  end;
end;

procedure TCustomActionPopupMenu.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if not DesignMode and Assigned(Selected) and not Assigned(Selected.ChildActionBar) then
    Selected.Control.Selected := False;
end;

procedure TCustomActionPopupMenu.CMVisibleChanged(var Message: TMessage);
begin
  if Visible then
    DisplayShadow
  else
    HideShadow;
  inherited;
end;

function TCustomActionPopupMenu.CreateControl(
  AnItem: TActionClientItem): TCustomActionControl;
begin
  Result := inherited CreateControl(AnItem);
  if (Result is TCustomMenuItem) then
    AddEdges(Result as TCustomMenuItem);
  if not Expanded and Result.ActionClient.Unused then
  begin
    FExpandable := True;
    Result.Visible := False;
  end;
end;

procedure TCustomActionPopupMenu.CreateControls;
begin
  inherited CreateControls;
  if not Expanded and FExpandable and (FindFirstVisibleItem <> nil) then
    SetupExpandBtn;
end;

procedure TCustomActionPopupMenu.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    if not (Parent is TCustomForm) then
      Style := Style and not WS_CHILD or WS_POPUP or WS_CLIPSIBLINGS or
        WS_CLIPCHILDREN or WS_OVERLAPPED;
    WindowClass.Style := CS_SAVEBITS or CS_DBLCLKS or not (CS_HREDRAW or not CS_VREDRAW);
    if not DesignMode then
      ExStyle := ExStyle or WS_EX_TOPMOST;
  end;
end;

function TCustomActionPopupMenu.DesignWndProc(var Message: TMessage): Boolean;
begin
  Result := True;
end;

procedure TCustomActionPopupMenu.ExecAction(Action: TContainedAction);
begin
  Hide;
  inherited ExecAction(Action);
end;

procedure TCustomActionPopupMenu.Expand(Full: Boolean);
var
  I: Integer;
begin
  FExpanded := True;
  DisableAlign;
  try
    if Assigned(FExpandBtn) then
      FExpandBtn.Visible := False;
    HideShadow;
    inherited Expand(Full);
    for I := 0 to Items.Count - 1 do
      if Items[I].Visible then
        if (Items[I].Control is TCustomMenuItem) then
        begin
          AddEdges(TCustomMenuItem(Items[I].Control));
          Items[I].Control.CalcBounds;
        end;
  finally
    EnableAlign;
    if Assigned(FParentControl) then
      PositionPopup(TCustomActionBar(FParentControl.Owner), FParentControl);
    SendMessage(Handle, WM_NCPAINT, 1, 0);
    DisplayShadow;
  end;
end;

procedure TCustomActionPopupMenu.ExpandClick(Sender: TObject);
begin
  while RootMenu.PopupStack.Peek <> Self do
    RootMenu.PopupStack.Pop;
  Expand(True);
end;

procedure TCustomActionPopupMenu.Popup(X, Y: Integer);
begin
  if ItemCount = 0 then exit;
  ParentWindow := Application.Handle;
  FRootMenu := Self;
  if FindFirstVisibleItem = nil then
    Expand(False);
  SetBounds(X, Y, Width, Height);
  PersistentHotKeys := True;
  Visible := True;
  TrackMenu;
end;

procedure TCustomActionPopupMenu.PositionPopup(AnOwner: TCustomActionBar;
  ParentItem: TCustomActionControl);

  function MonitorSize(A, B: Integer): Integer;
  begin
    Result := B;
    if A > 0 then
      Inc(Result, A);
  end;

var
  P: TPoint;
  R: TRect;
  LeftAlign: BOOL;
  Monitor: TMonitor;
begin
  if (AnOwner = nil) or (ParentItem = nil) then
  begin
    Monitor := Screen.MonitorFromPoint(Point(Left, Top));
    P.X := Left;
    P.Y := Top;

    if Left + Width > Monitor.Left + Monitor.Width then
      P.X := Monitor.Left + Monitor.Width - Width;
    if Left < Monitor.Left then
      P.X := Monitor.Left;

    if Top + Height > Monitor.WorkareaRect.Top + Monitor.WorkareaRect.Bottom then
      P.Y := Top - Height;
    if Top < Monitor.WorkareaRect.Top then
      P.Y := Monitor.WorkareaRect.Top;
    if P.Y < Monitor.WorkareaRect.Top then
      P.Y := Monitor.WorkareaRect.Top;
  end
  else
  begin
    with ParentItem do
      case AnOwner.Orientation of
        boLeftToRight: P := AnOwner.ClientToScreen(Point(Left + 1, Top + Height));
        boRightToLeft: P := AnOwner.ClientToScreen(Point(Left - Self.Width +
          Width, Top + Height));
      else
        P := Parent.ClientToScreen(BoundsRect.TopLeft);
        Inc(P.X, Width);
      end;
    // Adjust the position if the menu goes off the edge of the screen
    LeftAlign := True;
    SystemParametersInfo(SPI_GETMENUDROPALIGNMENT, 0, @LeftAlign, 0);
    with ParentItem do
    begin
      R.TopLeft := Parent.ClientToScreen(BoundsRect.TopLeft);
      R.BottomRight := Parent.ClientToScreen(BoundsRect.BottomRight);
    end;
    Monitor := Screen.MonitorFromRect(R, mdNearest);
    if P.X < Monitor.Left then P.X := Monitor.Left;
    if P.X + Width > MonitorSize(Monitor.WorkareaRect.Left, Monitor.WorkareaRect.Right) then
    begin
      P.X := MonitorSize(Monitor.WorkareaRect.Left, Monitor.WorkareaRect.Right) - Width;
      if (ParentItem is TCustomMenuItem) and
         (P.X + Width > Monitor.WorkareaRect.Left + Monitor.WorkareaRect.Right - AnOwner.Left + AnOwner.Width) then
        P.X := AnOwner.Left - Width + 2;
    end;
    if (Height > Monitor.WorkareaRect.Bottom) then
      P.Y := Monitor.Top
    else if (P.Y + Height > MonitorSize(Monitor.WorkareaRect.Top, Monitor.WorkareaRect.Bottom)) then
      if ParentItem is TCustomMenuButton then
        P.Y := P.Y - ParentItem.Height - Height
      else
        P.Y := P.Y - Height + ParentItem.Height + 3;
  end;
  SetBounds(P.X, P.Y, Width, Height);
end;

procedure TCustomActionPopupMenu.SetupExpandBtn;
begin
  if FExpandBtn = nil then
  begin
    FExpandBtn := GetExpandBtnClass.Create