Solved

Change the font for a pop-up menu

Posted on 2002-06-10
5
2,368 Views
Last Modified: 2013-12-02
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
Comment
Question by:seabear
  • 2
  • 2
5 Comments
 
LVL 33

Expert Comment

by:Slick812
Comment Utility
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
 
LVL 2

Expert Comment

by:freshman3k
Comment Utility
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
 
LVL 2

Expert Comment

by:freshman3k
Comment Utility
and try this component too,it also has a font property:

http://www.torry.net/vcl/menus/menuenhancments/smnu.zip
0
 

Author Comment

by:seabear
Comment Utility
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
 
LVL 33

Accepted Solution

by:
Slick812 earned 200 total points
Comment Utility
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

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

In this tutorial I will show you how to use the Windows Speech API in Delphi. I will only cover basic functions such as text to speech and controlling the speed of the speech. SAPI Installation First you need to install the SAPI type library, th…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
Here's a very brief overview of the methods PRTG Network Monitor (https://www.paessler.com/prtg) offers for monitoring bandwidth, to help you decide which methods you´d like to investigate in more detail.  The methods are covered in more detail in o…

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

7 Experts available now in Live!

Get 1:1 Help Now