تغيير فونت در منوي دلفي

[shirin71]

قبل از هر چيز يك پروژه جديد باز كنيد واز پالت win32 يك عنصر imagelistرو به فرم اضافه كنيدهمچنين از پالت standard يك عنصر mainmenu را به فرم اضافه كنيد.خاصيتهاي OwnerRedraw و ParentBidiMode

مربوط بهmainmenu را TRUE كنيد.حالا منوی دلخواه خودتون رو تنظيم كنيد

و كدهای زير رو در يونيت فرم يك جايگزين كنيد.
فونتی كه در كد استفاده شده و بارنگ قرمز متمايز شده TAHOMAاست كه شما بدلخواه می تونيد اون رو تغيير بديد .

همچنين با تغييرات مورد دلخواه در بلوکی که با رنگ سبز متمايز شده ميتونيد رنگ خطوط پس زمينه ناحيه انتخابی- پس زمينه کل منو همچنين حاشيه دور ناحيه انتخابی واز همه مهمتر رنگ فونت رو تغيير بديد




Code:

unit UNIT1;

interface

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

type
TForm1 = class(TForm)
ImageList1: TImageList;
MainMenu1: TMainMenu;
FileMenu: TMenuItem;
procedure DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
procedure FormCreate(Sender: TObject);
private
procedure MenueDrawItemX(xMenu: TMenu);
public
end;
procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
MenueDrawItemX(Menu);
end;

procedure TForm1.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
begin
MenueDrawItem(Sender, ACanvas, ARect, Selected);
end;

procedure TForm1.MenueDrawItemX(xMenu: TMenu);
var
i: integer;
B: TBitmap;
FMenuItem: TMenuItem;
begin
B := TBitmap.Create;
B.Width := 1;
B.Height := 1;

for i := 0 to ComponentCount - 1 do
if Components[i] is TMenuItem then
begin
FMenuItem := TMenuItem(Components[i]);
FMenuItem.OnDrawItem := DrawItem;
if (FMenuItem.ImageIndex = -1) and
(FMenuItem.Bitmap.width = 0) and (xMenu <> nil) then
if FMenuItem.GetParentComponent.Name <> xMenu.Name then
FMenuItem.Bitmap.Assign(b);
end;

B.Free;
DrawMenuBar(handle);


end;


procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
var
txt: string;
B: TBitmap;

IConRect, TextRect: TRect;
FBackColor, FIconBackColor, FSelectedBkColor, FFontColor, FSelectedFontColor,
FDisabledFontColor, FSeparatorColor, FCheckedColor: TColor;

i, X1, X2: integer;
TextFormat: integer;
HasImgLstBitmap: boolean;
FMenuItem: TMenuItem;
FMenu: TMenu;

begin
FMenuItem := TMenuItem(Sender);
FMenu := FMenuItem.Parent.GetParentMenu;

FBackColor := $00E1E1E1;
FIconBackColor := $00D1D1D1;
FSelectedBkColor := $00DCCFC7;

FFontColor := clBlack;
FSelectedFontColor := clNavy;
FDisabledFontColor := clGray;
FSeparatorColor := $00D1D1D1;
FCheckedColor := clGray;

if FMenu.IsRightToLeft then
begin
X1 := ARect.Right - 20;
X2 := ARect.Right;
end
else
begin
X1 := ARect.Left;
X2 := ARect.Left + 20;
end;
IConRect := Rect(X1, ARect.Top, X2, ARect.Bottom);

TextRect := ARect;
txt := ' ' + FMenuItem.Caption;

B := TBitmap.Create;

B.Transparent := True;
B.TransparentMode := tmAuto;

HasImgLstBitmap := false;
if (FMenuItem.Parent.GetParentMenu.Images <> nil) or
(FMenuItem.Parent.SubMenuImages <> nil) then
begin
if FMenuItem.ImageIndex <> -1 then
HasImgLstBitmap := true
else
HasImgLstBitmap := false;
end;

