推荐一个导航菜单控件 (50分)

  • 主题发起人 glhglhglh
  • 开始时间
G

glhglhglh

Unregistered / Unconfirmed
GUEST, unregistred user!
速达软件都有一个导航菜单，使用非常方便，我用Delphi 写了一个类似的控件,
支持D5,D6
欢迎大家参考、试用，如果有什么意见和建议，请留下墨宝，以便参考。谢谢!!!!

此控件包含三个文件
MyMenu.Pas 控件主文件
Glh.inc Delphi 版本兼容性设置
MenuReg.Pas 组件编辑器注册
图标文件不便上传，请自行编辑面板图标
需要设置相关路径和所需要的包

将控件所在的路径加入包搜索路径中




unit MyMenu;

//////////////////////////////////////////////////
// 导航菜单 V0.02 //
// 设计:甘论洪 glh@163.net //
// 2002.07.20 //
// //
//////////////////////////////////////////////////



{说明
1.此控件继承与TWinControl,相关帮助请参阅Delphi的TWinControl帮助.
2.控件功能请参见代码中的说明.
3.你可以将此控件用于任何环境，无需注册，也无需任何费用.
4.如果你将此控件转手他人使用，必须公布此控件的原码,
此控件部分也不能要求除发行成本外的其他费用.
5.软件作者不对由使用此控件造成的任何损失负责.
6.如果你修改了控件代码，烦请将修改部分告诉我，
如果你愿意，可以将你修改的部分集成到新版本中.
}

{
修改历史
2002.07.30 V0.01 首次发布
2002.08.06 V0.02 增加了图形设置，缺省值设置

}
{$I GLH.Inc}
interface

uses
Windows, Messages, SysUtils,Extctrls, Classes, Graphics, Controls, Forms,ImgList,
{$IFDEF GLH_LIB_dELPHI_6} Variants,{$ENDIF}
Dialogs,Commctrl;
type

TOnSelect=Procedure(TSendor:TComponent;Index:Integer;Caption:String) Of Object;

TMenuItemSaveInfo=(msColor,msMouseMoveColor,msSelectColor,msFont);
TMenuItemSaveInfos=Set Of TMenuItemSaveInfo;

TGlhMEnuItem=Class;
TGlhMEnuItems=Class;

//导航菜单
TglhMenuBar = class(TCustomControl)
private
FBKColor:TColor;
FMouseMoveIndex:Integer;
FSelectIndex:Integer;
FUseMouseMoveColor:Boolean;
FUseSelectColor:Boolean;
FItemHeight:Integer;
FitemVDistence:Integer;
FOnselect:TOnselect;
FMouseMove:Boolean;
FColumnCount:Integer;
FItemWidth:Integer;
FItemHDistence:Integer;
fKeepSelect:Boolean;
fglhMenuitems:TglhMEnuItems;
fImages:TCustomImageList;
fChangeLink:TChangeLink;
fDefaultColor:TColor;
fDefaultFont:TFont;
fDefaultMouseMOveColor:TColor;
fDefaultSelectColor:TColor;
FDefaultontSaved:Boolean;

//属性设置程序

Procedure SetBKColor(Value:TColor);
Procedure SetItemHeight(Value:Integer);
Procedure SetItemVDistence(Value:Integer);
Procedure SetglhMenuItems(Value:TglhMenuItems);
Procedure SetUseSelectColor(Value:Boolean);
Procedure SetUseMouseMoveColor(Value:Boolean);
Procedure SetColumnCount(Value:Integer);
Procedure SetItemWidth(Value:Integer);
Procedure SetItemHDistence(Value:Integer);
Procedure SetImageList(Value: HImageList);
Procedure SetIMages(Value:TCustomImageList);

Procedure SetDefaultColor(VAlue:TColor);
Procedure SetDefaultMouseMoveColor(VAlue:TColor);
Procedure SetDefaultSelectColor(VAlue:TColor);
Procedure SetDefaultFont(VAlue:TFont);


Function GetItemRect(Index:Integer):TRect;
//计算指定菜单项的位置


Procedure IMageListChange(Sender:TObject);
//ImageList改变 事件处理

Procedure DefaultFontChanged(Sender:TObject);
//DefaultFont改变 事件处理


Function IsDefaultFontSaved:Boolean;
//是否保存字体属性到dfm 文件中

procedure WMSize(var Msg: TWMSize); message WM_SIZE;
procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;

{ Private declarations }
protected
procedure Paint;override;


Procedure PaintItem(Index:Integer);
//画指定菜单项

Function MouseToItem(X,y:Integer):Integer;
//根据鼠标位置计算所在的菜单项

procedure MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer); Override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;


{ Protected declarations }
public

Constructor Create(Aowner:TComponent);Override;
//构造函数

Destructor Destroy;Override;
//析构函数
{ Public declarations }
published
Property Align;
//停靠位置


Property BKColor:TColor Read FBKColor Write SetBKColor Default clTeal;
//导航菜单背景色

Property ItemHeight:Integer Read FItemHeight Write SetItemHeight Default 50;
//菜单项的高度

Property ItemVDistence:Integer Read FItemVDistence Write SetItemVDistence Default 10;
//菜单项垂直方向的间距


Property ItemHDistence:Integer Read FItemHDistence Write SetItemHDistence Default 10;
//菜单项水平方向的间距（停靠位置为Top 、Bottom 或None 时有效)

