Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 2838
  • Last Modified:

Change the font for a pop-up menu

I am writing software for older users.

I want to change the font used by pop-up menus in my program.

The screen.MenuFont property appears to only be for Win95 and I do not want to change the overall settings for the Windows menu font as this affects too many other programs.

I am using Delphi 6 and want the solution to work for Win98 onwards if possible

Thanks for your help - Dan
0
seabear
Asked:
seabear
  • 2
  • 2
1 Solution
 
Slick812Commented:
hello seabear, The windows system uses the menu font for mrnus so you will have to do an Owner Draw Popup menu to get the font size you want on the menu. Set the PopupMenu1 Owner Draw property to True. This code is for a menu with 4 items on it named "a1" "b1" "c1" "d1". You need to size and draw the menu items. In each of the 4 menu items OnMeasureItem event set them all to the procedure a1MeasureItem. Now set all 4 items OnAdvancedDrawItem events to the same procedure a1AdvancedDrawItem


procedure TForm1.a1MeasureItem(Sender: TObject; ACanvas: TCanvas;
  var Width, Height: Integer);
begin
ACanvas.Font.Name := 'Arial';
ACanvas.Font.Size := 18;
Width := ACanvas.TextWidth(' Item D ')+6;
Height := ACanvas.TextHeight('M')+4;
end;


procedure TForm1.a1AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; State: TOwnerDrawState);
var
mText: String;
begin
ACanvas.Font.Name := 'Arial';
ACanvas.Font.Size := 18;
if  odSelected     in State then
ACanvas.Brush.Color := clHighLight
else
ACanvas.Brush.Color := clMenu;
ACanvas.FillRect(ARect);
if Sender = a1 then
mText := 'Item A' else
if Sender = b1 then
mText := 'Item B' else
if Sender = c1 then
mText := 'Item C' else
if Sender = d1 then
mText := 'Item D';
ACanvas.TextOut(12,ARect.Top+2,mText);
end;

this should give you large text on your menu, but it doesn't give you a Disabled look or check marks, you will have to draw them if you need them. Ask questions if it's unclear
0
 
freshman3kCommented:
hello

The following component is same as TPopupmenu but it has a Font property and much more:

http://www.torry.net/vcl/menus/menuenhancments/bc_bmenu.zip

Hope this help!
0
 
freshman3kCommented:
and try this component too,it also has a font property:

http://www.torry.net/vcl/menus/menuenhancments/smnu.zip
0
 
seabearAuthor Commented:
I am going to accept Slick812's suggestion as an answer because I want a lightweight solution but thanks freshman3k for your  links to components

Here is the modified code I am now using to show  sepperator bars and to show all shortcut text  lined up

var
  Form1: TForm1;
  maxWidth, shortcutAt : integer;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
//want to create a standard width for the pop-up and
//a standard starting point for the speed key text
//in any menu caption that has them
var
    aCanvas : TCanvas;
    i, temp : integer;
begin
    screen.MenuFont.Size := 14;
    image1.Canvas.Font.Name := 'Arial';
    image1.Canvas.Font.Size := 12;
    image1.Canvas.Font.Style := [fsBold];
    maxWidth := 0;
    for i := 0 to popupmenu1.Items.Count -1 do
    begin
        temp := image1.Canvas.TextWidth(popupmenu1.Items[i].Caption);
        if temp > maxWidth then maxWidth := temp;
    end;
    maxWidth := maxWidth + image1.Canvas.TextWidth('Ctrl+W') + 12;
    shortcutAt := maxWidth  - image1.Canvas.TextWidth('Ctrl+W') + 8;
end;

procedure TForm1.N11111MeasureItem(Sender: TObject; ACanvas: TCanvas;
  var Width, Height: Integer);
begin
    Width := maxWidth;
    Height := ACanvas.TextHeight('m')+2;
end;

procedure TForm1.N11111AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; State: TOwnerDrawState);
var
    mText: String;
    shortcut : TShortcut;
begin
    ACanvas.Font.Name := 'Arial';
    ACanvas.Font.Size := 12;
    ACanvas.Font.Style := [fsBold];
    if  odSelected     in State then
        ACanvas.Brush.Color := clHighLight
    else
        ACanvas.Brush.Color := clMenu;
    ACanvas.FillRect(ARect);

    shortcut := (sender as TMenuItem).ShortCut;
    mtext := (sender as TmenuItem).caption;
    if mText = '-' then   //sepperator bar
    begin
        ACanvas.Pen.Color := clGray;
        ACanvas.MoveTo(2,ARect.Top+8);
        ACanvas.LineTo(ARect.Right - 2,ARect.Top+8);
        ACanvas.Pen.Color := clWhite;
        ACanvas.MoveTo(2,ARect.Top+9);
        ACanvas.LineTo(ARect.Right - 2,ARect.Top+9);
    end
    else //ordinary menu caption that may have a shortcut key
    begin
        ACanvas.TextOut(12,ARect.Top+2,mText);
        ACanvas.TextOut(shortcutAt,ARect.Top+2,
                                            ShortCutToText(shortcut));
    end;
