1.新建一个PopupMenu1.设置OwnerDraw:=True;
2.添加一个菜单项m1.设置m1.Caption:='';
m1.Enabled:=False;
3.添加一些你需要的菜单项m2,m3,m4,…….
其中设置m2.Break:=mbBreak;
4.在m1的DrawItem中:
procedure TForm1.m1DrawItem(Sender: TObject; ACanvas: TCanvas;
ARect: TRect; Selected: Boolean);
var
i:word;
dy,y:real;
lf:TLogFont;
tf:TFont;
begin
//画渐进色背景
dy:=(ARect.Bottom - ARect.Top)/256;
y:=0;
for i:=255 downto 0 do
begin
Acanvas.brush.color:=RGB(255-i,255-i,255);
Acanvas.fillrect(rect(0,round(y),ARect.Right - ARect.Left,round(y+dy)));
y:=y+dy;
end;
//写字
With ACanvas do
Begin
Brush.Style:=bsClear;
Font.Name:='宋体';
Font.Size:=12;
Font.Color:=clred;
tf:=TFont.Create;
tf.Assign(Font);
GetObject(tf.Handle,sizeof(lf),@lf);
lf.lfEscapement:=900;
tf.Handle:=CreateFontIndirect(lf);
Font.Assign(tf);
tf.Free;
TextOut(ARect.Left +2,ARect.Bottom -2,'弹出菜单');
End;
end;
5.在m1的MeasureItem中：
procedure TForm1.m1MeasureItem(Sender: TObject; ACanvas: TCanvas;
var Width, Height: Integer);
begin
/////////
Width:= 10;
Height:= (PopupMenu1.Items.Count - 1) * 19;
end;
***********************************************
1、设置TPopupMenu的OwnerDraw为True；
2、设置TPopupMenu的Images
3、设置TMenuItem的OnMeasureItem和OnDrawItem分别指向两个例程。
这是以前我写的程序的一段代码，与大家分享(如果有什么问题，请呼我OICQ:6113690，或者写信给我，我可以写一个完整的例子):
procedure TfrmMain.pmTrayPopup(Sender: TObject);
begin
pmTray.Tag := 1; //对于左边的位图保证只绘制一次
end;
procedure TfrmMain.MenuMeasureItem(Sender: TObject; ACanvas: TCanvas;
var Width, Height: Integer);
begin
if (Sender as TMenuItem).IsLine then
Height := 4 //分隔条
else
Height := Canvas.TextHeight('高') + 6;
//const BMWidth = 位图宽度
Inc(Width, BMWidth + 7); //为左边的位图保留一些空间
end;
procedure TfrmMain.MenuDrawItem(Sender: TObject; ACanvas: TCanvas;
ARect: TRect; Selected: Boolean);
var ABitmap: TBitmap;
Item: TMenuItem;
Rc: TRect;
nLeft, nTop: Integer;
Ico: HICON;
begin
Item := Sender as TMenuItem;
ABitmap := TBitmap.Create;
try
//对于左边的位图保证只绘制一次
if (pmTray.Tag = 1) and (Item.MenuIndex = 0) then
begin
pmTray.Tag := 0;
ABitmap.LoadFromResourceID(hInstance, PostMan); //左边图形的ResourceID
CopyRect(Rc, ACanvas.ClipRect);
Rc.Left := BMWidth + 2;
CopyRect(Rc, ACanvas.ClipRect);
Rc.Right := Rc.Left + BMWidth + 2;
//用图形左下的颜色填充矩形
ACanvas.Brush.Color := ABitmap.Canvas.Pixels[0, ABitmap.Height - 1];
ACanvas.FillRect(Rc);
//绘制一个凹下的矩形框
Frame3D(ACanvas, Rc, clBtnShadow, clBtnHighlight, 1);
ACanvas.Draw(Rc.Left, Rc.Top, ABitmap);
//绘制Application图标
Ico := LoadImage(hInstance, PChar(szMainIcon), IMAGE_ICON, 16, 16,
LR_DEFAULTCOLOR);
nLeft := (BMWidth - 16) div 2 + 1;
DrawIconEx(ACanvas.Handle, nLeft, Rc.Bottom - nLeft - 16,
Ico, 16, 16, 0, 0, DI_NORMAL);
DestroyIcon(Ico);
ACanvas.Brush.Color := clBtnFace;
end;
CopyRect(Rc, ARect);
Inc(Rc.Left, BMWidth + 2);
nTop := Grade + Ord(Selected);
//绘制背景图形
ABitmap.LoadFromResourceID(hInstance, nTop);
ACanvas.CopyRect(Rc, ABitmap.Canvas, Rect(0, 0, ABitmap.Width, ABitmap.Height));
if Item.IsLine then //绘制菜单分隔条
begin
nTop := (ARect.Bottom + ARect.Top) div 2 - 1;
ACanvas.Pen.Color := clBtnShadow;
ACanvas.MoveTo(BMWidth + 3, nTop);
ACanvas.LineTo(ARect.Right, nTop);
ACanvas.Pen.Color := clBtnHighlight;
ACanvas.MoveTo(BMWidth + 3, nTop + 1);
ACanvas.LineTo(ARect.Right, nTop + 1);
end else
begin
nTop := (Rc.Bottom + Rc.Top - imglstState.Height) div 2;
nLeft := Rc.Left + (Rc.Bottom - Rc.Top - imglstState.Width) div 2 + 2;
if Selected then //绘制被选择菜单的外观
begin
with Rc do
Right := Left + Bottom - Top;
DrawEdge(ACanvas.Handle, Rc, BDR_RAISEDINNER, BF_RECT);
Inc(Rc.Left, Rc.Bottom - Rc.Top + 1);
Rc.Right := ARect.Right;
DrawEdge(ACanvas.Handle, Rc, BDR_SUNKENOUTER, BF_RECT);
end;
//绘制菜单前面的小图形，一个TImageList
imglstState.Draw(ACanvas, nLeft - 1, nTop, Item.ImageIndex, Item.Enabled);
CopyRect(Rc, ARect);
InflateRect(Rc, -1, -1);
Inc(Rc.Left, BMWidth + ARect.Bottom - ARect.Top + 6);
ACanvas.Brush.Style := bsClear;
if not Item.Enabled then
begin
OffsetRect(Rc, 1, 1);
ACanvas.Font.Color := clBtnHighlight;
end else
with ACanvas.Font do
if Selected then Color := clRed else Color := clBtnText;
ACanvas.Brush.Style := bsClear;
if Item.Enabled or (not Selected) then
DrawText(ACanvas.Handle, PChar(Item.Caption), Length(Item.Caption), Rc,
DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS);
if not Item.Enabled then
begin
OffsetRect(Rc, -1, -1);
ACanvas.Font.Color := clBtnShadow;
DrawText(ACanvas.Handle, PChar(Item.Caption), Length(Item.Caption), Rc,
DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS);
end;
end;
finally
ABitmap.Free;
end;
end;
*******************************
收集的，也用过了，借花献佛：）
const
BarWidth = 23; // 类似于开始菜单的popmenu的宽度
BarSpace = 3;
type
TFormMain = class(TForm)
......
......
private
{ Private declarations }
function CreateRotatedFont(F: TFont; Angle: Integer): hFont;
procedure ExpandItemWidth(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
procedure AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
public
{ Public declarations }
PopupImage: TBitmap; { icon in the bar }
PopupHeight: Integer; { holds the popumenu height }
PopupBitmap: TBitmap; { buffer for the bar }
Drawn: Boolean; { tells us if buffer has been drawn }
end;
//////////////////////////////////////////////////////////////////////////////////////////////
// 生成类似于开始菜单的popmenu
procedure TFormmain.ExpandItemWidth(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
begin
Inc(Width, BarWidth); // make space for graphical bar
// way to calculate total height of menu to PopupHeight variable which was reset at OnPopup event
if TMenuItem(Sender).Visible then PopupHeight := PopupHeight + Height;
end;
procedure TFormmain.AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
const
VerticalText = '静态页面生成系统';
clStart: TColor = clBlue;
clEnd: TColor = clBlack;
var
i, iTmp: Integer;
r: TRect;
rc1, rc2, gc1, gc2, bc1, bc2: Byte;
ColorStart, ColorEnd: Longint;
MenuItem: TMenuItem;
begin
MenuItem := TMenuItem(Sender);
{ we need to remove draw event so DrawMenuItem won't generate infinite loop! (Recursive) }
MenuItem.OnAdvancedDrawItem := nil;
{ align rect where item is draw so that vcl will leave bar for us }
r := ARect;
Dec(r.Right, BarWidth); // remove bar width
OffsetRect(r, BarWidth, 2);
DrawMenuItem(MenuItem, ACanvas, r, State); // draw item and restore event back
MenuItem.OnAdvancedDrawItem := AdvancedDrawItem;
PopupBitmap.Height := PopupHeight;
PopupBitmap.Width := BarWidth - BarSpace;
with PopupBitmap.Canvas do
if not Drawn then
begin // ... first draw phase ... }
Brush.Style := bsSolid;
if (clStart = clEnd) then // same color, just one fillrect required
begin
Brush.Color := clStart;
FillRect(Rect(0, ARect.Top, BarWidth - BarSpace, ARect.Bottom));
end
else //draw smooth gradient bar part for this item
begin
// this way we can use windows color constants e.g. clBtnFace. Those constant don't keep the RGB values
ColorStart := ColorToRGB(clStart);
ColorEnd := ColorToRGB(clEnd);
// get the color components here so they are faster to access inside the loop
rc1 := GetRValue(ColorStart);
gc1 := GetGValue(ColorStart);
bc1 := GetBValue(ColorStart);
rc2 := GetRValue(ColorEnd);
gc2 := GetGValue(ColorEnd);
bc2 := GetBValue(ColorEnd);
// make sure that division by zero doesn't happen
if PopupHeight <> 0 then
for i := 0 to (ARect.Bottom - ARect.Top) do
begin
Brush.Color := RGB(
(rc1 + (((rc2 - rc1) * (ARect.Top + i)) div PopupHeight)),
(gc1 + (((gc2 - gc1) * (ARect.Top + i)) div PopupHeight)),
(bc1 + (((bc2 - bc1) * (ARect.Top + i)) div PopupHeight)));
FillRect(Rect(0, ARect.Top + i, BarWidth - BarSpace, ARect.Top + i + 1));
end;
end;
with Font do
begin
Name := 'Tahoma';
Size := 9;
Color := clWhite;
Style := [fsBold];
iTmp := Handle; { store old }
Handle := CreateRotatedFont(Font, 90);
end;
Brush.Style := bsClear;
r := Rect(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom + 1);
ExtTextOut(Handle, 1, PopupHeight - PopupImage.Height - 15, ETO_CLIPPED, @r, PChar(VerticalText), Length(VerticalText), nil);
DeleteObject(Font.Handle); // delete created font and restore old handle
Font.Handle := iTmp;
if PopupHeight = ARect.Bottom then
begin // draw bitmap
Drawn := True;
Draw(0, PopupHeight - PopupImage.Height - 6, PopupImage);
end;
{ draw the double buffered bar now }
r := Rect(0, 0, PopupBitmap.Width, ARect.Bottom);
ACanvas.CopyRect(r, PopupBitmap.Canvas, r);
end
else // draw from double buffer
begin
r := Rect(0, ARect.Top, PopupBitmap.Width, ARect.Bottom);
ACanvas.CopyRect(r, PopupBitmap.Canvas, r);
end;
{ end with }
end;
function TFormmain.CreateRotatedFont(F: TFont; Angle: Integer): hFont;
var LF : TLogFont;
begin
FillChar(LF, SizeOf(LF), #0);
with LF do
begin
lfHeight := F.Height;
lfWidth := 0;
lfEscapement := Angle*10;
lfOrientation := 0;
if fsBold in F.Style then lfWeight := FW_BOLD
else lfWeight := FW_NORMAL;
lfItalic := Byte(fsItalic in F.Style);
lfUnderline := Byte(fsUnderline in F.Style);
lfStrikeOut := Byte(fsStrikeOut in F.Style);
lfCharSet := DEFAULT_CHARSET;
StrPCopy(lfFaceName, F.Name);
lfQuality := DEFAULT_QUALITY;
lfOutPrecision := OUT_DEFAULT_PRECIS;
lfClipPrecision := CLIP_DEFAULT_PRECIS;
case F.Pitch of
fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
fpFixed: lfPitchAndFamily := FIXED_PITCH;
else
lfPitchAndFamily := DEFAULT_PITCH;
end;
end;
Result := CreateFontIndirect(LF);
end;
// popmenu弹出事件 //
procedure TFormMain.PopupMenuIconPopup(Sender: TObject);
var i:integer;
begin
Drawn := False;
PopupHeight := 0;
with TPopupMenu(Sender) do
if (Items.Count > 0) then
for i := 0 to Items.Count-1 do
begin
Items[i].OnMeasureItem := ExpandItemWidth;
Items[i].OnAdvancedDrawItem := AdvancedDrawItem;
end;
end;
// end of menu create like start
////////////////////////////////////////////////////////////////////////////////////////////