Property GlhMenuItems:TGlhMenuItems Read FGlhMenuItems Write SetGlhMenuItems;


Property OnSelect:TOnselect Read FOnselect Write FOnSelect;
//选择菜单项时产生的事件


Property UseSelectColor:Boolean Read FUseSelectColor Write SetuseSelectColor Default true;
//菜单项选择时使用颜色


Property UseMouseMoveColor:Boolean Read FuseMouseMoveColor Write SetuseMouseMoveColor default false;
//鼠标在菜单项上移动时使用颜色


Property ColumnCount:Integer Read FColumnCount Write SetColumnCount Default 0;
//导航菜单的列数（停靠位置为Top 、Bottom 或None 时有效)



Property ItemWidth:Integer Read FItemWidth Write SetItemWidth Default 0;
//菜单项的宽度（停靠位置为Top 、Bottom 或None 时有效)


Property KeepSelect:Boolean Read FKeepSelect Write fKeepSelect Default true;
//一直保持菜单选择项


Property Images:TCustomImageList Read fImages Write SetIMages;
//图形来源


Property DefaultColor:TColor Read fDefaultColor Write SetDefaultColor Default $00D7C8A8;
//MenuItem的缺省颜色值

Property DefaultMouseMoveColor:TColor Read fDefaultMouseMoveColor Write SetDefaultMouseMoveColor Default clAqua;
//MenuItem的缺省鼠标移动时的颜色值

Property DefaultSelectColor:TColor Read fDefaultSelectColor Write SetDefaultSelectColor Default $008FD2DA;
//MenuItem的选中时的缺省颜色值

Property DefaultFont:TFont Read fDefaultFont Write SetDefaultFont Stored IsDefaultFontSaved;
//MenuItem的缺省字体值
{ Published declarations }
end;
//菜单项
TglhMenuItem=Class(TCollectionItem)
Private
fFont:TFont;
fColor:TColor;
fMouseMOveColor:TColor;
fSelectColor:TColor;
fCaption:String;
fNormalImageIndex:TImageIndex;
fMouseMoveImageIndex:TIMageIndex;
fSelectImageIndex:TIMageIndex;
fMenuItemSaveInfos:TMEnuItemSaveInfos;
//字体改变事件处理
Procedure FontChanged(Sender: TObject) ;

//属性设置
Procedure SetFont(Value:TFont);
Procedure SetColor(Value:TColor);
Procedure SetMouseMoveColor(Value:TColor);
Procedure SetSelectColor(Value:TColor);

Procedure SetCaption(Value:String);
Procedure SetNormalImageIndex(Value:TIMageIndex) ;
Procedure SetMouseMoveImageIndex(Value:TIMageIndex);
Procedure SetSelectImageIndex(Value:TIMageIndex);

//是否保存属性到dfm文件
Function IsFontStored:Boolean;
Function IsColorStored:Boolean;
Function IsMouseMoveColorStored:Boolean;
Function IsSelectColorStored:Boolean;

//取缺省设置
Function DefaultFont:TFont;
Function DefaultColor:TColor;
Function DefaultMouseMOveColor:TColor;
Function DefaultSelectColor:TColor;

//取Item 所在的MenuBar
Function GetMenuBar:TglhMenuBar;

Protected
//菜单项在属性编辑器中的显示内容
FUNCTION GetDisplayName:String;Override;
Public
//构造函数
Constructor Create(Collection:TCollection);Override;
//析构函数
Destructor Destroy;Override;
//对象复制
Procedure Assign(Source:Tpersistent);Override;

//处理MenuBar的缺省设置
Procedure RefreshDefaultFont;
Procedure RefreshDefaultColor;
Procedure RefreshDefaultMouseMoveColor;
Procedure RefreshDefaultSelectColor;

Published
//标题
Property Caption:String Read FCaption Write SetCaption;
//标题字体
Property Font:TFont Read FFOnt Write SetFont Stored IsFontStored;

//菜单项颜色
Property Color:TColor Read FColor Write SetColor Stored IsColorStored;

//鼠标移动时的颜色
Property MouseMoveColor:TColor Read FMouseMoveColor Write SetMouseMoveColor Stored IsMOuseMOveColorStored;

//菜单项选中时的颜色
Property SelectColor:TColor Read FSelectColor Write SetSelectColor Stored IsSelectColorStored;

//菜单正常图标
Property NormalImageIndex:TIMageIndex Read fNormalImageIndex Write SetNormalImageIndex Default -1;

//鼠标在菜单上移动时的图标
Property MOuseMOveImageIndex:TIMageIndex Read fMOuseMOveImageIndex Write SetMOuseMOveImageIndex Default -1;

//菜单选中时的图标
Property SelectImageIndex:TIMageIndex Read fSelectImageIndex Write SetSelectImageIndex Default -1;

END;


//菜单项集合
TGlhMenuItems=Class(TCollection)
Private
FglhMenuBar:TglhMenuBAr;
//取指定菜单项
Function GetItem(Index:Integer):TGlhMenuItem;
//设置指定菜单项
Procedure SetItem(Index:Integer;Value:TGlhMenuItem);

Protected