end;
0
 
Slick812Commented:
You got enough to use, Here is a unit I use if I want larger or smaller or different font menu text . . . . .



unit fontMenu;
interface

uses
  Windows, Graphics, Classes, Forms, Controls, Menus, SysUtils;

type

  TFontMenu = class(TObject)
  private
    { Private declarations }
    FFont : TFont;
    procedure MeasureItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
    procedure AdvanDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
    procedure Change(Sender: TObject; Source: TMenuItem; Rebuild: Boolean);
    procedure GetSubMenus(MItem: TMenuItem);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create;
    destructor Destroy; override;
    procedure AddMenu(PM: TPopupMenu); overload;
    procedure AddMenu(MM: TMainMenu); overload;
    procedure SetMenuFont(FSize: Integer; FName: String = 'Menu79');

  end;


implementation

constructor TFontMenu.Create;
var
hFont: THandle;
NonClMetrics: TNonClientMetrics;
begin
 inherited;
NonClMetrics.cbSize := SizeOf(NonClMetrics);
SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0,@NonClMetrics,0);
hFont := CreateFontIndirect(NonClMetrics.lfMenuFont);
FFont := TFont.Create;
if hFont <> 0 then
FFont.Handle := hFont;
end;

destructor TFontMenu.Destroy;
begin
FreeAndNil(FFont);
 inherited Destroy;
end;

procedure TFontMenu.MeasureItem(Sender: TObject; ACanvas: TCanvas;
  var Width, Height: Integer);
var
ShortCut: String;
begin
if not (Sender is TMenuItem) then Exit;
ACanvas.Font := FFont;
if TMenuItem(Sender).ShortCut <> 0 then
ShortCut := ShortCutToText(TMenuItem(Sender).ShortCut)+'   ';
Width := ACanvas.TextWidth(TMenuItem(Sender).Caption+'  '+ShortCut)+9;
if TMenuItem(Sender).Caption <> '-' then
Height := ACanvas.TextHeight('M')+4
else
Height := 10;
end;

procedure TFontMenu.AdvanDrawItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; State: TOwnerDrawState);
var
mText: String;
Pos1: Integer;
begin
if not (Sender is TMenuItem) then Exit;
if TMenuItem(Sender).Caption = '-' then
  begin
  ACanvas.Pen.Color := clBtnShadow;
  ACanvas.MoveTo(1,ARect.Bottom-((ARect.Bottom-ARect.Top) div 2));
  ACanvas.LineTo(ARect.Right-1,ARect.Bottom-((ARect.Bottom-ARect.Top) div 2));
  ACanvas.Pen.Color := clBtnHighLight;
  ACanvas.MoveTo(1,ARect.Bottom-((ARect.Bottom-ARect.Top) div 2)+1);
  ACanvas.LineTo(ARect.Right-1,ARect.Bottom-((ARect.Bottom-ARect.Top) div 2)+1);
  Exit;
  end;
ACanvas.Font := FFont;

if odSelected in State then
  begin
  ACanvas.Brush.Color := clHighLight;
  ACanvas.Pen.Color := clHighLightText;
  ACanvas.Font.Color := clHighLightText;
  end else
  ACanvas.Brush.Color := clMenu;
ACanvas.FillRect(ARect);
mText := TMenuItem(Sender).Caption;
{if mText[1] = '&' then
delete(mText,1,1);}
if TMenuItem(Sender).ShortCut <> 0 then
mText := mText+'   '+ShortCutToText(TMenuItem(Sender).ShortCut);
if odDisabled in State then
  begin
  ACanvas.Font.Color := clBtnHighLight;
  Pos1 := Pos('&',mText);
  if Pos1 > 0 then
  Delete(mText,Pos1,1);
  ACanvas.TextOut(ARect.Bottom-ARect.Top+9,ARect.Top+3,mText);
  ACanvas.Brush.Style := bsClear;
  ACanvas.Font.Color := clGrayText;
  ACanvas.Pen.Color := clGrayText;
  end;