if HasImgLstBitmap then
begin
if FMenuItem.Parent.SubMenuImages <> nil then
FMenuItem.Parent.SubMenuImages.GetBitmap(FMenuItem .ImageIndex, B)
else
FMenuItem.Parent.GetParentMenu.Images.GetBitmap(FM enuItem.ImageIndex, B)
end
else
if FMenuItem.Bitmap.Width > 0 then
B.Assign(TBitmap(FMenuItem.Bitmap));

if FMenu.IsRightToLeft then
begin
X1 := ARect.Left;
X2 := ARect.Right - 20;
end
else
begin
X1 := ARect.Left + 20;
X2 := ARect.Right;
end;
TextRect := Rect(X1, ARect.Top, X2, ARect.Bottom);

ACanvas.brush.color := FBackColor;
ACanvas.FillRect(TextRect);

if FMenu is TMainMenu then
for i := 0 to FMenuItem.GetParentMenu.Items.Count - 1 do
if FMenuItem.GetParentMenu.Items[i] = FMenuItem then
begin
ACanvas.brush.color := FIConBackColor;
ACanvas.FillRect(ARect);
if (FMenuItem.ImageIndex = -1) and (FMenuItem.Bitmap.width = 0) then
begin
TextRect := ARect;
break;
end;
end;

ACanvas.brush.color := FIconBackColor;
ACanvas.FillRect(IconRect);

if FMenuItem.Enabled then
ACanvas.Font.Color := FFontColor
else
ACanvas.Font.Color := FDisabledFontColor;

if Selected then
begin
ACanvas.brush.Style := bsSolid;
ACanvas.brush.color := FSelectedBkColor;
ACanvas.FillRect(TextRect);

ACanvas.Pen.color := FSelectedFontColor;

ACanvas.Brush.Style := bsClear;
ACanvas.RoundRect(TextRect.Left, TextRect.top, TextRect.Right,
TextRect.Bottom, 6, 6);

if FMenuItem.Enabled then
ACanvas.Font.Color := FSelectedFontColor;
end;

X1 := IConRect.Left + 2;
if B <> nil then
ACanvas.Draw(X1, IConRect.top + 1, B);

if FMenuItem.Checked then
begin
ACanvas.Pen.color := FCheckedColor;
ACanvas.Brush.Style := bsClear;
ACanvas.RoundRect(IconRect.Left, IconRect.top, IconRect.Right,
IconRect.Bottom, 3, 3);
end;

if not FMenuItem.IsLine then
begin
SetBkMode(ACanvas.Handle, TRANSPARENT);

ACanvas.Font.Name := 'Tahoma';
if FMenu.IsRightToLeft then
ACanvas.Font.Charset := ARABIC_CHARSET;

if FMenu.IsRightToLeft then
TextFormat := DT_RIGHT + DT_RTLREADING
else
TextFormat := 0;


if FMenuItem.Default then
begin
Inc(TextRect.Left, 1);
Inc(TextRect.Right, 1);
Inc(TextRect.Top, 1);
ACanvas.Font.color := clGray;
DrawtextEx(ACanvas.Handle,
PChar(txt),
Length(txt),
TextRect, TextFormat, nil);

Dec(TextRect.Left, 1);
Dec(TextRect.Right, 1);
Dec(TextRect.Top, 1);

ACanvas.Font.color := FFontColor;
end;

DrawtextEx(ACanvas.Handle,
PChar(txt),
Length(txt),
TextRect, TextFormat, nil);

txt := ShortCutToText(FMenuItem.ShortCut) + ' ';

if FMenu.IsRightToLeft then
TextFormat := DT_LEFT
else
TextFormat := DT_RIGHT;

DrawtextEx(ACanvas.Handle,
PChar(txt),
Length(txt),
TextRect, TextFormat, nil);
end
else
begin
ACanvas.Pen.Color := FSeparatorColor;
ACanvas.MoveTo(ARect.Left + 10,
TextRect.Top +
Round((TextRect.Bottom - TextRect.Top) / 2));
ACanvas.LineTo(ARect.Right - 2,
TextRect.Top +
Round((TextRect.Bottom - TextRect.Top) / 2))
end;


B.free;


end;

end.