//菜单项改变时刷新
Procedure Update(Item: TCollectionItem);Override;
Public
//构造函数
Constructor Create(aOwner:TGlhMenuBar);
//Destructor Destroy;Override;
//增加菜单项
Function Add:TGlhMenuItem;

//取所有者
Function GetOwner:Tpersistent;Override;
//菜单象列表
Property Items[Index:Integer]:TGlhMenuItem Read GetItem Write SetItem;Default;
Published
END;


procedure Register;

implementation

Constructor TglhMenuBar.Create(Aowner:TComponent);
BEGIN

Inherited Create(aowner);
fGlhMenuItems:=TGlhMEnuitems.Create(Self);
fChangeLink:=TChangeLink.Create;
fChangeLink.OnChange :=Self.IMageListChange;
self.KeepSelect :=true;
fDefaultFont:=TFont.Create ;
self.FDefaultontSaved :=false;

Self.fDefaultColor :=$00D7C8A8;
Self.fDefaultMouseMoveColor:=clAqua;
Self.fDefaultSelectColor:=$008FD2DA;

Self.fDefaultFont.Name :='宋体';
Self.fDefaultFont.Size :=18;
Self.fDefaultFont.Style :=[fsBold];
Self.fDefaultFont.Charset :=GB2312_CHARSET;
Self.fDefaultFont.OnChange:=SELF.DefaultFontChanged;

Self.Width:=150;
self.Align :=alLeft;
self.BkColor:=clTeal;
Self.ItemHeight:=50;
Self.ItemVDistence :=10;
Self.ItemHDistence :=10;
FMouseMoveIndex:=-1;
FSelectIndex:=-1;
FColumnCount:=1;

self.UseMouseMoveColor :=false;
Self.UseSelectColor :=true;
END;

Destructor TglhMenuBar.Destroy;
BEGIN
fGlhMenuItems.Free ;
fchangelink.Free ;
fDefaultFont.Free ;
Inherited Destroy;
END;

procedure TglhMenuBar.Paint;
var
i:Integer;
begin

IF Not KeepSelect THEN
BEGIN
self.FMouseMoveIndex :=-1;
self.FSelectIndex :=-1;
END;
Self.Canvas.Brush.Color:=self.BKColor;
self.Canvas.Pen.Color :=self.BKColor;
self.Canvas.Rectangle(0,0,width,height);
FOR I:=0 TO Self.FglhMenuitems.Count-1 DO
BEGIN
Paintitem(I);
END;
end;

Procedure TglhMenuBar.PaintItem(Index:Integer);
Var
R:Trect;
x,y,IMageIndex:Integer;
BEGIN


IF SELF.FGlhMEnuItems.items[Index].Caption ='' THEN Exit;
r:=self.GetItemRect(Index);
Self.Canvas.Brush.Color:=self.glhMEnuItems[Index].Color ;
ImageIndex:=self.GlhMenuItems[Index].NormalImageIndex ;

IF (FMouseMoveIndex=Index) AND (UseMouseMoveColor) THEN
Self.Canvas.Brush.Color:=self.GlhMenuItems[Index].MouseMoveColor ;

IF (FMouseMoveIndex=Index) THEN
ImageIndex:=Self.GlhMenuItems[Index].MOuseMOveImageIndex ;




IF (FSelectIndex=Index) AND UseSelectColor THEN
Self.Canvas.Brush.Color:=self.GlhMenuItems[Index].SelectColor;

IF (FSelectIndex=Index) THEN
ImageIndex:=Self.GlhMenuItems[Index].SelectImageIndex ;


Self.Canvas.Pen.Color:=Self.GlhMenuItems[Index].Color ;
DrawFrameControl(Self.canvas.handle,r,DFC_BUTTON ,DFCS_BUTTONPUSH );

R.Top:=R.Top +1;
R.Left :=R.Left +1;
R.Right :=R.Right -1;
R.Bottom :=R.Bottom -1;
self.Canvas.Rectangle(r);

self.Canvas.Font.Assign(self.GlhMenuItems[Index].Font) ;


x:=2;
IF Assigned(Self.IMages) AND (IMageIndex<>-1) THEN
BEGIN
Y:=R.Top+rOUND((R.Bottom-R.Top-sELF.Images.Height)/2);
sELF.Images.Draw(Self.Canvas,x,y,IMageIndex);
X:=Self.Images.Width +15;
END;

y:=round(r.top+(r.Bottom-r.Top-self.Canvas.TextHeight('甘'))/2);
self.Canvas.TextOut(R.LEFT+x,Y,Self.GlhMenuItems.Items[Index].Caption );

END;

Function TglhMenuBar.MouseToItem(X,y:Integer):Integer;
VAR
I:Integer;
fRect:TRect;
BEGIN

Result:=-1;
FOR I:=0 TO FglhMenuItems.Count -1 DO
begin
fRect:=Self.GetItemRect(i);
IF (x>=frect.Left) AND (x<=fRect.Right) AND (y>=frect.Top) AND (y<=frect.Bottom) THEN
begin
result:=I;
exit;
end;
end;
END;

Procedure TglhMenuBar.SetBKColor(Value:TColor);
BEGIN
FBKColor:=Value;
Invalidate;
END;


Procedure TglhMenuBar.SetItemHeight(Value:Integer);
BEGIN
FitemHeight:=Value;
Invalidate;
END;

Procedure TglhMenuBar.SetUseSelectColor(Value:Boolean);
BEGIN

