创建你需要的竖幅图片(可在FormCreate中写)
PopupImage := TBitmap.Create;
PopupImage.LoadFromFile(.....);
....
菜单每一项MenuMeasureItem事件都定义如下
procedure TForm1.MenuMeasureItem(Sender: TObject; ACanvas: TCanvas;
var Width, Height: Integer);
begin
Width := Width + BarWidth;{ 留出Bar的位置 }
{计算高度}
if (TMenuItem(Sender) = TMenuItem(Sender).Parent.Items[0]) then
TMenuItem(Sender).Parent.Items[0].Tag := Height
else
if TMenuItem(Sender).Visible then
TMenuItem(Sender).Parent.Items[0].Tag := TMenuItem(Sender).Parent.Items[0].Tag + Height;
end;
菜单每一项AdvancedDraw事件都定义如下
procedure TForm1.MenuAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
ARect: TRect; State: TOwnerDrawState);
const
VerticalText = 'Windows 2000'; {Bar上的文字}
{MenuBar上背景渐变:}
clStart: TColor =$00E6C9B7; {起始色}
clEnd: TColor = clBlack;{结束色}
var
i, h: Integer;
r: TRect;
rc, gc, bc: Byte;
OnAdvancedDrawItem: TAdvancedMenuDrawItemEvent;
function 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;
begin
//覆盖原有的画图事件
OnAdvancedDrawItem := TMenuItem(Sender).OnAdvancedDrawItem;
TMenuItem(Sender).OnAdvancedDrawItem := nil;
//重定义Item的位置
r := ARect;
r.Right := r.Right - BarWidth; { 减去Bar的宽度 }
OffsetRect(r, BarWidth, 0);
{ 画 item 还原原有的画图事件 }
DrawMenuItem(TMenuItem(Sender), ACanvas, r, State);
TMenuItem(Sender).OnAdvancedDrawItem := OnAdvancedDrawItem;
if TMenuItem(Sender).Parent.Items[0].Tag <> 0 then
begin
h := TMenuItem(Sender).Parent.Items[0].Tag;
for i := 0 to (ARect.Bottom - ARect.Top) do
begin
rc := GetRValue(clStart);
gc := GetGValue(clStart);
bc := GetBValue(clStart);
rc := rc + (((GetRValue(clEnd) - rc) * (ARect.Top + i)) div h);
gc := gc + (((GetGValue(clEnd) - gc) * (ARect.Top + i)) div h);
bc := bc + (((GetBValue(clEnd) - bc) * (ARect.Top + i)) div h);
ACanvas.Brush.Style := bsSolid;
ACanvas.Brush.Color := RGB(rc, gc, bc);
ACanvas.FillRect(Rect(0, ARect.Top + i, BarWidth - 2, ARect.Top + i + 1));
end;
{ MenuBar上的字体}
with ACanvas.Font do
begin
Name := 'Comic Sans MS';
Size := 10;
Color := clWhite;
Style := [fsBold];
i := Handle;
Handle := CreateRotatedFont(ACanvas.Font, 90);
end;
ACanvas.Brush.Style := bsClear;
r := Rect(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom + 1);
ExtTextOut(ACanvas.Handle, 1, h - PopupImage.Height - 7, ETO_CLIPPED,
@r, PChar(VerticalText), Length(VerticalText), nil);
DeleteObject(ACanvas.Font.Handle);
ACanvas.Font.Handle := i;
if TMenuItem(Sender)=TMenuItem(Sender).Parent.Items[TMenuItem(Sender).Parent.Count-1] then
begin
TMenuItem(Sender).Parent.Items[0].Tag := 0;
ACanvas.Draw(0, h - PopupImage.Height - 6, PopupImage);
end;
end;
end;
procedure TForm1.ExitMenuMeasureItem(Sender: TObject; ACanvas: TCanvas;
var Width, Height: Integer);
begin
Width := Width + BarWidth;{ 留出Bar的位置 }
{计算高度}
if (TMenuItem(Sender) = TMenuItem(Sender).Parent.Items[0]) then
TMenuItem(Sender).Parent.Items[0].Tag := Height
else
if TMenuItem(Sender).Visible then
TMenuItem(Sender).Parent.Items[0].Tag := TMenuItem(Sender).Parent.Items[0].Tag + Height;
end;
