如何作出象OICQ那样的彩色POPUPMENU？参与有分

Question

var Bitmap:TBitmap;
procedure TForm1.ddd1DrawItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; Selected: Boolean);
begin
        ACanvas.Draw(0,0,Bitmap);
end;
procedure TForm1.ddd1MeasureItem(Sender: TObject; ACanvas: TCanvas;
  var Width, Height: Integer);
begin
        Bitmap:=TBitmap.Create;
        Bitmap.LoadFromFile('1.bmp');
        Width:=Bitmap.Width;
        Height:=Bitmap.Height;
end;

Answer 1

还要加上：
PopupMenu.OwnerDraw:=True;

Answer 2

ch81(missile)　:谢谢
  你试一下QQ，它好象是整个菜单都是，不只是某个MENUITEM
它们原理一样吗？

Answer 3

kwhei(阿辉):那有什么区别呢？？你每个每个MenuItem加，不就行了吗？
QQ也不是这样吗?

Answer 4

mygod,要每个菜单项都画！？！

Answer 5

kwhei(阿辉):肯定啦，你看oicq不是这样实现嘛？？

Answer 6

只画主的其它的还是用PopupMenu，

Answer 7

我现在好象知道一点了，QQ弹出菜单只是使用TOOLBAR做出来的，这一点可以根据它的鼠标动作观察出来。我现在正在试，有结果我会把代码贴出来。界面上好象好看点了，但是代码增加量太大。不过，好象TENCENT不关心。
欢迎各位继续发表高见，

Answer 8

是不是开始菜单那种？菜单的左边多了一个广告条（我kao,又是广告）

Answer 9

收集的，也用过了，借花献佛：）
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
////////////////////////////////////////////////////////////////////////////////////////////

Answer 10

我的系统环境是win2000Professional+D5，没在9x下试过，里面好像用了win2000的API。
好长时间了，你看看吧

Answer 11

这个在三月份的一本杂志上讲过，我也有复印的资料，如果想要请E＿Mail:[email protected]

Answer 12

楼上的我想要啊 谢谢了  请EMAIL TO   [email protected]

Answer 13

Thanks to netsong:OICQ那种我已经试出来了不过它不是纯萃的ＷＩＮ９Ｘ上开始处的菜单实际上使用ＴＯＯＬＢＡＲ或ＰＡＮＥＬ都可以做出来，需要的朋友给我发个ＥＭＡＩＬ（因为代码中有其它资源不好贴在这里）。[email protected]

Answer 14

同意楼上的，如果想省点事可以用现成的控件，像coolmenu,venus之类都可以实现。

Answer 15

我也做出来了，效果与QQ的完全一样，而且用的只是TMune或TPopupMenu。

Answer 16

到C++Builder版找铁冰要把他定了一个，跟QQ的效果一样

Answer 17

我要，谢谢
[email protected]

Answer 18

Triumph(无为)　
能不能把你的代码公开一下或给我发外MAIL，学习学习？