FUseSelectColor:=Value;

END;

Procedure TglhMenuBar.SetUseMouseMoveColor(Value:Boolean);
BEGIN
FUseMouseMoveColor:=Value;

END;

Procedure TglhMenuBar.SetItemVDistence(Value:Integer);
BEGIN
FitemVDistence:=Value;
Invalidate;
END;

Procedure TglhMenuBar.SetglhMenuItems(Value:TglhMenuItems);
BEGIN
Self.fglhMenuitems.assign(Value);

END;

procedure TglhMenuBar.SetImageList(Value: HImageList);
var
BarInfo: TReBarInfo;
begin
if HandleAllocated then
begin
if Value = 0 then
RecreateWnd
else
begin
//BarInfo.cbSize := SizeOf(TReBarInfo);
//BarInfo.fMask := RBIM_IMAGELIST;
//BarInfo.himl := Value;
//Perform(RB_SETBARINFO, 0, Integer(@BarInfo));
//Invalidate;
end;
end;
end;

Procedure TglhMenuBar.SetImages(Value:TCustomImageList);
VAR
I:Integer;
BEGIN
if FImages <> nil then FImages.UnRegisterChanges(FChangeLink);
FImages := Value;
if FImages <> nil then
begin
FImages.RegisterChanges(FChangeLink);
FImages.FreeNotification(Self);
SetImageList(FImages.Handle);
end
else
SetImageList(0);

{FOR I:=0 TO Self.GlhMenuItems.Count-1 DO
BEGIN
Self.GlhMenuItems.NormalImageIndex :=-1;
Self.GlhMenuItems.SelectImageIndex :=-1;
Self.GlhMenuItems.MOuseMOveImageIndex:=-1;
END;}
END;

Procedure TglhMenuBar.SetColumnCount(Value:Integer);
BEGIN
IF (Align =alLeft) OR (align=alRight) THEN EXIT;
IF (FColumnCount<>Value) AND (Value>0) THEN
BEGIN
FColumnCount:=Value;
InValidate;
END;
END;

Procedure TglhMenuBar.SetDefaultColor(VAlue:TColor);
var
I:Integer;
BEGIN
IF fDefaultColor<>Value THEN
BEGIN
fDefaultColor:=Value;
FOR I:=0 TO Self.GlhMenuItems.Count -1 DO
Self.GlhMenuItems.RefreshDefaultColor ;

END;
END;

Procedure TglhMenuBar.SetDefaultMouseMoveColor(VAlue:TColor);
var
I:Integer;
BEGIN
IF fDefaultMouseMoveColor<>Value THEN
BEGIN
fDefaultMouseMoveColor:=Value;
FOR I:=0 TO Self.GlhMenuItems.Count -1 DO
Self.GlhMenuItems.RefreshDefaultMOuseMOveColor;

END;

END;

Procedure TglhMenuBar.SetDefaultSelectColor(VAlue:TColor);
Var
i:Integer;
BEGIN
IF fDefaultSelectColor<>Value THEN
BEGIN
fDefaultSelectColor:=Value;
FOR I:=0 TO Self.GlhMenuItems.Count -1 DO
Self.GlhMenuItems.RefreshDefaultSelectColor;

END;

END;

Procedure TglhMenuBar.SetDefaultFont(VAlue:TFont);
var
I:Integer;
BEGIN
Self.FDefaultontSaved:=true;
fDefaultFont.Assign(Value);
FOR I:=0 TO Self.GlhMenuItems.Count -1 DO
Self.GlhMenuItems.RefreshDefaultFont ;

END;

Procedure TglhMenuBar.SetItemWidth(Value:Integer);
BEGIN
IF (Align =alLeft) OR (align=alRight) THEN EXIT;
IF FItemWidth<>Value THEN
BEGIN
FItemWidth:=Value;
InValidate;
END;

END;

Procedure TglhMenuBar.SetItemHDistence(Value:Integer);
BEGIN
//IF (Align =alLeft) OR (align=alRight) THEN EXIT;
IF FItemHDistence<>Value THEN
BEGIN
FItemHDistence:=Value;
InValidate;
END;

END;


procedure TglhMenuBar.MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);
VAR
ItemIndex:Integer;
OldIndex:Integer;
BEGIN
OldIndex:=FSelectIndex;
ItemIndex:=Mousetoitem(x,y);
FSelectIndex:=ItemIndex;
if OldIndex<>FSelectIndex THEN
BEGIN
IF OldIndex<>-1 THEN
PaintItem(OldIndex);
IF FSelectIndex<>-1 THEN
PaintItem(FSelectIndex);
END;
IF ItemIndex<>-1 THEN
BEGIN
IF ASSIGNED(FOnselect) THEN
FOnselect(sELF,ItemIndex,Self.GlhMenuitems.Items[itemindex].Caption);
END;

END;

procedure TglhMenuBar.MouseMove(Shift: TShiftState; X, Y: Integer);
VAR
ItemIndex:Integer;
OldIndex:Integer;
BEGIN

IF Not UseMouseMoveColor THEN EXIT;

OldIndex:=FMouseMoveIndex;
ItemIndex:=Mousetoitem(x,y);
IF ItemIndex=OldIndex THEN EXIT;
IF ItemIndex=-1 THEN
BEGIN
IF FMouseMoveIndex<>-1 THEN
begin
FMouseMoveIndex:=-1 ;
PaintItem(OldIndex);
end
END
ELSE
BEGIN

FMouseMoveIndex:=ItemIndex;
PaintItem(FMouseMoveIndex);
IF (FMouseMoveIndex<>OldIndex) and (OldIndex<>-1) THEN
BEGIN

PaintItem(OldIndex);
END;



END;
END;

Procedure TglhMenuBar.IMageListChange(Sender:TObject);
BEGIN
if HandleAllocated and (Sender = Images) then
BEGIN
if Images.HandleAllocated then
SetImageList(Images.Handle)
else
SetImageList(0);
END;
END;

Procedure TglhMenuBar.DefaultFontChanged(Sender:TObject);
Var
I:Integer;
BEGIN
Self.FDefaultontSaved:=true;
FOR I:=0 TO Self.GlhMenuItems.Count -1 DO
Self.GlhMenuItems.RefreshDefaultFont ;

END;

Function TglhMenuBar.GetItemRect(Index:Integer):TRect;
var
ItemX,ItemY:Integer;
BEGIN
IF (Align=alRight) OR (align=alLeft) THEN
BEGIN
Result.Top:=Index*(Self.ItemHeight +self.ItemVDistence);
Result.Bottom:=Result.Top +Self.ItemHeight;
result.Left :=0;
Result.Right :=self.Width ;
END
ELSE
BEGIN
Itemy:=Round(int(Index/ColumnCount));
Itemx:=Index-ItemY*ColumnCount;
Result.Left :=itemx*(ItemWidth+ItemHDistence);
Result.Right:=result.Left +ItemWidth;
result.Top :=ItemY*(ItemHeight+ItemVDistence);
Result.Bottom :=Result.Top +itemHeight;
END;


END;

procedure TglhMenuBar.WMSize(var Msg: TWMSize);
BEGIN
Inherited;
IF (Self.Align=alTop) Or (Self.Align=alBottom) Or (Self.Align=alNone) THEN
BEGIN
IF Self.ColumnCount=1 THEN
BEGIN
Self.ColumnCount :=3;

Self.Height:=(Self.ItemHeight+Self.ItemVDistence)*Round((self.GlhMenuItems.Count+3)/3);
END;
IF Self.ItemWidth =0 THEN
Self.ItemWidth:=round(Self.Width/3)-Self.ItemHDistence; ;

END;
Invalidate;
END;

procedure TglhMenuBar.CMMouseLeave(var Msg: TMessage);
begin
IF Self.KeepSelect =false THEN
BEGIN
Self.FMouseMoveIndex:=-1;
Self.FSelectIndex:=-1;
Invalidate;
END;
Inherited;
end;

Function TglhMenuBar.IsDefaultFontSaved:Boolean;
BEGIN
Result:=Self.FDefaultontSaved;
END;

//TglhMenuItem
Constructor TglhMenuitem.Create(Collection:TCollection);
BEGIN
Inherited Create(Collection);

self.fFont:=TFont.Create;

Self.fColor :=$00D7C8A8;
Self.fMouseMoveColor:=clAqua;
Self.fSelectColor:=$008FD2DA;
Self.fFont.Name :='宋体';
Self.fFont.Size :=18;
Self.fFont.Style :=[fsBold];
Self.fFont.Charset :=GB2312_CHARSET;

ffont.OnChange:=self.FontChanged;
self.NormalImageIndex:=-1;
self.SelectImageIndex:=-1;
Self.MOuseMOveImageIndex:=-1;
END;

Destructor TglhMenuitem.Destroy;
BEGIN
fFont.Free ;
Inherited Destroy;
END;

Procedure TglhMenuitem.Assign(Source:Tpersistent);
BEGIN
IF Source Is TglhMenuItem THEN
BEGIN
FCaption:=TglhMenuItem(Source).Caption;
fColor:=TglhMenuItem(Source).Color;
FMouseMOveColor:=TglhMenuItem(Source).MouseMOveColor;
FSelectColor:=TglhMenuItem(Source).SelectColor;
fNormalImageIndex:=TglhMenuItem(Source).NormalImageIndex;
fMouseMoveImageIndex:=TglhMenuItem(Source).MouseMoveImageIndex;
fSelectImageIndex:=TglhMenuItem(Source).SelectImageIndex;
fFont.Assign(TglhMenuItem(Source).Font);

END;

END;

Procedure TglhMenuitem.RefreshDefaultFont;
var
Save: TNotifyEvent;
begin
IF msFont In fMenuitemSaveInfos THEN EXIT;
Save:=ffOnt.OnChange ;
ffont.OnChange :=Nil;
Try
fFont.Assign(DefaultFont);
finally
ffont.OnChange :=Save;
ENd;
Self.GetMenuBar.Invalidate ;
END;

Procedure TglhMenuitem.RefreshDefaultColor;
BEGIN
IF msColor In fMenuitemSaveInfos THEN EXIT;
Self.fColor:=DefaultColor;
self.GetMenuBar.Invalidate ;
END;

Procedure TglhMenuitem.RefreshDefaultMouseMoveColor;
BEGIN
IF msMouseMoveColor In fMenuitemSaveInfos THEN EXIT;
Self.fMouseMoveColor:=DefaultMouseMoveColor;
END;