Pos1 := Pos('&',mText);
if Pos1 > 0 then
  begin
  SetTextAlign(ACanvas.Handle,TA_UPDATECP or TA_TOP);
  MoveToEx(ACanvas.Handle,ARect.Bottom-ARect.Top+8,ARect.Top+2, nil);
  if Pos1 > 1 then
    begin
    windows.TextOut(ACanvas.Handle,0,0,@mText[1],Pos1-1);
    end;
  ACanvas.Font.Style :=  [fsUnderline];
  windows.TextOut(ACanvas.Handle,0,0,@mText[Pos1+1],1);
  ACanvas.Font.Style :=  [];
  TextOut(ACanvas.Handle,0,0,@mText[Pos1+2],Length(mText)-Pos1-1);
  SetTextAlign(ACanvas.Handle,TA_TOP);
  end else
ACanvas.TextOut(ARect.Bottom-ARect.Top+8,ARect.Top+2,mText);
if Assigned(TMenuItem(Sender).Bitmap) and not TMenuItem(Sender).Bitmap.Empty then
ACanvas.StretchDraw(Rect(2,ARect.Top+1,ARect.Bottom-ARect.Top,ARect.Bottom-1),TMenuItem(Sender).Bitmap);
if odChecked in State then
  begin
  ACanvas.Pen.Width := 2;
  ACanvas.MoveTo(3,ARect.Bottom-((ARect.Bottom-ARect.Top) div 2));
  ACanvas.LineTo(((ARect.Bottom-ARect.Top) div 3)-1,ARect.Bottom-((ARect.Bottom-ARect.Top) div 4)-1);
  ACanvas.LineTo(ARect.Bottom-ARect.Top-((ARect.Bottom-ARect.Top) div 4)-1,ARect.Top+((ARect.Bottom-ARect.Top) div 4)+1);
  end;
end;

procedure TFontMenu.Change(Sender: TObject; Source: TMenuItem;
  Rebuild: Boolean);
var
n, i, Count1: Integer;
begin
Rebuild := True;
for i := 0 to TMenu(Sender).Items.Count - 1 do
    begin
    GetSubMenus(TMenu(Sender).Items[i]);
    if Sender is TPopupMenu then
      begin
      TMenu(Sender).Items[i].OnMeasureItem := MeasureItem;
      TMenu(Sender).Items[i].OnAdvancedDrawItem := AdvanDrawItem;
      end;
    end;
end;

procedure TFontMenu.GetSubMenus(MItem: TMenuItem);
var
i: Integer;
begin
if MItem.Count = 0 then Exit;
for i := 0 to MItem.Count - 1 do
  begin
  GetSubMenus(MItem.Items[i]);
  MItem.Items[i].OnMeasureItem := MeasureItem;
  MItem.Items[i].OnAdvancedDrawItem := AdvanDrawItem;
  end;
end;

procedure TFontMenu.AddMenu(PM: TPopupMenu);
var
i: Integer;
begin
PM.OwnerDraw := True;
PM.OnChange := Change;
if PM.Items = nil then Exit;
for i := 0 to PM.Items.Count - 1 do
  begin
  GetSubMenus(PM.Items[i]);
  PM.Items[i].OnMeasureItem := MeasureItem;
  PM.Items[i].OnAdvancedDrawItem := AdvanDrawItem;
  end;
end;

procedure TFontMenu.AddMenu(MM: TMainMenu);
var
i: Integer;
begin
MM.OwnerDraw := True;
MM.OnChange := Change;
if MM.Items = nil then Exit;
for i := 0 to MM.Items.Count - 1 do
  GetSubMenus(MM.Items[i]);
end;

procedure TFontMenu.SetMenuFont(FSize: Integer; FName: String = 'Menu79');
begin
if FFont.Size <> FSize then
FFont.Size := FSize;
if FName = 'Menu79' then Exit;
if FFont.Name <> FName then
FFont.Name := FName;
end;

end.



- - - - - - - - - - - - - - - - - - - - - - - - - -


put fontMenu in your uses caluse and add to your Private variables -

 FontMenu1: TFontMenu;

add these to your FormCreate

FontMenu1 := TFontMenu.Create;
FontMenu1.AddMenu(MainMenu1);
FontMenu1.AddMenu(PopupMenu1);
FontMenu1.AddMenu(PopupMenu2);
FontMenu1.SetMenuFont(16);
{or you can also add a Font name to the setMenuFont
FontMenu1.SetMenuFont(16, 'New Times Roman');}

and add the Free to your Form's onClose event

FontMenu1.Free;

this also put's check marks and Bitmaps on the menuand under lines the HotKey, but it does NOT do Image lists and Image index numbers. aybe you can get a pointer or to from it
0

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now