为让主菜单能下拉出颜色选单,这需要设置MainMenu的OwnerDraw为True,然后逐个画出来。
为了方便,可以先整个ColorMenu组件,然后直接拉过来用就可以了:
ColorMenu组件(代码由本人网上收集修改,建议收藏):
===================================================================================
unit ColorMenu;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Menus;
const
CPMenuWidth = 80;
CPDefItemHeight = 16;
CPColorRectWidth = 24;
type
TColorLanguage = (cpEnglish, cpChinese);
TColorMenu = class(TMenu)
private
FItemHeight: Integer;
FDisplayNames: Boolean;
FDisplayCustom: Boolean;
FColorNames: TStrings;
FLanguage: TColorLanguage;
FSelectedColor: TColor;
FCustomColor: TColor;
FOnSelectColor: TNotifyEvent;
function ShowCustomColorDlg: Boolean;
function GetColorCustomizeName: string;
procedure SetColorLanguage(Value: TColorLanguage);
procedure SetDisplayNames(Value: Boolean);
procedure InitializeMenuItems;
procedure ColorItemDrawItem(Sender: TObject; ACanvas: TCanvas;
ARect: TRect; Selected: Boolean);
procedure ColorItemMeasureItem(Sender: TObject;
ACanvas: TCanvas; var Width, Height: Integer);
procedure ColorItemClick(Sender: TObject);
protected
procedure Loaded; override;
public
procedure AddThisMenu(PMenu: TMenuItem);
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property SelectedColor: TColor read FSelectedColor;
published
property DisplayNames: Boolean read FDisplayNames write SetDisplayNames default True;
property DisplayCustom: Boolean read FDisplayCustom write FDisplayCustom default True;
property OnSelectColor: TNotifyEvent read FOnSelectColor write FOnSelectColor;
end;
procedure Register;
implementation
const
ColorCount = 16;
ColorValues: array[0..ColorCount - 1] of TColor = (
clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray,
clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite
);
CnColorNames: array[-1..ColorCount - 1] of string = (
'定制...',
'黑色', '深红色', '绿色', '橄榄色', '藏青色', '紫色', '青色', '灰色',
'银色', '红色', '浅绿色', '黄色', '蓝色', '紫红色', '浅绿色', '白色'
);
EnColorNames: array[-1..ColorCount - 1] of string = (
'Customize...',
'Black', 'Maroon', 'Green', 'Olive', 'Navy', 'Purple', 'Teal', 'Gray',
'Silver', 'Red', 'Lime', 'Yellow', 'Blue', 'Fuchsia', 'Aqua', 'White'
);
procedure Register;
begin
RegisterComponents('Samples', [TColorMenu]);
end;
{ TColorMenu }
constructor TColorMenu.Create(AOwner: TComponent);
begin
inherited;
FItemHeight := CPDefItemHeight;
FColorNames := TStringList.Create;
FDisplayNames := True;
FDisplayCustom := True;
FSelectedColor := clBlack;
SetColorLanguage(cpChinese);
end;
destructor TColorMenu.Destroy;
begin
FColorNames.Free;
inherited;
end;
procedure TColorMenu.ColorItemDrawItem(Sender: TObject;
ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
var
ColorRect: TRect;
Index, TextH: Integer;
ColorName: string;
begin
Index := (Sender as TMenuItem).Tag;
if (Index >=0) and (Index < ColorCount) or (Index = -1) then
begin
if Selected then
begin
ACanvas.Brush.Color := clActiveCaption;
ACanvas.Pen.Color := clWhite;
ACanvas.Font.Color := clWhite;
end else
begin
ACanvas.Brush.Color := clMenu;
ACanvas.Pen.Color := clBlack;
ACanvas.Font.Color := clBlack;
end;
ACanvas.FillRect(ARect);
if Index <> -1 then
ACanvas.Brush.Color := ColorValues[Index]
// 如果是"定制"项
else
ACanvas.Brush.Color := FCustomColor;
ColorRect.Left := ARect.Left + 2;;
ColorRect.Top := ARect.Top + 2;;
if FDisplayNames then
ColorRect.Right := ColorRect.Left + CPColorRectWidth
else
ColorRect.Right := ARect.Right - 2;
ColorRect.Bottom := ARect.Bottom - 2;
ACanvas.Rectangle(ColorRect);
if FDisplayNames then
begin
ACanvas.Brush.Style := bsClear;
if Index <> -1 then
ColorName := FColorNames[Index]
else
ColorName := GetColorCustomizeName;
TextH := ACanvas.TextHeight(ColorName);
ACanvas.TextOut(ColorRect.Right + 20,
ARect.Top + (ARect.Bottom - ARect.Top - TextH) div 2,
ColorName);
end;
end;
end;
procedure TColorMenu.ColorItemMeasureItem(Sender: TObject;
ACanvas: TCanvas; var Width, Height: Integer);
begin
Width := CPMenuWidth;
Height := FItemHeight;
end;
procedure TColorMenu.ColorItemClick(Sender: TObject);
var
Index: Integer;
Selected: Boolean;
begin
Index := (Sender as TMenuItem).Tag;
Selected := False;
if (Index >=0) and (Index < ColorCount) then
begin
FSelectedColor := ColorValues[Index];
Selected := True;
end;
if Index = -1 then
Selected := ShowCustomColorDlg;
if Selected and Assigned(FOnSelectColor) then
FOnSelectColor(Self);
end;
procedure TColorMenu.Loaded;
begin
inherited;
OwnerDraw := True;
InitializeMenuItems;
end;
procedure TColorMenu.InitializeMenuItems;
var
I: Integer;
MenuItem: TMenuItem;
begin
Items.Clear;
for I := 0 to ColorCount - 1 do
begin
MenuItem := TMenuItem.Create(Self);
Items.Add(MenuItem);
MenuItem.Tag := I;
end;
if FDisplayCustom then
begin
MenuItem := TMenuItem.Create(Self);
Items.Add(MenuItem);
MenuItem.Tag := -1; //"定制"项
end;
for I := 0 to Items.Count - 1 do
begin
MenuItem := Items.Items[I];
MenuItem.OnDrawItem := ColorItemDrawItem;
MenuItem.OnMeasureItem := ColorItemMeasureItem;
MenuItem.OnClick := ColorItemClick;
end;
end;
procedure TColorMenu.AddThisMenu(PMenu: TMenuItem);
var
I: Integer;
MenuItem: TMenuItem;
begin
PMenu.Clear;
for I := 0 to ColorCount - 1 do
begin
MenuItem := TMenuItem.Create(Self);
PMenu.Add(MenuItem);
MenuItem.Tag := I;
end;
if FDisplayCustom then
begin
MenuItem := TMenuItem.Create(Self);
PMenu.Add(MenuItem);
MenuItem.Tag := -1; //"定制"项
end;
for I := 0 to PMenu.Count - 1 do
begin
MenuItem := PMenu.Items[I];
MenuItem.OnDrawItem := ColorItemDrawItem;
MenuItem.OnMeasureItem := ColorItemMeasureItem;
MenuItem.OnClick := ColorItemClick;
end;
end;
function TColorMenu.ShowCustomColorDlg: Boolean;
var
ColorDlg: TColorDialog;
begin
ColorDlg := TColorDialog.Create(Application);
try
ColorDlg.Options := ColorDlg.Options;
ColorDlg.Color := FCustomColor;
Result := ColorDlg.Execute;
if Result then
begin
FCustomColor := ColorDlg.Color;
FSelectedColor := ColorDlg.Color;
end;
finally
ColorDlg.Free;
end;
end;
function TColorMenu.GetColorCustomizeName: string;
begin
if FLanguage = cpEnglish then Result := EnColorNames[-1]
else Result := CnColorNames[-1];
end;
procedure TColorMenu.SetColorLanguage(Value: TColorLanguage);
var
I: Integer;
begin
FLanguage := Value;
FColorNames.Clear;
case Value of
cpEnglish:
for I := 0 to ColorCount - 1 do
FColorNames.Add(EnColorNames[I]);
cpChinese:
for I := 0 to ColorCount - 1 do
FColorNames.Add(CnColorNames[I]);
end;
end;
procedure TColorMenu.SetDisplayNames(Value: Boolean);
begin
if FDisplayNames <> Value then
begin
FDisplayNames := Value;
end;
end;
end.
===================================================================================
安装该组件后,在Form1上添加Mainmenu1和ColorMenu1,代码如下:
===================================================================================
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, ColorMenu;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
ColorMenu1: TColorMenu;
M_Color: TMenuItem;
M_File: TMenuItem;
M_Open: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure ColorMenu1SelectColor(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
ColorMenu1.AddThisMenu(M_Color);
end;
procedure TForm1.ColorMenu1SelectColor(Sender: TObject);
begin
self.color := ColorMenu1.SelectedColor;
end;
end.
===================================================================================
最后,效果图: