将PopupMenu和MainMenu自绘单元合并，统一使用PopupMenu的样式和用法。
2026-03-04:
增加零配置使用方式
只需要uses添加MenuExt单元，程序运行后，MainMenu1 和 PopupMenu1 会自动应用 DefaultMenuStyle 样式，并显示为自定义绘制的菜单栏和弹出菜单，无需任何额外的初始化代码。
当然也可以使用之前的方法自定义样式。
unit menu_unit; {$mode objfpc}{$H+} interface uses Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, clipbrd, Menus, Messages, Buttons, ExtCtrls, ComCtrls, MATH, Spin, CheckLst, LazUTF8, LazUtils, cp936, LConvEncoding, LazUnicode, LazUTF16, LazSysUtils, LazUtilities, Types, Grids, MenuExt;//-->只需添加MenuExt单元 type { TForm1 } TForm1 = class(TForm) Button1: TButton; Label1: TLabel; MainMenu1: TMainMenu; Memo1: TMemo; MenuItem1: TMenuItem; MenuItem10: TMenuItem; MenuItem11: TMenuItem; MenuItem12: TMenuItem; MenuItem13: TMenuItem; MenuItem14: TMenuItem; Separator2: TMenuItem; Separator1: TMenuItem; MenuItem2: TMenuItem; MenuItem3: TMenuItem; MenuItem4: TMenuItem; MenuItem5: TMenuItem; MenuItem6: TMenuItem; MenuItem7: TMenuItem; MenuItem8: TMenuItem; MenuItem9: TMenuItem; Panel1: TPanel; PopupMenu1: TPopupMenu; private public end; var Form1: TForm1; implementation {$R *.lfm} end.
unit menu_unit; {$mode objfpc}{$H+} interface uses Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, clipbrd, Menus, Messages, Buttons, ExtCtrls, ComCtrls, MATH, Spin, CheckLst, LazUTF8, LazUtils, cp936, LConvEncoding, LazUnicode, LazUTF16, LazSysUtils, LazUtilities, Types, Grids, MenuExt;// StyledMenuUnit, PopupMenuExt; type { TForm1 } TForm1 = class(TForm) Button1: TButton; Label1: TLabel; MainMenu1: TMainMenu; Memo1: TMemo; MenuItem1: TMenuItem; MenuItem10: TMenuItem; MenuItem11: TMenuItem; MenuItem12: TMenuItem; MenuItem13: TMenuItem; MenuItem14: TMenuItem; Separator2: TMenuItem; Separator1: TMenuItem; MenuItem2: TMenuItem; MenuItem3: TMenuItem; MenuItem4: TMenuItem; MenuItem5: TMenuItem; MenuItem6: TMenuItem; MenuItem7: TMenuItem; MenuItem8: TMenuItem; MenuItem9: TMenuItem; Panel1: TPanel; PopupMenu1: TPopupMenu; procedure FormCreate(Sender: TObject); private MyMenuStyle: TPopupMenuStyle; public end; var Form1: TForm1; implementation {$R *.lfm} { TForm1 } procedure TForm1.FormCreate(Sender: TObject); begin // 1. 配置样式 MyMenuStyle := DefaultMenuStyle; // 获取默认值 MyMenuStyle.FontName := 'Microsoft YaHei'; // 微软雅黑，Linux下如无此字体会自动降级 MyMenuStyle.FontSize := 10; // 字体变大 MyMenuStyle.FontColor := clBlack; MyMenuStyle.BgColor := $00F0F0F0; // 浅灰背景 MyMenuStyle.SelectedBgColor := $00FFCC00; // 选中时背景 MyMenuStyle.SelectedFontColor := clBlack; // 选中时黑色字体 MyMenuStyle.ItemPadding := 6; // 增加垂直间距 // 2. 应用样式到 MainMenu1和PopupMenu1 PopupMenu1.ApplyStyle(@MyMenuStyle); MainMenu1.ApplyStyle(@MyMenuStyle); end; end.
unit MenuExt; {$mode objfpc}{$H+} interface uses Classes, SysUtils, LResources, Forms, Controls, Graphics, Menus, LCLType, Dialogs, LCLIntf, LMessages, ExtCtrls, StdCtrls, GraphType, imglist, lclproc, ComCtrls; const My_IconSize = 24; //=========================================================== //扩展PopupMenu //=========================================================== type TPopupMenuStyle = record FontName: String; FontSize: Integer; FontColor: TColor; BgColor: TColor; SelectedFontColor: TColor; SelectedBgColor: TColor; DisabledFontColor: TColor; SeparatorColor: TColor; ItemPadding: Integer; IconSize: Integer; end; PPopupMenuStyle = ^TPopupMenuStyle; TPopupMenu = class; // 统一的模拟弹出窗口 TSimulatedPopupForm = class(TCustomForm) private FStyle: PPopupMenuStyle; FMenuItems: TList; FItemRects: array of TRect; FSelectedIndex: Integer; FRootMenu: TPopupMenu; FParentPopup: TSimulatedPopupForm; FChildPopup: TSimulatedPopupForm; FImageList: TCustomImageList; procedure SetStyle(AValue: PPopupMenuStyle); procedure CalculateSizes; procedure DrawMenu; procedure SetSelectedIndex(Index: Integer); procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE; procedure ShowSubMenu(Index: Integer); procedure CloseChain; function GetImageList: TCustomImageList; function FindItemByMnemonic(Key: Char): Integer; function FindItemByShortCut(Key: Word; Shift: TShiftState): Integer; protected procedure Paint; override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure DoShow; override; procedure Deactivate; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; public constructor CreateNew(AOwner: TComponent; Num: Integer = 0); override; destructor Destroy; override; procedure Popup(AX, AY: Integer; AMenu: TPopupMenu); overload; procedure Popup(AX, AY: Integer; AItem: TMenuItem; AParent: TSimulatedPopupForm); overload; property Style: PPopupMenuStyle read FStyle write SetStyle; end; // 菜单拦截器 TPopupMenu = class(Menus.TPopupMenu) private procedure SetStylePtr(Value: PPopupMenuStyle); function GetStylePtr: PPopupMenuStyle; protected procedure Popup(X, Y: Integer); override; public procedure ApplyStyle(Style: PPopupMenuStyle); property StylePtr: PPopupMenuStyle read GetStylePtr write SetStylePtr; end; function DefaultMenuStyle: TPopupMenuStyle; //=========================================================== //扩展MainMenu //=========================================================== type { 前向声明 } TStyledMenuBar = class; // TMainMenu 拦截器 TMainMenu = class(Menus.TMainMenu) protected procedure Loaded; override; // 【新增】重写 Loaded 方法 public procedure ApplyStyle(Style: PPopupMenuStyle); end; { TStyledMenuPopup } TStyledMenuPopup = class(TCustomForm) private FMenuItems: TMenuItem; FImages: TCustomImageList; FHoverIndex: Integer; FOnClosePopup: TNotifyEvent; FMaxTextWidth: Integer; FMaxShortcutWidth: Integer; FItemHeight: Integer; FTextIndent: Integer; FChildPopup: TStyledMenuPopup; FParentPopup: TStyledMenuPopup; FMenuBar: TStyledMenuBar; FActiveSubMenuIndex: Integer; procedure SetMenuItems(AValue: TMenuItem); procedure CalculateLayout; procedure PaintItem(Index: Integer; ARect: TRect; IsHover: Boolean); procedure CMMouseLeave(var Msg: TLMessage); message CM_MOUSELEAVE; function GetPopupColor: TColor; function GetPopupBorderColor: TColor; function GetItemHoverColor: TColor; function GetTextColor: TColor; function GetTextHoverColor: TColor; function GetDisabledTextColor: TColor; procedure ShowSubMenu(Index: Integer); procedure HideSubMenu; procedure CloseAllPopups; function IsPointInChildPopup(P: TPoint): Boolean; function FindItemByMnemonic(Key: Char): Integer; function FindItemByShortCut(Key: Word; Shift: TShiftState): Integer; procedure DoKeyDown(var Key: Word; Shift: TShiftState); protected procedure Paint; override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure DoHide; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; public constructor CreateNew(AOwner: TComponent; Num: Integer = 0); override; destructor Destroy; override; property MenuItems: TMenuItem read FMenuItems write SetMenuItems; property Images: TCustomImageList read FImages write FImages; property OnClosePopup: TNotifyEvent read FOnClosePopup write FOnClosePopup; property ParentPopup: TStyledMenuPopup read FParentPopup write FParentPopup; end; { TStyledMenuBar } TStyledMenuBar = class(TCustomControl) private FIconSize:Integer; FMainMenu: TMainMenu; FHotIndex: Integer; FPressedIndex: Integer; FPopupForm: TStyledMenuPopup; FOwnerForm: TCustomForm; FOldFormChangeBounds: TNotifyEvent; FOldAppShortCut: TShortCutEvent; FBarColor: TColor; FItemHoverColor: TColor; FTextColor: TColor; FTextHoverColor: TColor; FPopupColor: TColor; FPopupBorderColor: TColor; FDisabledTextColor: TColor; procedure SetMainMenu(AValue: TMainMenu); function GetItemRect(Index: Integer): TRect; function GetItemWidth(Index: Integer): Integer; procedure ShowPopupForm(P: TPoint; Items: TMenuItem; Images: TCustomImageList); procedure HidePopup; procedure DoPopupClose(Sender: TObject); procedure HookEvents; procedure UnhookEvents; procedure DoFormChangeBounds(Sender: TObject); procedure DoAppShortCut(var Msg: TLMKey; var Handled: Boolean); function FindMenuItemByShortCut(Items: TMenuItem; ShortCut: TShortCut): TMenuItem; function FindMenuItemByMnemonic(Items: TMenuItem; Key: Char): TMenuItem; function GetActiveStyle: PPopupMenuStyle; protected procedure Paint; override; procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseLeave; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Popup(X, Y: Integer; APopupMenu: TPopupMenu); published property Align default alTop; property Font; property AutoSize; property IconSize: Integer read FIconSize write FIconSize default my_IconSize; property BarColor: TColor read FBarColor write FBarColor default clBtnFace; property ItemHoverColor: TColor read FItemHoverColor write FItemHoverColor default clHighlight; property TextColor: TColor read FTextColor write FTextColor default clBtnText; property TextHoverColor: TColor read FTextHoverColor write FTextHoverColor default clHighlightText; property PopupColor: TColor read FPopupColor write FPopupColor default clWhite; property PopupBorderColor: TColor read FPopupBorderColor write FPopupBorderColor default clGray; property DisabledTextColor: TColor read FDisabledTextColor write FDisabledTextColor default clGray; property MainMenu: TMainMenu read FMainMenu write SetMainMenu; end; //procedure Register; implementation uses Math; var GStyleList: TList; type // 保存样式的副本 TMenuStyleLink = class Menu: TMenu; Style: TPopupMenuStyle; end; function DefaultMenuStyle: TPopupMenuStyle; begin Result.FontName := 'default'; Result.FontSize := 10; Result.FontColor := clBlack; Result.BgColor := clWhite; Result.SelectedFontColor := clWhite; Result.SelectedBgColor := clHighlight; Result.DisabledFontColor := clGray; Result.SeparatorColor := clSilver; Result.ItemPadding := 4; Result.IconSize := My_IconSize; end; function GetStyleForMenu(AMenu: TMenu): PPopupMenuStyle; var i: Integer; Link: TMenuStyleLink; begin Result := nil; if not Assigned(GStyleList) then Exit; for i := 0 to GStyleList.Count - 1 do begin Link := TMenuStyleLink(GStyleList[i]); if Link.Menu = AMenu then Exit(@Link.Style); end; end; procedure RegisterStyle(AMenu: TMenu; AStyle: PPopupMenuStyle); var Link: TMenuStyleLink; i: Integer; begin if not Assigned(GStyleList) then GStyleList := TList.Create; for i := GStyleList.Count - 1 downto 0 do begin Link := TMenuStyleLink(GStyleList[i]); if Link.Menu = AMenu then begin GStyleList.Delete(i); Link.Free; end; end; Link := TMenuStyleLink.Create; Link.Menu := AMenu; Link.Style := AStyle^; // 复制内容 GStyleList.Add(Link); end; //procedure Register; //begin // RegisterComponents('Standard', [TStyledMenuBar]); //end; function GetMnemonicChar(const ACaption: String): Char; var i: Integer; begin Result := #0; for i := 1 to Length(ACaption) - 1 do begin if (ACaption[i] = '&') and (ACaption[i+1] <> '&') then begin Result := UpCase(ACaption[i+1]); Break; end; end; end; //=========================================================== //扩展MainMenu //=========================================================== // 【新增】当窗体加载完成时自动触发 procedure TMainMenu.Loaded; var DefStyle: TPopupMenuStyle; begin inherited Loaded; // 设计时跳过，防止干扰设计器 if (csDesigning in ComponentState) then Exit; // 如果当前菜单还没有注册样式，则自动应用默认样式 if GetStyleForMenu(Self) = nil then begin DefStyle := DefaultMenuStyle; ApplyStyle(@DefStyle); end; end; { TMainMenu 拦截器实现 } procedure TMainMenu.ApplyStyle(Style: PPopupMenuStyle); var Form: TCustomForm; Bar: TStyledMenuBar; i: Integer; begin // 1. 注册样式 RegisterStyle(Self, Style); // 2. 自动创建/绑定 TStyledMenuBar if not (csDesigning in ComponentState) then begin if Owner is TCustomForm then begin Form := TCustomForm(Owner); // 查找现有的 TStyledMenuBar Bar := nil; for i := 0 to Form.ComponentCount - 1 do if Form.Components[i] is TStyledMenuBar then begin Bar := TStyledMenuBar(Form.Components[i]); Break; end; // 如果没有，自动创建 if Bar = nil then begin Bar := TStyledMenuBar.Create(Form); Bar.Name := 'AutoStyledMenuBar'; end; // 无论Bar是找到的还是新建的，都要确保Parent正确 if Bar.Parent = nil then Bar.Parent := Form; // 确保菜单栏在最顶层 Bar.BringToFront; // 绑定菜单 if Bar.MainMenu <> Self then Bar.MainMenu := Self; end; end; end; { TStyledMenuPopup } constructor TStyledMenuPopup.CreateNew(AOwner: TComponent; Num: Integer); begin inherited CreateNew(AOwner, Num); BorderStyle := bsNone; FormStyle := fsSystemStayOnTop; ShowInTaskBar := stNever; FHoverIndex := -1; FActiveSubMenuIndex := -1; Color := clWhite; DoubleBuffered := True; KeyPreview := True; if AOwner is TStyledMenuBar then FMenuBar := TStyledMenuBar(AOwner) else if AOwner is TStyledMenuPopup then FMenuBar := TStyledMenuPopup(AOwner).FMenuBar; end; destructor TStyledMenuPopup.Destroy; begin if FChildPopup <> nil then begin FChildPopup.Free; FChildPopup := nil; end; inherited Destroy; end; procedure TStyledMenuPopup.DoHide; begin HideSubMenu; inherited DoHide; end; function TStyledMenuPopup.GetPopupColor: TColor; var PStyle: PPopupMenuStyle; begin if (FMenuBar <> nil) and (FMenuBar.FMainMenu <> nil) then begin PStyle := GetStyleForMenu(FMenuBar.FMainMenu); if PStyle <> nil then Exit(PStyle^.BgColor); end; if FMenuBar <> nil then Result := FMenuBar.PopupColor else Result := clWhite; end; function TStyledMenuPopup.GetPopupBorderColor: TColor; var PStyle: PPopupMenuStyle; begin if (FMenuBar <> nil) and (FMenuBar.FMainMenu <> nil) then begin PStyle := GetStyleForMenu(FMenuBar.FMainMenu); if PStyle <> nil then Exit(PStyle^.SeparatorColor); end; if FMenuBar <> nil then Result := FMenuBar.PopupBorderColor else Result := clGray; end; function TStyledMenuPopup.GetItemHoverColor: TColor; var PStyle: PPopupMenuStyle; begin if (FMenuBar <> nil) and (FMenuBar.FMainMenu <> nil) then begin PStyle := GetStyleForMenu(FMenuBar.FMainMenu); if PStyle <> nil then Exit(PStyle^.SelectedBgColor); end; if FMenuBar <> nil then Result := FMenuBar.ItemHoverColor else Result := clHighlight; end; function TStyledMenuPopup.GetTextColor: TColor; var PStyle: PPopupMenuStyle; begin if (FMenuBar <> nil) and (FMenuBar.FMainMenu <> nil) then begin PStyle := GetStyleForMenu(FMenuBar.FMainMenu); if PStyle <> nil then Exit(PStyle^.FontColor); end; if FMenuBar <> nil then Result := FMenuBar.TextColor else Result := clBtnText; end; function TStyledMenuPopup.GetTextHoverColor: TColor; var PStyle: PPopupMenuStyle; begin if (FMenuBar <> nil) and (FMenuBar.FMainMenu <> nil) then begin PStyle := GetStyleForMenu(FMenuBar.FMainMenu); if PStyle <> nil then Exit(PStyle^.SelectedFontColor); end; if FMenuBar <> nil then Result := FMenuBar.TextHoverColor else Result := clHighlightText; end; function TStyledMenuPopup.GetDisabledTextColor: TColor; var PStyle: PPopupMenuStyle; begin if (FMenuBar <> nil) and (FMenuBar.FMainMenu <> nil) then begin PStyle := GetStyleForMenu(FMenuBar.FMainMenu); if PStyle <> nil then Exit(PStyle^.DisabledFontColor); end; if FMenuBar <> nil then Result := FMenuBar.DisabledTextColor else Result := clGray; end; function TStyledMenuPopup.IsPointInChildPopup(P: TPoint): Boolean; begin Result := False; if (FChildPopup <> nil) and (FChildPopup.Visible) then begin Result := PtInRect(FChildPopup.ClientRect, FChildPopup.ScreenToClient(P)); end; end; procedure TStyledMenuPopup.CalculateLayout; var i: Integer; Item: TMenuItem; ShortCutText: String; MaxImgWidth, MaxImgHeight: Integer; IconSize,MaxIconSize:Integer; PStyle: PPopupMenuStyle; begin FMaxTextWidth := 0; FMaxShortcutWidth := 0; FItemHeight := 0; FTextIndent := 0; if FMenuItems = nil then Exit; PStyle := nil; if (FMenuBar <> nil) and (FMenuBar.FMainMenu <> nil) then PStyle := GetStyleForMenu(FMenuBar.FMainMenu); if PStyle <> nil then begin Canvas.Font.Name := PStyle^.FontName; Canvas.Font.Size := PStyle^.FontSize; end else if FMenuBar <> nil then Canvas.Font.Assign(FMenuBar.Font) else Canvas.Font := Screen.MenuFont; MaxImgWidth := 0; MaxImgHeight := 0; MaxIconSize := 0; if PStyle <> nil then IconSize := PStyle^.IconSize else if FMenuBar <> nil then IconSize := FMenuBar.IconSize else IconSize := my_IconSize; if IconSize=0 then begin for i := 0 to FMenuItems.Count - 1 do begin Item := FMenuItems[i]; if (Item.Bitmap <> nil) and (not Item.Bitmap.Empty) then begin MaxIconSize:=Min(Item.Bitmap.Width,Item.Bitmap.Height); IconSize:=Max(MaxIconSize,IconSize); end; end; end; if (IconSize=0) and (FImages <> nil) then IconSize:=Min(FImages.Width,FImages.Height); if IconSize=0 then IconSize:=my_IconSize; if (FImages <> nil) and (FImages.Count > 0) then begin MaxImgWidth := Min(FImages.Width, IconSize); MaxImgHeight := Min(FImages.Height, IconSize); end; for i := 0 to FMenuItems.Count - 1 do begin Item := FMenuItems[i]; if (Item.Bitmap <> nil) and (not Item.Bitmap.Empty) then begin MaxImgWidth := Max(MaxImgWidth, Min(Item.Bitmap.Width, IconSize)); MaxImgHeight := Max(MaxImgHeight, Min(Item.Bitmap.Height, IconSize)); end; end; if MaxImgWidth > 0 then FTextIndent := 4 + IconSize + 6 else FTextIndent := 10; for i := 0 to FMenuItems.Count - 1 do begin Item := FMenuItems[i]; if Item.Caption <> '-' then begin FMaxTextWidth := Max(FMaxTextWidth, Canvas.TextWidth(StringReplace(Item.Caption, '&', '', [rfReplaceAll]))); ShortCutText := ShortCutToText(Item.ShortCut); if ShortCutText = 'Unknown' then ShortCutText := ''; if ShortCutText <> '' then FMaxShortcutWidth := Max(FMaxShortcutWidth, Canvas.TextWidth(ShortCutText)); end; end; FItemHeight := Max(IconSize, Canvas.TextHeight('Wg')) + 6; end; procedure TStyledMenuPopup.SetMenuItems(AValue: TMenuItem); var i: Integer; TotalHeight, TotalWidth: Integer; begin if FMenuItems <> AValue then HideSubMenu; FMenuItems := AValue; FHoverIndex := -1; FActiveSubMenuIndex := -1; if FMenuItems = nil then Exit; CalculateLayout; TotalWidth := FTextIndent + FMaxTextWidth + 20 + FMaxShortcutWidth + 40; if TotalWidth < 150 then TotalWidth := 150; TotalHeight := 4; for i := 0 to FMenuItems.Count - 1 do begin if FMenuItems[i].Caption = '-' then TotalHeight := TotalHeight + 6 else TotalHeight := TotalHeight + FItemHeight; end; TotalHeight := TotalHeight + 2; ClientWidth := TotalWidth; ClientHeight := TotalHeight; end; procedure TStyledMenuPopup.PaintItem(Index: Integer; ARect: TRect; IsHover: Boolean); var Item: TMenuItem; IconX, IconY: Integer; TextX: Integer; ShortCutText: String; IconIdx: Integer; ShortCutX: Integer; IconWidth, IconHeight: Integer; Bmp: TBitmap; DrawEffect: TGraphicsDrawEffect; HasSubMenu: Boolean; IconSize: Integer; TS: TTextStyle; PStyle: PPopupMenuStyle; ArrowWidth: Integer; begin Item := FMenuItems[Index]; if Item.Caption = '-' then begin Canvas.Brush.Color := GetPopupColor; Canvas.FillRect(ARect); Canvas.Pen.Color := GetPopupBorderColor; Canvas.Line(ARect.Left + 2, ARect.Top + ARect.Height div 2, ARect.Right - 2, ARect.Top + ARect.Height div 2); Exit; end; HasSubMenu := (Item.Count > 0); if Item.Enabled then begin if IsHover then begin Canvas.Brush.Color := GetItemHoverColor; Canvas.Font.Color := GetTextHoverColor; end else begin Canvas.Brush.Color := GetPopupColor; Canvas.Font.Color := GetTextColor; end; DrawEffect := gdeNormal; end else begin Canvas.Brush.Color := GetPopupColor; Canvas.Font.Color := GetDisabledTextColor; DrawEffect := gdeDisabled; end; Canvas.FillRect(ARect); PStyle := nil; if (FMenuBar <> nil) and (FMenuBar.FMainMenu <> nil) then PStyle := GetStyleForMenu(FMenuBar.FMainMenu); if PStyle <> nil then IconSize := PStyle^.IconSize else if FMenuBar <> nil then IconSize := FMenuBar.IconSize else IconSize := my_IconSize; IconWidth := 0; IconHeight := 0; IconIdx := Item.ImageIndex; if (FImages <> nil) and (IconIdx >= 0) and (IconIdx < FImages.Count) then begin if IconSize=0 then begin IconSize:=Min(FImages.Width,FImages.Height); end else IconSize:=my_IconSize; IconWidth := Min(FImages.Width, IconSize); IconHeight := Min(FImages.Height, IconSize); IconX := ARect.Left + 4; IconY := ARect.Top + (ARect.Height - IconHeight) div 2; if (IconWidth = FImages.Width) and (IconHeight = FImages.Height) then begin FImages.Draw(Canvas, IconX, IconY, IconIdx, dsTransparent, itImage, DrawEffect); end else begin Bmp := TBitmap.Create; try Bmp.Width := FImages.Width; Bmp.Height := FImages.Height; FImages.Draw(Bmp.Canvas, 0, 0, IconIdx, dsTransparent, itImage, DrawEffect); Bmp.Transparent := True; Canvas.StretchDraw(Rect(IconX, IconY, IconX + IconWidth, IconY + IconHeight), Bmp); finally Bmp.Free; end; end; end else if (Item.Bitmap <> nil) and (not Item.Bitmap.Empty) then begin if IconSize=0 then begin IconSize:=Min(Item.Bitmap.Width,Item.Bitmap.Height); if IconSize=0 then IconSize:=my_IconSize; end; IconWidth := Min(Item.Bitmap.Width, IconSize); IconHeight := Min(Item.Bitmap.Height, IconSize); IconX := ARect.Left + 4; IconY := ARect.Top + (ARect.Height - IconHeight) div 2; Item.Bitmap.Transparent := True; Canvas.StretchDraw(Rect(IconX, IconY, IconX + IconWidth, IconY + IconHeight), Item.Bitmap); end; TextX := ARect.Left + FTextIndent; Canvas.Brush.Style := bsClear; TS := Canvas.TextStyle; TS.ShowPrefix := True; TS.Opaque := False; Canvas.TextStyle := TS; Canvas.TextRect(ARect, TextX, ARect.Top + (ARect.Height - Canvas.TextHeight('Wg')) div 2, Item.Caption); // 计算箭头宽度 ArrowWidth := Canvas.TextWidth('►'); ShortCutText := ShortCutToText(Item.ShortCut); if ShortCutText = 'Unknown' then ShortCutText := ''; if ShortCutText <> '' then begin // 如果有子菜单，快捷键位置要向左移动，避免覆盖箭头 // 箭头位置: Right - ArrowWidth - 5 // 快捷键右侧应距离箭头左侧 5 像素 // 快捷键右侧 = (Right - ArrowWidth - 5) - 5 = Right - ArrowWidth - 10 if HasSubMenu then ShortCutX := ARect.Right - ArrowWidth - Canvas.TextWidth(ShortCutText) - 10 else ShortCutX := ARect.Right - Canvas.TextWidth(ShortCutText) - 5; Canvas.TextRect(ARect, ShortCutX, ARect.Top + (ARect.Height - Canvas.TextHeight('Wg')) div 2, ShortCutText); end; // 【修复】MainMenu 箭头位置：根据实际文本宽度计算 X 坐标，右边距5像素 if HasSubMenu then begin Canvas.Pen.Color := Canvas.Font.Color; IconX := ARect.Right - ArrowWidth - 5; IconY := ARect.Top + (ARect.Height - Canvas.TextHeight('►')) div 2; Canvas.TextOut(IconX, IconY, '►'); end; end; procedure TStyledMenuPopup.Paint; var i: Integer; R: TRect; CurY: Integer; PStyle: PPopupMenuStyle; begin inherited Paint; Canvas.Pen.Color := GetPopupBorderColor; Canvas.Brush.Color := GetPopupColor; Canvas.Rectangle(0, 0, ClientWidth, ClientHeight); if FMenuItems = nil then Exit; PStyle := nil; if (FMenuBar <> nil) and (FMenuBar.FMainMenu <> nil) then PStyle := GetStyleForMenu(FMenuBar.FMainMenu); if PStyle <> nil then begin Canvas.Font.Name := PStyle^.FontName; Canvas.Font.Size := PStyle^.FontSize; end else if FMenuBar <> nil then Canvas.Font.Assign(FMenuBar.Font) else Canvas.Font := Screen.MenuFont; CurY := 2; for i := 0 to FMenuItems.Count - 1 do begin if FMenuItems[i].Caption = '-' then R := Rect(1, CurY, ClientWidth - 1, CurY + 6) else R := Rect(1, CurY, ClientWidth - 1, CurY + FItemHeight); PaintItem(i, R, (i = FHoverIndex)); CurY := R.Bottom; end; end; procedure TStyledMenuPopup.CMMouseLeave(var Msg: TLMessage); begin inherited; end; function TStyledMenuPopup.FindItemByMnemonic(Key: Char): Integer; var i: Integer; C: Char; begin Result := -1; for i := 0 to FMenuItems.Count - 1 do begin C := GetMnemonicChar(FMenuItems[i].Caption); if (C = Key) and (FMenuItems[i].Enabled) and (FMenuItems[i].Caption <> '-') then begin Result := i; Exit; end; end; end; function TStyledMenuPopup.FindItemByShortCut(Key: Word; Shift: TShiftState): Integer; var i: Integer; SC: TShortCut; begin Result := -1; SC := Menus.ShortCut(Key, Shift); for i := 0 to FMenuItems.Count - 1 do begin if (FMenuItems[i].ShortCut = SC) and (FMenuItems[i].Enabled) then begin Result := i; Exit; end; end; end; procedure TStyledMenuPopup.DoKeyDown(var Key: Word; Shift: TShiftState); var i, NewIdx: Integer; Item: TMenuItem; begin if Key = VK_ESCAPE then begin CloseAllPopups; Exit; end; if Key = VK_DOWN then begin NewIdx := FHoverIndex; repeat Inc(NewIdx); if NewIdx >= FMenuItems.Count then NewIdx := -1; until (NewIdx = -1) or (FMenuItems[NewIdx].Caption <> '-'); if NewIdx = -1 then begin for NewIdx := 0 to FMenuItems.Count - 1 do if FMenuItems[NewIdx].Caption <> '-' then Break; end; FHoverIndex := NewIdx; Invalidate; Key := 0; Exit; end; if Key = VK_UP then begin NewIdx := FHoverIndex; repeat Dec(NewIdx); if NewIdx < 0 then NewIdx := -1; until (NewIdx = -1) or (FMenuItems[NewIdx].Caption <> '-'); if NewIdx = -1 then begin for NewIdx := FMenuItems.Count - 1 downto 0 do if FMenuItems[NewIdx].Caption <> '-' then Break; end; FHoverIndex := NewIdx; Invalidate; Key := 0; Exit; end; if Key = VK_RETURN then begin if (FHoverIndex >= 0) and (FMenuItems[FHoverIndex].Enabled) then begin Item := FMenuItems[FHoverIndex]; if Item.Count > 0 then ShowSubMenu(FHoverIndex) else begin CloseAllPopups; Item.Click; end; end; Key := 0; Exit; end; if Key = VK_RIGHT then begin if (FHoverIndex >= 0) and (FMenuItems[FHoverIndex].Count > 0) then begin ShowSubMenu(FHoverIndex); if FChildPopup <> nil then FChildPopup.FHoverIndex := 0; end; Key := 0; Exit; end; if Key = VK_LEFT then begin if FParentPopup <> nil then begin HideSubMenu; end; Key := 0; Exit; end; i := FindItemByShortCut(Key, Shift); if i >= 0 then begin CloseAllPopups; FMenuItems[i].Click; Key := 0; Exit; end; if (Shift = []) or (Shift = [ssAlt]) then begin i := FindItemByMnemonic(UpCase(Chr(Key))); if i >= 0 then begin Item := FMenuItems[i]; if Item.Count > 0 then begin FHoverIndex := i; Invalidate; ShowSubMenu(i); end else begin CloseAllPopups; Item.Click; end; Key := 0; Exit; end; end; end; procedure TStyledMenuPopup.KeyDown(var Key: Word; Shift: TShiftState); begin DoKeyDown(Key, Shift); inherited KeyDown(Key, Shift); end; procedure TStyledMenuPopup.ShowSubMenu(Index: Integer); var Item: TMenuItem; P: TPoint; R: TRect; CurY: Integer; ScreenRect: TRect; i: Integer; begin if (Index < 0) or (Index >= FMenuItems.Count) then Exit; Item := FMenuItems[Index]; if (Item.Count = 0) then Exit; if (FChildPopup <> nil) and (FActiveSubMenuIndex = Index) then Exit; HideSubMenu; FActiveSubMenuIndex := Index; CurY := 2; for i := 0 to Index - 1 do begin if FMenuItems[i].Caption = '-' then CurY := CurY + 6 else CurY := CurY + FItemHeight; end; R := Rect(1, CurY, ClientWidth - 1, CurY + FItemHeight); P := ClientToScreen(Point(R.Right, R.Top)); FChildPopup := TStyledMenuPopup.CreateNew(Self, 0); FChildPopup.ParentPopup := Self; FChildPopup.Images := FImages; FChildPopup.MenuItems := Item; ScreenRect := Screen.MonitorFromPoint(P).WorkareaRect; if P.X + FChildPopup.Width > ScreenRect.Right then P.X := ClientToScreen(Point(R.Left, 0)).X - FChildPopup.Width; if P.Y + FChildPopup.Height > ScreenRect.Bottom then P.Y := ScreenRect.Bottom - FChildPopup.Height; FChildPopup.SetBounds(P.X, P.Y, FChildPopup.Width, FChildPopup.Height); FChildPopup.Show; end; procedure TStyledMenuPopup.HideSubMenu; begin if FChildPopup <> nil then begin FChildPopup.Hide; FChildPopup.Release; FChildPopup := nil; FActiveSubMenuIndex := -1; end; end; procedure TStyledMenuPopup.CloseAllPopups; begin Hide; if FParentPopup <> nil then FParentPopup.CloseAllPopups else if Assigned(FOnClosePopup) then FOnClosePopup(Self); end; procedure TStyledMenuPopup.MouseMove(Shift: TShiftState; X, Y: Integer); var i: Integer; R: TRect; CurY: Integer; NewIndex: Integer; ScreenP: TPoint; BarP: TPoint; Bar: TStyledMenuBar; begin inherited MouseMove(Shift, X, Y); ScreenP := ClientToScreen(Point(X, Y)); if IsPointInChildPopup(ScreenP) then begin Exit; end; if (Owner is TStyledMenuBar) and (FParentPopup = nil) then begin Bar := TStyledMenuBar(Owner); BarP := Bar.ScreenToClient(ScreenP); if (BarP.Y >= 0) and (BarP.Y < Bar.ClientHeight) then begin for i := 0 to Bar.MainMenu.Items.Count - 1 do begin if PtInRect(Bar.GetItemRect(i), BarP) then begin if i <> Bar.FPressedIndex then begin Bar.HidePopup; Bar.FPressedIndex := i; Bar.FHotIndex := i; Bar.ShowPopupForm(Bar.ClientToScreen(Point(Bar.GetItemRect(i).Left, Bar.ClientHeight)), Bar.MainMenu.Items[i], Bar.MainMenu.Images); Bar.Invalidate; end; Exit; end; end; end; end; NewIndex := -1; CurY := 2; for i := 0 to FMenuItems.Count - 1 do begin if FMenuItems[i].Caption = '-' then R := Rect(1, CurY, ClientWidth - 1, CurY + 6) else R := Rect(1, CurY, ClientWidth - 1, CurY + FItemHeight); if PtInRect(R, Point(X, Y)) then begin if FMenuItems[i].Caption <> '-' then NewIndex := i else NewIndex := FHoverIndex; Break; end; CurY := R.Bottom; end; if NewIndex <> FHoverIndex then begin FHoverIndex := NewIndex; Invalidate; if (NewIndex <> FActiveSubMenuIndex) then begin HideSubMenu; end; if (NewIndex >= 0) and (FMenuItems[NewIndex].Count > 0) then begin ShowSubMenu(NewIndex); end; end; end; procedure TStyledMenuPopup.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i: Integer; R: TRect; CurY: Integer; Item: TMenuItem; ScreenP: TPoint; BarP: TPoint; Bar: TStyledMenuBar; ClickedItem: Boolean; ChildP: TPoint; begin inherited MouseDown(Button, Shift, X, Y); ScreenP := ClientToScreen(Point(X, Y)); if (FChildPopup <> nil) and (FChildPopup.Visible) then begin ChildP := FChildPopup.ScreenToClient(ScreenP); if PtInRect(FChildPopup.ClientRect, ChildP) then begin FChildPopup.MouseDown(Button, Shift, ChildP.X, ChildP.Y); Exit; end; end; if (Owner is TStyledMenuBar) and (FParentPopup = nil) then begin Bar := TStyledMenuBar(Owner); BarP := Bar.ScreenToClient(ScreenP); if (BarP.Y >= 0) and (BarP.Y < Bar.ClientHeight) then begin for i := 0 to Bar.MainMenu.Items.Count - 1 do begin if PtInRect(Bar.GetItemRect(i), BarP) then begin if i = Bar.FPressedIndex then Bar.HidePopup else begin Bar.HidePopup; Bar.FPressedIndex := i; Bar.FHotIndex := i; Bar.ShowPopupForm(Bar.ClientToScreen(Point(Bar.GetItemRect(i).Left, Bar.ClientHeight)), Bar.MainMenu.Items[i], Bar.MainMenu.Images); Bar.Invalidate; end; Exit; end; end; end; end; ClickedItem := False; CurY := 2; for i := 0 to FMenuItems.Count - 1 do begin if FMenuItems[i].Caption = '-' then R := Rect(1, CurY, ClientWidth - 1, CurY + 6) else R := Rect(1, CurY, ClientWidth - 1, CurY + FItemHeight); if PtInRect(R, Point(X, Y)) then begin Item := FMenuItems[i]; if (Item.Caption <> '-') and Item.Enabled then begin if Item.Count = 0 then begin CloseAllPopups; Item.Click; end else begin ShowSubMenu(i); end; end; ClickedItem := True; Break; end; CurY := R.Bottom; end; if not ClickedItem then begin CloseAllPopups; end; end; { TStyledMenuBar } constructor TStyledMenuBar.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csOpaque]; Align := alTop; AutoSize := True; DoubleBuffered := True; FHotIndex := -1; FPressedIndex := -1; FBarColor := clBtnFace; FItemHoverColor := clHighlight; FTextColor := clBtnText; FTextHoverColor := clHighlightText; FPopupColor := clWhite; FIconSize:=my_IconSize; FPopupBorderColor := clGray; FDisabledTextColor := clGray; end; destructor TStyledMenuBar.Destroy; begin UnhookEvents; inherited Destroy; end; procedure TStyledMenuBar.CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean); var PStyle: PPopupMenuStyle; begin inherited CalculatePreferredSize(PreferredWidth, PreferredHeight, WithThemeSpace); PStyle := GetActiveStyle; if PStyle <> nil then begin Canvas.Font.Name := PStyle^.FontName; Canvas.Font.Size := PStyle^.FontSize; end else Canvas.Font.Assign(Self.Font); PreferredHeight := Canvas.TextHeight('Wg') + 6; PreferredWidth := 0; end; procedure TStyledMenuBar.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) then begin if AComponent = FMainMenu then FMainMenu := nil; if AComponent = FOwnerForm then begin if not (csDestroying in ComponentState) then UnhookEvents; FOwnerForm := nil; end; end; end; procedure TStyledMenuBar.HookEvents; begin if FOwnerForm = nil then begin if (MainMenu <> nil) and (MainMenu.Owner is TCustomForm) then FOwnerForm := TCustomForm(MainMenu.Owner) else FOwnerForm := GetParentForm(Self); end; if (FOwnerForm <> nil) and not (csDesigning in ComponentState) then begin FOldFormChangeBounds := FOwnerForm.OnChangeBounds; FOwnerForm.OnChangeBounds := @DoFormChangeBounds; FOwnerForm.FreeNotification(Self); end; if not (csDesigning in ComponentState) then begin FOldAppShortCut := Application.OnShortCut; Application.OnShortCut := @DoAppShortCut; end; end; procedure TStyledMenuBar.UnhookEvents; begin if (FOwnerForm <> nil) then begin FOwnerForm.OnChangeBounds := FOldFormChangeBounds; end; if not (csDesigning in ComponentState) then begin Application.OnShortCut := FOldAppShortCut; end; end; procedure TStyledMenuBar.DoFormChangeBounds(Sender: TObject); begin if Assigned(FOldFormChangeBounds) then FOldFormChangeBounds(Sender); HidePopup; end; function TStyledMenuBar.FindMenuItemByShortCut(Items: TMenuItem; ShortCut: TShortCut): TMenuItem; var i: Integer; ChildItem: TMenuItem; begin Result := nil; for i := 0 to Items.Count - 1 do begin if (Items[i].ShortCut = ShortCut) and Items[i].Enabled then begin Result := Items[i]; Exit; end; if Items[i].Count > 0 then begin ChildItem := FindMenuItemByShortCut(Items[i], ShortCut); if ChildItem <> nil then begin Result := ChildItem; Exit; end; end; end; end; function TStyledMenuBar.FindMenuItemByMnemonic(Items: TMenuItem; Key: Char): TMenuItem; var i: Integer; C: Char; begin Result := nil; for i := 0 to Items.Count - 1 do begin C := GetMnemonicChar(Items[i].Caption); if (C = Key) and Items[i].Enabled then begin Result := Items[i]; Exit; end; end; end; function TStyledMenuBar.GetActiveStyle: PPopupMenuStyle; begin if FMainMenu <> nil then Result := GetStyleForMenu(FMainMenu) else Result := nil; end; procedure TStyledMenuBar.DoAppShortCut(var Msg: TLMKey; var Handled: Boolean); var Key: Word; ShiftState: TShiftState; SC: TShortCut; Item: TMenuItem; begin if Assigned(FOldAppShortCut) then FOldAppShortCut(Msg, Handled); if Handled then Exit; if FMainMenu = nil then Exit; Key := Msg.CharCode; ShiftState := []; if GetKeyState(VK_SHIFT) < 0 then Include(ShiftState, ssShift); if GetKeyState(VK_CONTROL) < 0 then Include(ShiftState, ssCtrl); if GetKeyState(VK_MENU) < 0 then Include(ShiftState, ssAlt); SC := Menus.ShortCut(Key, ShiftState); Item := FindMenuItemByShortCut(FMainMenu.Items, SC); if Item <> nil then begin if (FPopupForm <> nil) and (FPopupForm.Visible) then HidePopup; Item.Click; Handled := True; Msg.Result := 1; Exit; end; if (ssAlt in ShiftState) and not (ssCtrl in ShiftState) then begin Item := FindMenuItemByMnemonic(FMainMenu.Items, UpCase(Chr(Key))); if Item <> nil then begin HidePopup; if Item.Count > 0 then begin FPressedIndex := Item.MenuIndex; FHotIndex := Item.MenuIndex; ShowPopupForm(ClientToScreen(Point(GetItemRect(Item.MenuIndex).Left, ClientHeight)), Item, FMainMenu.Images); end else begin Item.Click; end; Invalidate; Handled := True; Msg.Result := 1; Exit; end; end; end; procedure TStyledMenuBar.SetMainMenu(AValue: TMainMenu); begin if FMainMenu = AValue then Exit; UnhookEvents; if FMainMenu <> nil then FMainMenu.RemoveFreeNotification(Self); FMainMenu := AValue; if FMainMenu <> nil then begin FMainMenu.FreeNotification(Self); // 关键：隐藏系统原生菜单 if (FMainMenu.Owner is TCustomForm) then TCustomForm(FMainMenu.Owner).Menu := nil; end; HookEvents; Invalidate; end; function TStyledMenuBar.GetItemWidth(Index: Integer): Integer; var PStyle: PPopupMenuStyle; begin if (FMainMenu = nil) or (Index < 0) or (Index >= FMainMenu.Items.Count) then Exit(0); PStyle := GetActiveStyle; if PStyle <> nil then begin Canvas.Font.Name := PStyle^.FontName; Canvas.Font.Size := PStyle^.FontSize; end else Canvas.Font.Assign(Self.Font); Result := Canvas.TextWidth(StringReplace(FMainMenu.Items[Index].Caption, '&', '', [rfReplaceAll])) + 20; end; function TStyledMenuBar.GetItemRect(Index: Integer): TRect; var i, curX: Integer; begin Result := Rect(0, 0, 0, 0); if (FMainMenu = nil) or (Index < 0) or (Index >= FMainMenu.Items.Count) then Exit; curX := 0; for i := 0 to Index - 1 do curX := curX + GetItemWidth(i); Result.Left := curX; Result.Top := 0; Result.Right := curX + GetItemWidth(Index); Result.Bottom := ClientHeight; end; procedure TStyledMenuBar.Paint; var i: Integer; R: TRect; Item: TMenuItem; TS: TTextStyle; PStyle: PPopupMenuStyle; UseColor: TColor; begin inherited Paint; PStyle := GetActiveStyle; if PStyle <> nil then UseColor := PStyle^.BgColor else UseColor := FBarColor; Canvas.Brush.Color := UseColor; Canvas.FillRect(ClientRect); if FMainMenu = nil then Exit; if PStyle <> nil then begin Canvas.Font.Name := PStyle^.FontName; Canvas.Font.Size := PStyle^.FontSize; end else Canvas.Font.Assign(Self.Font); for i := 0 to FMainMenu.Items.Count - 1 do begin Item := FMainMenu.Items[i]; R := GetItemRect(i); if i = FPressedIndex then begin if PStyle <> nil then Canvas.Brush.Color := PStyle^.SelectedBgColor else Canvas.Brush.Color := FPopupBorderColor; if PStyle <> nil then Canvas.Font.Color := PStyle^.SelectedFontColor else Canvas.Font.Color := FTextHoverColor; end else if i = FHotIndex then begin if PStyle <> nil then Canvas.Brush.Color := PStyle^.SelectedBgColor else Canvas.Brush.Color := FItemHoverColor; if PStyle <> nil then Canvas.Font.Color := PStyle^.SelectedFontColor else Canvas.Font.Color := FTextHoverColor; end else begin Canvas.Brush.Style := bsClear; if PStyle <> nil then Canvas.Font.Color := PStyle^.FontColor else Canvas.Font.Color := FTextColor; end; if (i = FPressedIndex) or (i = FHotIndex) then Canvas.FillRect(R) else Canvas.Brush.Style := bsClear; TS := Canvas.TextStyle; TS.ShowPrefix := True; TS.Opaque := False; Canvas.TextStyle := TS; Canvas.TextRect(R, R.Left + 5, R.Top + (R.Height - Canvas.TextHeight(Item.Caption)) div 2, Item.Caption); end; end; procedure TStyledMenuBar.MouseMove(Shift: TShiftState; X, Y: Integer); var i: Integer; R: TRect; NewHot: Integer; begin inherited MouseMove(Shift, X, Y); if (FPopupForm = nil) or (not FPopupForm.Visible) then begin NewHot := -1; if FMainMenu <> nil then begin for i := 0 to FMainMenu.Items.Count - 1 do begin R := GetItemRect(i); if PtInRect(R, Point(X, Y)) then begin NewHot := i; Break; end; end; end; if NewHot <> FHotIndex then begin FHotIndex := NewHot; Invalidate; end; end; end; procedure TStyledMenuBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i: Integer; R: TRect; P: TPoint; begin inherited MouseDown(Button, Shift, X, Y); if FMainMenu = nil then Exit; for i := 0 to FMainMenu.Items.Count - 1 do begin R := GetItemRect(i); if PtInRect(R, Point(X, Y)) then begin if (FPopupForm <> nil) and (FPopupForm.Visible) then HidePopup else begin FPressedIndex := i; if FMainMenu.Items[i].Count > 0 then begin P := ClientToScreen(Point(R.Left, ClientHeight)); ShowPopupForm(P, FMainMenu.Items[i], FMainMenu.Images); end; end; Invalidate; Break; end; end; end; procedure TStyledMenuBar.MouseLeave; begin inherited MouseLeave; if (FPopupForm = nil) or (not FPopupForm.Visible) then begin FHotIndex := -1; Invalidate; end; end; procedure TStyledMenuBar.ShowPopupForm(P: TPoint; Items: TMenuItem; Images: TCustomImageList); var screenRect: TRect; begin if Items = nil then Exit; if FPopupForm = nil then begin FPopupForm := TStyledMenuPopup.CreateNew(Self, 0); FPopupForm.OnClosePopup := @DoPopupClose; end; FPopupForm.Images := Images; FPopupForm.MenuItems := Items; screenRect := Screen.MonitorFromPoint(P).WorkareaRect; if P.X + FPopupForm.Width > screenRect.Right then P.X := screenRect.Right - FPopupForm.Width; if P.Y + FPopupForm.Height > screenRect.Bottom then P.Y := screenRect.Bottom - FPopupForm.Height; FPopupForm.SetBounds(P.X, P.Y, FPopupForm.Width, FPopupForm.Height); FPopupForm.Show; SetCapture(FPopupForm.Handle); end; procedure TStyledMenuBar.HidePopup; begin if FPopupForm <> nil then begin FPopupForm.Hide; end; FPressedIndex := -1; FHotIndex := -1; Invalidate; end; procedure TStyledMenuBar.DoPopupClose(Sender: TObject); begin ReleaseCapture; if FPopupForm <> nil then begin FPopupForm.Release; FPopupForm := nil; end; FPressedIndex := -1; FHotIndex := -1; Invalidate; end; procedure TStyledMenuBar.Popup(X, Y: Integer; APopupMenu: TPopupMenu); begin if APopupMenu = nil then Exit; HidePopup; ShowPopupForm(Point(X, Y), APopupMenu.Items, APopupMenu.Images); end; //=========================================================== //扩展PopupMenu //=========================================================== { TPopupMenu 拦截器 } procedure TPopupMenu.SetStylePtr(Value: PPopupMenuStyle); begin RegisterStyle(Self, Value); end; function TPopupMenu.GetStylePtr: PPopupMenuStyle; begin Result := GetStyleForMenu(Self); end; procedure TPopupMenu.ApplyStyle(Style: PPopupMenuStyle); begin StylePtr := Style; end; procedure TPopupMenu.Popup(X, Y: Integer); var Frm: TSimulatedPopupForm; PStyle: PPopupMenuStyle; DefStyle: TPopupMenuStyle; // 【新增】局部变量 begin PStyle := GetStyleForMenu(Self); // 【修改】如果没有手动设置样式，则自动使用默认样式 if not Assigned(PStyle) then begin DefStyle := DefaultMenuStyle; ApplyStyle(@DefStyle); PStyle := GetStyleForMenu(Self); // 重新获取 end; // 如果还是没有（理论上不可能），则调用系统默认 if not Assigned(PStyle) then begin inherited Popup(X, Y); Exit; end; Frm := TSimulatedPopupForm.CreateNew(nil); Frm.Style := PStyle; Frm.Popup(X, Y, Self); end; { TSimulatedPopupForm (Windows & Linux Unified) } constructor TSimulatedPopupForm.CreateNew(AOwner: TComponent; Num: Integer); begin inherited CreateNew(AOwner, Num); FMenuItems := TList.Create; FSelectedIndex := -1; BorderStyle := bsNone; FormStyle := fsSystemStayOnTop; ShowInTaskBar := stNever; ControlStyle := ControlStyle + [csOpaque]; KeyPreview := True; end; destructor TSimulatedPopupForm.Destroy; begin if Assigned(FParentPopup) then FParentPopup.FChildPopup := nil; if Assigned(FChildPopup) then FreeAndNil(FChildPopup); FMenuItems.Free; inherited Destroy; end; procedure TSimulatedPopupForm.SetStyle(AValue: PPopupMenuStyle); begin FStyle := AValue; if Assigned(FStyle) then Color := FStyle^.BgColor; end; function TSimulatedPopupForm.GetImageList: TCustomImageList; begin if Assigned(FRootMenu) then Result := FRootMenu.Images else Result := nil; end; procedure TSimulatedPopupForm.DoShow; begin inherited DoShow; SetFocus; end; procedure TSimulatedPopupForm.Deactivate; begin inherited Deactivate; if Assigned(FChildPopup) and FChildPopup.Visible then Exit; CloseChain; end; procedure TSimulatedPopupForm.CloseChain; begin if Assigned(FChildPopup) then begin FChildPopup.CloseChain; FreeAndNil(FChildPopup); end; Close; end; procedure TSimulatedPopupForm.KeyDown(var Key: Word; Shift: TShiftState); var i, NewIdx: Integer; Item: TMenuItem; begin inherited; if Key = VK_ESCAPE then begin CloseChain; Key := 0; Exit; end; if Key = VK_DOWN then begin NewIdx := FSelectedIndex; repeat Inc(NewIdx); if NewIdx >= FMenuItems.Count then NewIdx := -1; until (NewIdx = -1) or (not TMenuItem(FMenuItems[NewIdx]).IsLine); if NewIdx = -1 then begin for NewIdx := 0 to FMenuItems.Count - 1 do if not TMenuItem(FMenuItems[NewIdx]).IsLine then Break; end; SetSelectedIndex(NewIdx); Key := 0; Exit; end; if Key = VK_UP then begin NewIdx := FSelectedIndex; repeat Dec(NewIdx); if NewIdx < 0 then NewIdx := -1; until (NewIdx = -1) or (not TMenuItem(FMenuItems[NewIdx]).IsLine); if NewIdx = -1 then begin for NewIdx := FMenuItems.Count - 1 downto 0 do if not TMenuItem(FMenuItems[NewIdx]).IsLine then Break; end; SetSelectedIndex(NewIdx); Key := 0; Exit; end; if Key = VK_RETURN then begin if (FSelectedIndex >= 0) then begin Item := TMenuItem(FMenuItems[FSelectedIndex]); if Item.Enabled then begin if Item.Count > 0 then ShowSubMenu(FSelectedIndex) else begin CloseChain; Item.Click; end; end; end; Key := 0; Exit; end; if Key = VK_RIGHT then begin if (FSelectedIndex >= 0) and (TMenuItem(FMenuItems[FSelectedIndex]).Count > 0) then begin ShowSubMenu(FSelectedIndex); if FChildPopup <> nil then FChildPopup.SetSelectedIndex(0); end; Key := 0; Exit; end; if Key = VK_LEFT then begin if FParentPopup <> nil then begin Close; end; Key := 0; Exit; end; i := FindItemByShortCut(Key, Shift); if i >= 0 then begin CloseChain; TMenuItem(FMenuItems[i]).Click; Key := 0; Exit; end; if (Shift = []) or (Shift = [ssAlt]) then begin i := FindItemByMnemonic(UpCase(Chr(Key))); if i >= 0 then begin Item := TMenuItem(FMenuItems[i]); if Item.Count > 0 then begin SetSelectedIndex(i); ShowSubMenu(i); end else begin CloseChain; Item.Click; end; Key := 0; Exit; end; end; end; function TSimulatedPopupForm.FindItemByMnemonic(Key: Char): Integer; var i: Integer; C: Char; begin Result := -1; for i := 0 to FMenuItems.Count - 1 do begin C := GetMnemonicChar(TMenuItem(FMenuItems[i]).Caption); if (C = Key) and (TMenuItem(FMenuItems[i]).Enabled) and (not TMenuItem(FMenuItems[i]).IsLine) then begin Result := i; Exit; end; end; end; function TSimulatedPopupForm.FindItemByShortCut(Key: Word; Shift: TShiftState): Integer; var i: Integer; SC: TShortCut; begin Result := -1; SC := Menus.ShortCut(Key, Shift); for i := 0 to FMenuItems.Count - 1 do begin if (TMenuItem(FMenuItems[i]).ShortCut = SC) and (TMenuItem(FMenuItems[i]).Enabled) then begin Result := i; Exit; end; end; end; procedure TSimulatedPopupForm.Popup(AX, AY: Integer; AMenu: TPopupMenu); var i: Integer; begin FRootMenu := AMenu; FParentPopup := nil; FMenuItems.Clear; for i := 0 to AMenu.Items.Count - 1 do FMenuItems.Add(AMenu.Items[i]); FImageList := AMenu.Images; CalculateSizes; if AX + Width > Screen.Width then AX := Screen.Width - Width; if AY + Height > Screen.Height then AY := Screen.Height - Height; Left := AX; Top := AY; Show; end; procedure TSimulatedPopupForm.Popup(AX, AY: Integer; AItem: TMenuItem; AParent: TSimulatedPopupForm); var i: Integer; begin FRootMenu := AParent.FRootMenu; FParentPopup := AParent; AParent.FChildPopup := Self; FMenuItems.Clear; for i := 0 to AItem.Count - 1 do FMenuItems.Add(AItem.Items[i]); FImageList := FRootMenu.Images; CalculateSizes; if AX + Width > Screen.Width then AX := AParent.Left - Width; if AY + Height > Screen.Height then AY := Screen.Height - Height; Left := AX; Top := AY; Show; end; procedure TSimulatedPopupForm.CalculateSizes; var i: Integer; Item: TMenuItem; H, MaxW, CurW: Integer; R: TRect; S: String; begin if not Assigned(FStyle) then Exit; Canvas.Font.Name := FStyle^.FontName; Canvas.Font.Size := FStyle^.FontSize; SetLength(FItemRects, FMenuItems.Count); MaxW := 150; for i := 0 to FMenuItems.Count - 1 do begin Item := TMenuItem(FMenuItems[i]); if Item.IsLine then Continue; CurW := FStyle^.IconSize + 10; CurW := CurW + Canvas.TextWidth(StringReplace(Item.Caption, '&', '', [rfReplaceAll])); if Item.ShortCut <> 0 then begin S := ShortCutToText(Item.ShortCut); CurW := CurW + Canvas.TextWidth(S) + 20; end; if Item.Count > 0 then CurW := CurW + 25; if CurW > MaxW then MaxW := CurW; end; R.Top := 0; for i := 0 to FMenuItems.Count - 1 do begin Item := TMenuItem(FMenuItems[i]); if Item.IsLine then H := 6 else H := Canvas.TextHeight('Wg') + (FStyle^.ItemPadding * 2); R.Left := 0; R.Right := MaxW; R.Bottom := R.Top + H; FItemRects[i] := R; R.Top := R.Bottom; end; ClientWidth := MaxW; ClientHeight := R.Top; end; procedure TSimulatedPopupForm.Paint; begin DrawMenu; end; procedure TSimulatedPopupForm.DrawMenu; var i: Integer; Item: TMenuItem; R: TRect; IconRect: TRect; TargetIconSize: Integer; TempBmp: TBitmap; ShortCutTxt: String; TextY: Integer; ArrowSpace: Integer; CenterY: Integer; TS: TTextStyle; ArrowWidth: Integer; begin if not Assigned(FStyle) then Exit; TargetIconSize := FStyle^.IconSize; Canvas.Brush.Color := FStyle^.BgColor; Canvas.FillRect(ClientRect); Canvas.Font.Name := FStyle^.FontName; Canvas.Font.Size := FStyle^.FontSize; for i := 0 to FMenuItems.Count - 1 do begin Item := TMenuItem(FMenuItems[i]); R := FItemRects[i]; if Item.IsLine then begin Canvas.Brush.Color := FStyle^.BgColor; Canvas.FillRect(R); Canvas.Pen.Color := FStyle^.SeparatorColor; CenterY := R.Top + (R.Bottom - R.Top) div 2; Canvas.Line(R.Left + TargetIconSize + 4, CenterY, R.Right - 2, CenterY); end else begin if i = FSelectedIndex then begin Canvas.Brush.Color := FStyle^.SelectedBgColor; Canvas.Font.Color := FStyle^.SelectedFontColor; Canvas.FillRect(R); end else begin Canvas.Brush.Color := FStyle^.BgColor; if Item.Enabled then Canvas.Font.Color := FStyle^.FontColor else Canvas.Font.Color := FStyle^.DisabledFontColor; end; IconRect.Left := R.Left + 2; IconRect.Right := IconRect.Left + TargetIconSize; IconRect.Top := R.Top + (R.Height - TargetIconSize) div 2; IconRect.Bottom := IconRect.Top + TargetIconSize; if Assigned(FImageList) and (Item.ImageIndex >= 0) then begin TempBmp := TBitmap.Create; try TempBmp.SetSize(TargetIconSize, TargetIconSize); TempBmp.Canvas.Brush.Color := FStyle^.BgColor; TempBmp.Canvas.FillRect(0, 0, TargetIconSize, TargetIconSize); FImageList.Draw(TempBmp.Canvas, 0, 0, Item.ImageIndex, dsNormal, itImage); Canvas.StretchDraw(IconRect, TempBmp); finally TempBmp.Free; end; end else if not Item.Bitmap.Empty then begin Canvas.StretchDraw(IconRect, Item.Bitmap); end; TextY := R.Top + FStyle^.ItemPadding; ArrowSpace := 0; // 计算箭头宽度 ArrowWidth := Canvas.TextWidth('►'); // 【修复】PopupMenu 箭头位置：右边距5像素 if Item.Count > 0 then begin ArrowSpace := ArrowWidth + 5; // 箭头宽度 + 右边距 Canvas.TextOut(R.Right - ArrowWidth - 5, R.Top + (R.Height - Canvas.TextHeight('►')) div 2, '►'); end; if Item.ShortCut <> 0 then begin ShortCutTxt := ShortCutToText(Item.ShortCut); // 位置计算：右边距 - 箭头占用空间 - 快捷键文本宽度 - 间隔5 Canvas.TextOut(R.Right - ArrowSpace - Canvas.TextWidth(ShortCutTxt) - 5, TextY, ShortCutTxt); end; TS := Canvas.TextStyle; TS.ShowPrefix := True; TS.Opaque := False; Canvas.TextStyle := TS; R.Left := TargetIconSize + 6; Canvas.TextRect(R, R.Left, TextY, Item.Caption); end; end; end; procedure TSimulatedPopupForm.SetSelectedIndex(Index: Integer); begin if FSelectedIndex <> Index then begin FSelectedIndex := Index; Invalidate; if Assigned(FChildPopup) then begin FChildPopup.Free; FChildPopup := nil; end; if (Index >= 0) then ShowSubMenu(Index); end; end; procedure TSimulatedPopupForm.ShowSubMenu(Index: Integer); var Item: TMenuItem; ChildForm: TSimulatedPopupForm; P: TPoint; begin Item := TMenuItem(FMenuItems[Index]); if (Item.Count = 0) or (not Item.Enabled) then Exit; P.X := Left + Width; P.Y := Top + FItemRects[Index].Top; ChildForm := TSimulatedPopupForm.CreateNew(nil); ChildForm.Style := FStyle; ChildForm.Popup(P.X, P.Y, Item, Self); end; procedure TSimulatedPopupForm.CMMouseLeave(var Message: TLMessage); begin if not (Assigned(FChildPopup) and FChildPopup.Visible) then SetSelectedIndex(-1); inherited; end; procedure TSimulatedPopupForm.MouseMove(Shift: TShiftState; X, Y: Integer); var i: Integer; P: TPoint; Item: TMenuItem; begin inherited; P := Point(X, Y); for i := 0 to High(FItemRects) do begin if PtInRect(FItemRects[i], P) then begin Item := TMenuItem(FMenuItems[i]); if Item.IsLine then begin SetSelectedIndex(-1); Exit; end; SetSelectedIndex(i); Exit; end; end; end; procedure TSimulatedPopupForm.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i: Integer; P: TPoint; Item: TMenuItem; Root: TSimulatedPopupForm; begin inherited; if Button <> mbLeft then Exit; P := Point(X, Y); for i := 0 to High(FItemRects) do begin if PtInRect(FItemRects[i], P) then begin Item := TMenuItem(FMenuItems[i]); if (not Item.IsLine) and Item.Enabled and (Item.Count = 0) then begin if Assigned(FRootMenu) then FRootMenu.Close; Root := Self; while Assigned(Root.FParentPopup) do Root := Root.FParentPopup; Root.CloseChain; Item.Click; end; Exit; end; end; end; initialization GStyleList := TList.Create; //RegisterClass(TPopupMenu); //RegisterClass(TMainMenu); finalization while GStyleList.Count > 0 do begin TObject(GStyleList[0]).Free; GStyleList.Delete(0); end; GStyleList.Free; end.
此内容由惯性聚合(RSS阅读器)自动聚合整理，仅供阅读参考。 原文来自 — 版权归原作者所有。