创建一个类似Win98的StartMenu.

[TeamD]

现在把源程序附上。
unit mainfrm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, StdCtrls;

type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
Exit1: TMenuItem;
N1: TMenuItem;
PrintSetup1: TMenuItem;
Print1: TMenuItem;
N2: TMenuItem;
SaveAs1: TMenuItem;
Save1: TMenuItem;
Open1: TMenuItem;
New1: TMenuItem;
Button1: TButton;
procedure PopupMenu1Popup(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
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;

var
Form1: TForm1;

const
BarWidth=31;
BarSpace = 2;
implementation

{$R *.DFM}

procedure TForm1.PopupMenu1Popup(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;

procedure TForm1.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 TForm1.AdvancedDrawItem(Sender: TObject;
ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
const
VerticalText = 'Winamp Slider!';
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, 0);

{ draw item and restore event back }
DrawMenuItem(MenuItem, ACanvas, r, State);
MenuItem.OnAdvancedDrawItem := AdvancedDrawItem;
{ set buffer bitmap to right size }
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 := 14;
Color := clWhite;
Style := [fsBold, fsItalic];

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 - 7,
ETO_CLIPPED, @r, PChar(VerticalText), Length(VerticalText),
nil);

{ delete created font and restore old handle }
DeleteObject(Font.Handle);
Font.Handle := iTmp;
//**********************************
if PopupHeight = ARect.Bottom then
begin
Drawn := True;

{ draw bitmap }
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 TForm1.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;

procedure TForm1.FormCreate(Sender: TObject);
var
f: TFileStream;
begin
PopupBitmap := TBitmap.Create;

{ load bitmap from file, this could be resources too }
PopupImage := TBitmap.Create;
PopupImage.Transparent := True;

// PopupImage.LoadFromResourceName(hInstance, 'POPUPIMAGE1');

f := TFileStream.Create('popupicon.bmp', fmOpenRead);
PopupImage.LoadFromStream(f);
f.Free;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
PopupImage.Free;
PopupBitmap.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
PopupMenu1.Popup(Left,Top+22);
end;

end.

[TeamD]

popupicon.bmp文件要小。。。