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;
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;
Comment