Procedure TglhMenuitem.RefreshDefaultSelectColor;
BEGIN
IF msSelectColor In fMenuitemSaveInfos THEN EXIT;
Self.fSelectColor:=DefaultSelectColor;

END;

Procedure TglhMenuitem.SetMouseMoveColor(Value:TColor);
BEGIN
IF FMouseMoveColor<>Value THEN
BEGIN
Include(fMenuitemSaveInfos,msMouseMoveColor);
FMouseMoveColor:=Value;
changed(false);
END;
END;

Procedure TglhMenuitem.SetSelectColor(Value:TColor);
BEGIN
IF FSelectColor<>Value THEN
BEGIN
Include(fMenuitemSaveInfos,msSelectColor);
FSelectColor:=Value;
changed(false);
END;
END;

Procedure TglhMenuitem.SetColor(Value:TColor);
BEGIN
IF FColor<>Value THEN
BEGIN
Include(fMenuitemSaveInfos,msColor);
FColor:=Value;
changed(false);
END;
END;

Procedure TglhMenuitem.SetNormalImageIndex(Value:TIMageIndex);
BEGIN
IF Self.fNormalImageIndex<>Value THEN
BEGIN
Self.fNormalImageIndex:=Value;
Self.Changed(false);
END;
END;

Procedure TglhMenuitem.SetMouseMoveImageIndex(Value:TIMageIndex);
BEGIN
IF Self.fMouseMoveImageIndex<>Value THEN
BEGIN
Self.fMouseMoveImageIndex:=Value;
Self.Changed(false);
END;
END;

Procedure TglhMenuitem.SetSelectImageIndex(Value:TIMageIndex);
BEGIN
IF Self.fSelectImageIndex<>Value THEN
BEGIN
Self.fSelectImageIndex:=Value;
Self.Changed(false);
END;
END;

Procedure TglhMenuitem.SetFont(Value:TFont);
BEGIN
Include(fMenuitemSaveInfos,msFOnt);
FFont.Assign(Value);
Changed(false);
END;

Procedure TglhMenuitem.SetCaption(Value:String);
BEGIN
fCaption:=VAlue;
Changed(false);
END;

Function TglhMenuitem.IsFontStored:Boolean;
BEGIN
Result:=(msFont In FMenuItemSaveInfos);
END;

Function TglhMenuitem.IsColorStored:Boolean;
BEGIN
Result:=(msColor In FMenuItemSaveInfos);
END;

Function TglhMenuitem.IsMouseMoveColorStored:Boolean;
BEGIN
Result:=(msMouseMOveColor In FMenuItemSaveInfos);
END;

Function TglhMenuitem.IsSelectColorStored:Boolean;
BEGIN
Result:=(msSelectColor In FMenuItemSaveInfos);
END;


Function TglhMenuitem.DefaultFont:TFont;
var
fMEnuBar:TglhMenuBar;
BEGIN
fMenuBAr:=Self.GetMenuBar;
IF Assigned(fMEnuBAr) THEN
Result:=fMEnubar.DefaultFont
ELSE
Result:=self.Font ;
END;

Function TglhMenuitem.DefaultColor:TColor;
var
fMEnuBar:TglhMenuBar;
BEGIN
fMenuBAr:=Self.GetMenuBar;
IF Assigned(fMEnuBAr) THEN
Result:=fMenuBAr.DefaultColor
ELSE
Result:=Self.Color ;

END;

Function TglhMenuitem.DefaultMouseMOveColor:TColor;
var
fMEnuBar:TglhMenuBar;
BEGIN
fMenuBAr:=Self.GetMenuBar;
IF Assigned(fMEnuBAr) THEN
Result:=fMEnubar.DefaultMouseMoveColor
ELSE
Result:=self.MouseMoveColor ;
END;

Function TglhMenuitem.DefaultSelectColor:TColor;
var
fMEnuBar:TglhMenuBar;
BEGIN
fMenuBAr:=Self.GetMenuBar;
IF Assigned(fMEnuBAr) THEN
Result:=fMEnubar.DefaultSelectColor
ELSE
Result:=self.SelectColor ;
END;

Function TglhMenuitem.GetMenuBar:TglhMenuBar;
BEGIN
IF (Assigned(Collection)) AND (Collection Is TGlhMenuItems) THEN
BEGIN
Result:=TglhMenuItems(Collection).fGlhMenuBar;
END
ELSE
BEGIN
Result:=Nil;
END;


END;

FUNCTION TglhMenuitem.GetDisplayName:String;
BEGIN
Result:=self.Caption;
IF Result='' THEN
Result:=Inherited GetdisplayName;
END;

Procedure TglhMenuitem.FontChanged(Sender: TObject) ;
BEGIN
Include(fMenuitemSaveInfos,msFOnt);
Changed(false);
END;

//TglhMenuItems
Constructor TGlhMenuItems.Create(aOwner:TGlhMenuBar);
BEGIN
Inherited Create(TGlhMenuItem);
fGlhMenuBar:=aOwner;
END;

Function TGlhMenuItems.Add:TGlhMenuItem ;
BEGIN
Result:=TGlhMenuItem(Inherited Add);
END;

Function TGlhMenuItems.GetOwner:TPersistent;
BEGIN
Result:=fGlhMenuBar;
END;

Procedure TGlhMenuItems.Update(Item: TCollectionItem);
BEGIN
Self.FglhMenuBar.Invalidate;
END;

