Problem bei eigener XP-MainMenu VCL

[Christian Ruppert]

Hi!
Ich programmiere gerade eine XP-Komponente, welche das MainMenu im XP-Stil darstellen soll. Hier der Code meiner Komponente:

<PRE>
unit XPMainMenu;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus;
type
TXPMainMenu = class(TMainMenu)
private
FForm : TForm;
procedure Activate(MenuItem: TMenuItem);
procedure DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
procedure MeasureItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
protected
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
public
function Draw : Boolean;
function Init : Boolean;
procedure MenueDrawItemX(xMenu: TMenu);
procedure ItrateMenu(MenuItem: TMenuItem);
published
{ Published-Deklarationen }
end;
procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
procedure Register;
implementation
constructor TXPMainMenu.Create(AOwner : TComponent);
var FFComponent : TComponent;
begin
inherited Create(AOwner);
FForm := TForm(AOwner);
FFComponent := AOwner;
while (FFComponent <> nil) and (not (FFComponent is TForm)) do
FFComponent := FForm.Owner;
if FForm is TForm then
FFComponent := TForm(FForm);
end;
destructor TXPMainMenu.Destroy;
begin
inherited Destroy;
end;
procedure TXPMainMenu.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
begin
MenueDrawItem(Sender, ACanvas, ARect, Selected);
end;
procedure TXPMainMenu.Activate(MenuItem: TMenuItem);
begin
if True then
begin
if (not assigned(MenuItem.OnDrawItem)) then
MenuItem.OnDrawItem := DrawItem;
if (not assigned(MenuItem.OnMeasureItem)) then
MenuItem.OnMeasureItem := MeasureItem;
end
else
begin
if addr(MenuItem.OnDrawItem) = addr(TXPMainMenu.DrawItem) then
MenuItem.OnDrawItem := nil;
if addr(MenuItem.OnMeasureItem) = addr(TXPMainMenu.MeasureItem) then
MenuItem.OnMeasureItem := nil;
end;
end;
procedure TXPMainMenu.MeasureItem(Sender: TObject; ACanvas: TCanvas;
var Width, Height: Integer);
var
s: string;
W, H: integer;
P: TPoint;
IsLine: boolean;
begin
S := TMenuItem(Sender).Caption;
if S = '-' then IsLine := true else IsLine := false;
if IsLine then
if IsLine then
S := '';
if Trim(ShortCutToText(TMenuItem(Sender).ShortCut)) <> '' then
S := S + ShortCutToText(TMenuItem(Sender).ShortCut) + 'WWW';
W := ACanvas.TextWidth(s);
if pos('&', s) > 0 then
W := W - ACanvas.TextWidth('&')+15;
W := W + P.x + 60;
if Width < W then
Width := W;
if IsLine then
Height := 10
else
begin
H := ACanvas.TextHeight(s)+8;
if P.y + 4 > H then
H := P.y + 4;
if Height < H then
Height := H;
end;
end;
procedure TXPMainMenu.ItrateMenu(MenuItem: TMenuItem);
var
i: integer;
begin
Activate(MenuItem);
for i := 0 to MenuItem.Count - 1 do
ItrateMenu(MenuItem.Items[i]);
end;
function TXPMainMenu.Init : Boolean;
var i, x : integer;
begin
for i := 0 to FForm.ComponentCount - 1 do
begin
if FForm.Components[i] is TMainMenu then
begin
for x := 0 to TMainMenu(FForm.Components[i]).Items.Count - 1 do
begin
TMainMenu(FForm.Components[i]).OwnerDraw := True;
ItrateMenu(TMainMenu(FForm.Components[i]).Items[x]);
end;
end;
if FForm.Components[i] is TPopupMenu then
begin
for x := 0 to TPopupMenu(FForm.Components[i]).Items.Count - 1 do
begin
TPopupMenu(FForm.Components[i]).OwnerDraw := True;
ItrateMenu(TMainMenu(FForm.Components[i]).Items[x]);
end;
end;
end;
end;
function TXPMainMenu.Draw : Boolean;
begin
MenueDrawItemX(Self);
end;
procedure TXPMainMenu.MenueDrawItemX(xMenu: TMenu);
var
i: integer;
B: TBitmap;
FMenuItem: TMenuItem;
begin
B := TBitmap.Create;
B.Width := 1;
B.Height := 1;
for i := 0 to Self.Items.Count-1 do
Items[i].OnDrawItem := DrawItem;
B.Free;
DrawMenuBar(handle);
end;

[Christian Ruppert]

Fortsetzung:

<PRE>
procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
var i : integer;
txt: string;
B: TBitmap;
IconRect, TextRect : TRect;
FBackColor, FIconBackColor, FSelectedBkColor, FFontColor, FSelectedFontColor,
FDisabledFontColor, FSeparatorColor, FCheckedColor: TColor;
X1, X2: integer;
TextFormat: integer;
HasImgLstBitmap: boolean;
FMenuItem: TMenuItem;
FMenu: TMenu;
begin
FMenuItem := TMenuItem(Sender);
FMenu := FMenuItem.Parent.GetParentMenu;
FBackColor := clWhite;
FIconBackColor := clBtnFace;
FSelectedBkColor := $00C9AFA7;
FFontColor := clBlack;
FSelectedFontColor := clBlack;
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.Brush.Style := bsClear;
if FMenuItem.Enabled then
ACanvas.Font.Color := FSelectedFontColor;
ACanvas.brush.color := FSelectedBkColor;
ACanvas.FillRect(IconRect);
ACanvas.RoundRect(0, TextRect.top, X2,
TextRect.Bottom, 0, 0);
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 :

[Christian Ruppert]

<PRE>
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;
procedure Register;
begin
RegisterComponents('XPStyle', [TXPMainMenu]);
end;
end.
</PRE>

Ich habe dabei 2 Probleme:
1.) Die Untereinträge werden ja so dargestellt, wie ich das möchte, aber wenn ich die Haupteinträge selektiere funktioniert das nur beim ersten Eintrag. Die weiteren Einträge nach rechts hin, sorgen dafür, dass die voranstehenden überzeichnet werden (einfach mal austesten, wenn ihr nicht wisst, was ich genau meine - es fällt einem direkt auf). Wie kann ich das Problem lösen?
2.) Wie kann ich die Untereinträge Vertikal zentrieren?

Gruß Christia

[Oliver Killguß]

Hallo Christian,

falls es dich interessiert findest du selbige Komponente auf der Delphi Superpage (nach XPMenu suchen) die bereits recht gute Ergebnisse liefert. Wozu denn noch selbst so etwas entwickeln? Übrigens der Quellcode ist auch dabei.

Gruss Ol