Solved

Change the font for a pop-up menu

Posted on 2002-06-10
5
2,410 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
ID: 7069125
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
ID: 7070190
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
ID: 7070211
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
ID: 7079467
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
ID: 7079882
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Path  to current project in Delphi. 2 71
how do you get these � Marks in your text? 9 74
SUM 2 INTEGER ARRAYS INTO 1 10 93
Firemonkey DbLookupComboBox equivalent ? 2 32
A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
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…
A short film showing how OnPage and Connectwise integration works.

914 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

14 Experts available now in Live!

Get 1:1 Help Now