Function TGlhMenuItems.GetItem(Index:Integer):TGlhMenuItem;
BEGIN
Result:=TGlhMenuItem(Inherited GetItem(Index));
END;

Procedure TGlhMenuItems.SetItem(Index:Integer;Value:TGlhMenuItem);
BEGIN
Inherited SetItem(Index,Value);
END;

procedure Register;
begin
RegisterComponents('glh', [TglhMenuBar]);

end;

end.


//glh.inc

//////////////////////////////////////////
// //
// Delphi 版本兼容性设置 //
// //
// 设计:甘论洪 glh@163.net //
//////////////////////////////////////////


{$IFDEF VER100} { Borland Delphi 3.0 }
{$MESSAGE ERROR 'This version don't support Delphi 3' }
{$ENDIF}

{$IFDEF VER110} { C++Builder 3.0 }
{$MESSAGE ERROR 'This version don't support C++Builder 3' }
{$ENDIF}

{$IFDEF VER120} { Borland Delphi 4.0 }
{$MESSAGE ERROR 'This version don't support Delphi 4 ' }
{$ENDIF}

{$IFDEF VER125} { CPP Builder 4.0 }
{$MESSAGE ERROR 'This version don't support C++Builder 3' }
{$ENDIF}

{$IFDEF VER130} { Borland Delphi 5.0 or CPP Builder 5.0 }
{$DEFINE GLH_LIB_DELPHI_5}
{$ENDIF}

{$IFDEF VER140} { Borland Delphi 6.0 }
{$DEFINE GLH_LIB_DELPHI_6}
{$ENDIF}


//{$D-}
//{$LOCALSYMBOLS OFF}
//{$REFERENCEINFO OFF}
//{$ASSERTIONS OFF}






unit MenuReg;
//////////////////////////////////////////////////
// 属性编辑器、组件编辑器注册 //
// 设计:甘论洪 glh@163.net //
// 2002.07.20 //
// //
//////////////////////////////////////////////////


{$I glh.inc}
interface
uses
Windows,SysUtils,forms,Classes,db,
Dialogs,controls,imglist,graphics,ColnEdit,
{$IFDEF GLH_LIB_dELPHI_6} Variants, DesignEditors,VCLEditors, DesignIntf,{$ENDIF}
{$IFDEF GLH_LIB_dELPHI_5} DsgnIntf,{$ENDIF}
MyMenu;


Type
//导航菜单组件编辑器
TglhMenuEditor = class(TComponentEditor)
public
//执行选择的项目
procedure ExecuteVerb(Index: Integer); override;

//组件编辑器的标题
function GetVerb(Index: Integer): string; override;

//组件编辑器的命令数量
function GetVerbCount: Integer; override;
end;


//ImageIndex属性编辑器
TBaseImageIndexProperty = class(TIntegerProperty
{$IFDEF GLH_LIB_dELPHI_6} ,ICustomPropertyDrawing, ICustomPropertyListDrawing{$Endif})
private

protected
//取ImageList对象 各IMageIndex属性编辑器需覆盖此方法
function GetImages: TCustomImageList; virtual;Abstract;


property Images: TCustomImageList read GetImages;
public
//返回属性编辑器风格设置
function GetAttributes: TPropertyAttributes; override;

//生成属性编辑器的显示的值列表
procedure GetValues(Proc: TGetStrProc); override;

//计算每个可选择单元的宽度
{$IFDEF GLH_LIB_dELPHI_6}
procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas;var AWidth: Integer);
{$ENDIF}
{$IFDEF GLH_LIB_dELPHI_5}
procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas;var AWidth: Integer); override;
{$ENDIF}



//计算每个可选择单元的高度
{$IFDEF GLH_LIB_dELPHI_6}
procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas;var AHeight: Integer);
{$ENDIF}
{$IFDEF GLH_LIB_dELPHI_5}
procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas;var AHeight: Integer); override;
{$ENDIF}

