How to simulate Office XP menu look and feel

This code simulate Office XP menu look and feel, without loosing any of the menu standard functionality, RightToLeft has been taking in account in the code.

You can alter the code to give your own colors and fonts.

Note: Make sure that OnerRedraw and ParentBidiMode properties of the menu are true.

The following code is a complete form unit, with a MainMenu and ImageList.

You can download/see the example project from: http://www.shagrouni.com/english/software/menu.html

(New: XP Menu is a component now). To download:
http://www.shagrouni.com/english/software/xpmenu.html

=================
unit fMenu;

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(FMenuItem.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.