//画弹出列表
{$IFDEF GLH_LIB_dELPHI_6}
procedure ListDrawValue(const Value: string; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
{$ENDIF}
{$IFDEF GLH_LIB_dELPHI_5}
procedure ListDrawValue(const Value: string; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); override;
{$ENDIF}


{$IFDEF GLH_LIB_dELPHI_6}
//画属性值
procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
//画属性名称
procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
{$EndIf}
end;
//TGlhMenu的ImageIndex属性编辑器
TMenuItemImageIndexProperty=Class(TBaseIMageIndexProperty)
Protected
//取ImageList;
Function GEtImages:TCustomImageList;Override;
End;

Procedure Register;

implementation

//组件编辑器的标题
function TglhMenuEditor.GetVerb(Index: Integer): string;
begin
Case Index Of
0:Result:='Items...';
1:Result:='About...';

END;
end;

//执行选择的项目
procedure TglhMenuEditor.ExecuteVerb(Index: Integer);
begin
Case Index of

0:ShowCollectionEditorClass(Designer, TCollectionEditor, Component,TGlhMenuBar(Component).GlhMenuItems, 'GlhMenuItems');
1:ShowMessage('设计：甘轮洪'+chr(13)+'EMail glh@163.net');
end;

end;

//组件编辑器的命令数量
function TglhMenuEditor.GetVerbCount: Integer;
begin
Result := 2;
end;



//返回属性编辑器风格设置
function TBaseImageIndexProperty.GetAttributes: TPropertyAttributes;
begin
Result := inherited GetAttributes + [paValueList];
end;

//生成属性编辑器的显示的值列表
procedure TBaseImageIndexProperty.GetValues(Proc: TGetStrProc);
var
I: Integer;
begin
Proc('-1');
if Images = nil then Exit;
for I := 0 to Images.Count - 1 do
Proc(IntToStr(I));


end;

//计算每个可选择单元的宽度
procedure TBaseImageIndexProperty.ListMeasureWidth(const Value: string; ACanvas: TCanvas;
var AWidth: Integer);
begin
inherited;
if Images <> nil then
Inc(AWidth, 1 + Images.Width + 1);
end;

//计算每个可选择单元的高度
procedure TBaseImageIndexProperty.ListMeasureHeight(const Value: string; ACanvas: TCanvas;
var AHeight: Integer);
begin
inherited;
if (Images <> nil) and (AHeight < 1 + Images.Height + 1) then
AHeight := 1 + Images.Height + 1;
end;

//画弹出列表
procedure TBaseImageIndexProperty.ListDrawValue(const Value: string; ACanvas: TCanvas;
const ARect: TRect; ASelected: Boolean);
var
ATextRect: TRect;
PrevBrushColor: TColor;
begin
ATextRect := ARect;
if Images <> nil then
begin
Inc(ATextRect.Left, 1 + Images.Width + 1);
with ARect do
begin
PrevBrushColor := ACanvas.Brush.Color;
ACanvas.Brush.Color := clWindow;
ACanvas.FillRect(Rect(Left, Top, ATextRect.Left, Bottom));
ACanvas.Brush.Color := PrevBrushColor;
end;
Images.Draw(ACanvas, ARect.Left + 1, ARect.Top + 1, StrToInt(Value));
end;
with ATextRect, ACanvas do
ACanvas.TextRect(ATextRect, Left + 1, (Top + Bottom - TextHeight(Value)) div 2, Value);
end;
{$IFDEF GLH_LIB_dELPHI_6}
procedure TBaseImageIndexProperty.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
BEGIN
DefaultPropertyDrawValue(Self, ACanvas, ARect);
END;

procedure TBaseImageIndexProperty.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
BEGIN
DefaultPropertyDrawName(Self, ACanvas, ARect);
END;
{$ENDIF}

Function TMenuItemImageIndexProperty.GEtImages:TCustomImageList;
BEGIN
Result :=TGlhMenuBar( TglhMenuItems(TGlhMEnuItem(GetComponent(0)).Collection).GetOwner).Images;
END;

Procedure Register;
BEGIN
RegisterComponentEditor(TglhMenuBar,TglhMenuEditor);
RegisterPropertyEditor(TypeInfo(TIMageIndex),TGlhMenuItem,'NormalImageIndex',TMenuItemImageIndexProperty);
eND;
end.
 
好东西，没人进来顶顶，不像话啊
 
up,谢谢楼主.
 
不好用。
 
有没有屏幕捷图？不想贸然装上。
 
等我试一下，看看效果先
 

To bigroute:希望详细说明如何不好用，或者如何才好用，
这样我可以参考你的意见修改程序！！

最新修改
1.将组件编辑器中的About 和Items.. 换了位置，鼠标双击控件时直接进入菜单项编辑
2.修改了Align 改变为altop、alBottom、alNone 时无初始数据，显示不好.

最近开发计划
1.增加Item的缺省数据，在未进行菜单项个性化设置时统一使用缺省值，这样可以统一控制.
2.增加图形属性，在菜单 项中根据选择情况显示指定图形.
3.增加帮助文件
4.菜单显示美化.
 
大哥：
能共享原码，给我们新手们一个学习的机会，不错呀，
先感谢你了。
 
还可以，继续努力，大家~
 
这个帖太长，先结束，待完成相关功能后在出新贴，希望大家继续支持
 
多人接受答案了。
 
V0.02已发布:
http://www.delphibbs.com/delphibbs/dispq.asp?lid=1247312
 
同志，您的SelectImageIndex是怎么跟ImageList相连的啊，我也做了一个这样的属性的
东东，但是没有像Toolbar一样把ImageList的东东都列出来啊，只能当做Integer类型
来做：(，高手，帮我一下，我看Toolbar里的代码也没看出什么东东，是不是跟action
有关啊
 
诸葛兄：
久未上网，实在抱歉。在 MenuReg.Pas 中有属性编辑器的辕马，你可以参考!
 
您必须登录或注册才可回复。

Similar threads

Q
我初学,自己照书上写了个组件,可是在组件面板上没有显示!源码如下(100分)
回复
6
查看
132
qingfei
Q
Y
我写的一个构件，继承于tLabel,想实现在鼠标在文字上方时鼠标为crHandPoint,链接为红色.....(100分)
回复
4
查看
100
ynfly
Y
D
学习写一个控件，但是得不到结果(100分)
回复
5
查看
155
JohnsonGuo
J
黎
ReportPart控件的新版！续动态表列打印问题！ (0分)
回复
15
查看
89
黎永欢
黎
A
很急的问题，关于TCollection，不惜分数请教 (200分)
回复
6
查看
107
awing
A
顶部