Delphi控件源码

开发平台：
Delphi

bsSkinMenus.pas：源码内容
							{*******************************************************************}
{                                                                   }
{       Almediadev Visual Component Library                         }
{       BusinessSkinForm                                            }
{       Version 1.98                                                }
{                                                                   }
{       Copyright (c) 2000-2003 Almediadev                          }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{       Home:  http://www.almdev.com                                }
{       Support: support@almdev.com                                 }
{                                                                   }
{*******************************************************************}
unit bsSkinMenus;
{$P+,S-,W-,R-}
{$WARNINGS OFF}
{$HINTS OFF}
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Menus, ExtCtrls, ImgList, bsSkinData, bsUtils;
type
  TbsSkinPopupWindow = class;
  TbsSkinMenuItem = class(TObject)
  protected
    Parent: TbsSkinPopupWindow;
    MI: TbsDataSkinMenuItem;
    ActivePicture: TBitMap;
    FMorphKf: Double;
    procedure SetMorphKf(Value: Double);
    procedure Redraw;
  public
    MenuItem: TMenuItem;
    ObjectRect: TRect;
    Active: Boolean;
    Down: Boolean;
    FVisible: Boolean;
    constructor Create(AParent: TbsSkinPopupWindow; AMenuItem: TMenuItem;
                       AData: TbsDataSkinMenuItem);
    procedure Draw(Cnvs: TCanvas);
    procedure DefaultDraw(Cnvs: TCanvas);
    procedure MouseDown(X, Y: Integer);
    procedure MouseEnter(Kb: Boolean);
    procedure MouseLeave;
    function CanMorphing: Boolean; virtual;
    procedure DoMorphing;
    property MorphKf: Double read FMorphKf write SetMorphKf;
  end;
  TbsSkinMenu = class;
  TbsSkinPopupWindow = class(TCustomControl)
  private
    DSMI: TbsDataSkinMenuItem;
    VisibleCount: Integer;
    VisibleStartIndex: Integer;
    Scroll: Boolean;
    ScrollCode: Integer;
    NewLTPoint, NewRTPoint,
    NewLBPoint, NewRBPoint: TPoint;
    NewItemsRect: TRect;
    FRgn: HRGN;
    ShowX, ShowY: Integer;
    OMX, OMY: Integer;
    procedure WMMouseActivate(var Message: TMessage); message WM_MOUSEACTIVATE;
    procedure WMEraseBkGrnd(var Message: TMessage); message WM_ERASEBKGND;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CreateMenu(Item: TMenuItem; StartIndex: Integer);
    procedure CreateRealImage(B: TBitMap);
    procedure SetMenuWindowRegion;
    procedure DrawUpMarker(Cnvs: TCanvas);
    procedure DrawDownMarker(Cnvs: TCanvas);
    procedure StartScroll;
    procedure StopScroll;
  protected
    ImgL: TCustomImageList;
    GlyphWidth: Integer;
    WindowPicture, MaskPicture: TBitMap;
    OldActiveItem: Integer;
    MouseTimer, MorphTimer: TTimer;
    ParentMenu: TbsSkinMenu;
    SD: TbsSkinData;
    PW: TbsDataSkinPopupWindow;
    procedure TestMorph(Sender: TObject);
    procedure WMTimer(var Message: TWMTimer); message WM_Timer;
    function CanScroll(AScrollCode: Integer): Boolean;
    procedure ScrollUp(Cycle: Boolean);
    procedure ScrollDown(Cycle: Boolean);
    function GetEndStartVisibleIndex: Integer;
    procedure CalcItemRects;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure TestMouse(Sender: TObject);
    procedure TestActive(X, Y: Integer);
    function InWindow(P: TPoint): Boolean;
    procedure UpDatePW;
    function GetActive(X, Y: Integer): Boolean;
  public
    ItemList: TList;
    ActiveItem: Integer;
    constructor CreateEx(AOwner: TComponent; AParentMenu: TbsSkinMenu;
                       AData: TbsDataSkinPopupWindow);
    destructor Destroy; override;
     procedure Hide;
    procedure Show(R: TRect; AItem: TMenuItem; StartIndex: Integer;
                   PopupByItem: Boolean;  PopupUp: Boolean);
    procedure PaintMenu(DC: HDC);
    procedure PopupKeyDown(CharCode: Integer);
  end;
  TbsSkinMenu = class(TComponent)
  protected
    FFirst: Boolean;
    FDefaultMenuItemHeight: Integer;
    FDefaultMenuItemFont: TFont;
    PopupCtrl: TControl;
    FForm: TForm;
    WaitTimer: TTimer;
    WItem: TbsSkinMenuItem;
    WorkArea: TRect;
    FVisible: Boolean;
    SkinData: TbsSkinData;
    procedure SetDefaultMenuItemFont(Value: TFont);
    function GetWorkArea: TRect;
    function GetPWIndex(PW: TbsSkinPopupWindow): Integer;
    procedure CheckItem(PW: TbsSkinPopupWindow; MI: TbsSkinMenuItem; Down: Boolean; Kb: Boolean);
    procedure CloseMenu(EndIndex: Integer);
    procedure PopupSub(R: TRect; AItem: TMenuItem; StartIndex: Integer;
                       PopupByItem, PopupUp: Boolean);
    procedure WaitItem(Sender: TObject);
  public
    FPopupList: TList;
    AlphaBlend: Boolean;
    AlphaBlendValue: Byte;
    AlphaBlendAnimation: Boolean;
    property First: Boolean read FFirst;
    property Visible: Boolean read FVisible;
    constructor CreateEx(AOwner: TComponent; AForm: TForm);
    destructor Destroy; override;
    procedure Popup(APopupCtrl: TControl; ASkinData: TbsSkinData; StartIndex: Integer;
                    R: TRect; AItem: TMenuItem; PopupUp: Boolean);
    procedure Hide;
    property DefaultMenuItemFont: TFont
      read FDefaultMenuItemFont write SetDefaultMenuItemFont;
    property DefaultMenuItemHeight: Integer
      read FDefaultMenuItemHeight write FDefaultMenuItemHeight;
  end;
  TbsSkinPopupMenu = class(TPopupMenu)
  protected
    FSD: TbsSkinData;
    FComponentForm: TForm;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Popup(X, Y: Integer); override;
    procedure PopupFromRect(R: TRect; APopupUp: Boolean);
    procedure Popup2(ACtrl: TControl; X, Y: Integer);
    procedure PopupFromRect2(ACtrl: TControl; R: TRect; APopupUp: Boolean);
    property ComponentForm: TForm read FComponentForm write FComponentForm;
  published
    property SkinData: TbsSkinData read FSD write FSD;
  end;
  function CanMenuClose(Msg: Cardinal): Boolean;
const
    WM_CLOSESKINMENU = WM_USER + 204;
implementation
   Uses BusinessSkinForm, bsEffects;
const
  MouseTimerInterval = 50;
  MorphTimerInterval = 20;
  MorphInc = 0.1;
  WaitTimerInterval = 500;
  MarkerItemHeight = 10;
  ScrollTimerInterval = 100;
  MI_MINNAME = 'BSF_MINITEM';
  MI_MAXNAME = 'BSF_MAXITEM';
  MI_CLOSENAME = 'BSF_CLOSE';
  MI_RESTORENAME = 'BSF_RESTORE';
  MI_MINTOTRAYNAME = 'BSF_MINTOTRAY';
  MI_ROLLUPNAME = 'BSF_ROLLUP';
  TMI_RESTORENAME = 'TRAY_BSF_RESTORE';
  TMI_CLOSENAME = 'TRAY_BSF_CLOSE';
  MI_MINCAPTION = 'Mi&nimize';
  MI_MAXCAPTION = 'Ma&ximize';
  MI_CLOSECAPTION = '&Close';
  MI_RESTORECAPTION = '&Restore';
  MI_MINTOTRAYCAPTION = 'Minimize to &Tray';
  MI_ROLLUPCAPTION = 'Ro&llUp';
procedure DrawCheckImage(Cnvs: TCanvas; X, Y: Integer; Color: TColor);
var
  i: Integer;
begin
  with Cnvs do
  begin
    Pen.Color := Color;
    for i := 0 to 2 do
    begin
      MoveTo(X, Y + 5 - i);
      LineTo(X + 2, Y + 7 - i);
      LineTo(X + 7, Y + 2 - i);
    end;
  end;
end;
procedure DrawSubImage(Cnvs: TCanvas; X, Y: Integer; Color: TColor);
var
  i: Integer;
begin
  with Cnvs do
  begin
    Pen.Color := Color;
    for i := 0 to 3 do
    begin
      MoveTo(X + i, Y + i);
      LineTo(X + i, Y + 7 - i);
    end;
  end;
end;
procedure DrawRadioImage(Cnvs: TCanvas; X, Y: Integer; Color: TColor);
begin
  with Cnvs do
  begin
    Pen.Color := Color;
    Brush.Color := Color;
    Ellipse(X, Y, X + 6, Y + 6);
  end;
end;
function RectWidth(R: TRect): Integer;
begin
  Result := R.Right - R.Left;
end;
function RectHeight(R: TRect): Integer;
begin
  Result := R.Bottom - R.Top;
end;
function CanMenuClose;
begin
  Result := False;
  case Msg of
    WM_MOUSEACTIVATE, WM_ACTIVATE,
    WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN,
    WM_NCLBUTTONDOWN, WM_NCMBUTTONDOWN, WM_NCRBUTTONDOWN,
    WM_KILLFOCUS, WM_MOVE, WM_SIZE, WM_CANCELMODE, WM_PARENTNOTIFY:
      Result := True;
  end;
end;
//===============TbsSkinMenuItem===================//
constructor TbsSkinMenuItem.Create;
begin
  Parent := AParent;
  MenuItem := AMenuItem;
  FVisible := True;
  MI := AData;
  if MI <> nil
  then
    with AData do
    begin
      if (ActivePictureIndex <> - 1) and
         (ActivePictureIndex < Self.Parent.SD.FActivePictures.Count)
      then
        ActivePicture := Self.Parent.SD.FActivePictures.Items[ActivePictureIndex]
      else
        begin
          ActivePicture := nil;
          SkinRect := NullRect;
          ActiveSkinRect := NullRect;
        end;
    end;
  FMorphKf := 0;
end;
function TbsSkinMenuItem.CanMorphing;
var
  AD: Boolean;
begin
  AD := Active or Down;
  Result := FVisible and ((AD and (MorphKf < 1)) or
                         (not AD and (MorphKf > 0)));
  if not FVisible and (FMorphKf <> 0)
  then
    begin
      Active := False;
      Down := False;
      FMorphKf := 0;
    end;
end;
procedure TbsSkinMenuItem.DoMorphing;
begin
  if Active or Down
  then MorphKf := MorphKf + MorphInc
  else MorphKf := MorphKf - MorphInc;
  Draw(Parent.Canvas);
end;
procedure TbsSkinMenuItem.SetMorphKf(Value: Double);
begin
  FMorphKf := Value;
  if FMorphKf < 0 then FMorphKf := 0 else
  if FMorphKf > 1 then FMorphKf := 1;
end;
procedure TbsSkinMenuItem.ReDraw;
begin
  if (MI <> nil) and MI.Morphing
  then Parent.MorphTimer.Enabled := True
  else Draw(Parent.Canvas);
end;
procedure TbsSkinMenuItem.MouseDown(X, Y: Integer);
begin
  if not Down and MenuItem.Enabled
  then
    Parent.ParentMenu.CheckItem(Parent, Self, True, False);
end;
procedure TbsSkinMenuItem.MouseEnter;
var
  i: Integer;
begin
  Active := True;
  for i := 0 to Parent.ItemList.Count - 1 do
    if (TbsSkinMenuItem(Parent.ItemList.Items[i]) <> Self)
       and TbsSkinMenuItem(Parent.ItemList.Items[i]).Down
    then
      with TbsSkinMenuItem(Parent.ItemList.Items[i]) do
      begin
        Down := False;
        ReDraw;
      end;
  if not Down
  then
    begin
      ReDraw;
      Parent.ParentMenu.CheckItem(Parent, Self, False, Kb);
    end
  else
    with Parent.ParentMenu do
    begin
      i := GetPWIndex(Parent);
      if i + 2 < FPopupList.Count
      then
        TbsSkinPopupWindow(FPopupList.Items[i + 1]).UpDatePW;
    end;
    
end;
procedure TbsSkinMenuItem.MouseLeave;
begin
  Active := False;
  if not Down then ReDraw;
  with Parent.ParentMenu do
  begin
    if (WItem <> nil) and (WItem = Self)
    then
      begin
        WaitTimer.Enabled := False;
        WItem := nil;
      end;
  end;
end;
procedure TbsSkinMenuItem.DefaultDraw(Cnvs: TCanvas);
var
  MIShortCut: String;
  B: TBitMap;
  TextOffset: Integer;
  R, TR, SR: TRect;
  DrawGlyph: Boolean;
  GX, GY, IX, IY: Integer;
begin
  if MenuItem.ShortCut <> 0
  then
    MIShortCut := ShortCutToText(MenuItem.ShortCut)
  else
    MIShortCut := '';
  B := TBitMap.Create;
  B.Width := RectWidth(ObjectRect);
  B.Height := RectHeight(ObjectRect);
  if Parent.ImgL = nil
  then TextOffset := 19
  else TextOffset := Parent.GlyphWidth;
  
  with B.Canvas do
  begin
    R := Rect(0, 0, B.Width, B.Height);
    Font.Assign(Parent.ParentMenu.FDefaultMenuItemFont);
    if Active or Down
    then
      begin
        Frame3D(B.Canvas, R, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
        Brush.Color := BS_XP_BTNACTIVECOLOR;
        Font.Color := clWindowText;
        FillRect(R);
      end
    else
      begin
        R := Rect(0, 0, TextOffset, B.Height);
        Brush.Color := clBtnFace;
        FillRect(R);
        R := Rect(TextOffset, 0, B.Width, B.Height);
        Brush.Color := clWindow;
        if MenuItem.Enabled
        then
          Font.Color := clWindowText
        else
          Font.Color := clBtnShadow;
        FillRect(R);
      end;
  end;
  if MenuItem.Caption = '-'
  then
    begin
      R.Left := TextOffset;
      R.Top := B.Height div 2;
      R.Right := B.Width;
      R.Bottom := B.Height div 2 + 1;
      Frame3D(B.Canvas, R, clBtnShadow, clBtnShadow, 1);
      Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, B);
      B.Free;
      Exit;
    end;  
  TR := Rect(2, 2, B.Width - 2, B.Height - 2);
  // text
  R := Rect(TR.Left + TextOffset, 0, TR.Right - 19, 0);
  DrawText(B.Canvas.Handle, PChar(MenuItem.Caption), Length(MenuItem.Caption), R,
             DT_CALCRECT);
  OffsetRect(R, 0, TR.Top + RectHeight(TR) div 2 - R.Bottom div 2);
  Inc(R.Right, 2);
  DrawText(B.Canvas.Handle,
           PChar(MenuItem.Caption), Length(MenuItem.Caption), R, DT_CENTER or DT_VCENTER);
  // short cut
  if MIShortCut <> ''
  then
    begin
      SR := Rect(0, 0, 0, 0);
      DrawText(B.Canvas.Handle, PChar(MIShortCut), Length(MIShortCut), SR,
               DT_CALCRECT);
      SR := Rect(TR.Right - SR.Right - 19, R.Top, TR.Right - 19, R.Bottom);
      DrawText(B.Canvas.Handle,
        PChar(MIShortCut), Length(MIShortCut), SR, DT_CENTER or DT_VCENTER);
    end;
  //
  if MenuItem.Count <> 0
  then
    DrawSubImage(B.Canvas,
                 TR.Right - 7, TR.Top + RectHeight(TR) div 2 - 4,
                 B.Canvas.Font.Color);
  //
  DrawGlyph := (Parent.ImgL <> nil) and (MenuItem.ImageIndex > -1) and
       (MenuItem.ImageIndex < Parent.ImgL.Count);
  if DrawGlyph
  then
    begin
      GX := TR.Left;
      GY := TR.Top + RectHeight(TR) div 2 - Parent.ImgL.Height div 2;
      if MenuItem.Checked
      then
        with B.Canvas do
        begin
          Brush.Style := bsClear;
          Pen.Color := Font.Color;
          Rectangle(GX - 1, GY - 1,
                    GX + Parent.ImgL.Width + 1,
                    GY + Parent.ImgL.Height + 1);
        end;
    end
  else
    begin
      GX := 0; GY := 0;
      IY := TR.Top + RectHeight(TR) div 2 - 4;
      IX := TR.Left + 2;
      if (MenuItem.Name = MI_CLOSENAME) or (MenuItem.Name = TMI_CLOSENAME)
      then DrawCloseImage(B.Canvas, IX, IY, B.Canvas.Font.Color) else
      if MenuItem.Name = MI_MINNAME
      then DrawMinimizeImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
      else
      if MenuItem.Name = MI_MAXNAME
      then DrawMaximizeImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
      else
      if (MenuItem.Name = MI_RESTORENAME) or (MenuItem.Name = TMI_RESTORENAME)
      then DrawRestoreImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
      else
      if MenuItem.Name = MI_ROLLUPNAME
      then DrawRollUpImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
      else
      if MenuItem.Name = MI_MINTOTRAYNAME
      then DrawMTImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
      else
      if MenuItem.Checked
      then
      if MenuItem.RadioItem
      then
        DrawRadioImage(B.Canvas,
                       TR.Left + 3, TR.Top + RectHeight(TR) div 2 - 3,
                       B.Canvas.Font.Color)
      else
        DrawCheckImage(B.Canvas,
                       TR.Left + 3, TR.Top + RectHeight(TR) div 2 - 4,
                       B.Canvas.Font.Color);
    end;
  //
  if DrawGlyph
  then
    Parent.ImgL.Draw(B.Canvas, GX, GY, MenuItem.ImageIndex, MenuItem.Enabled);
  Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, B);
  B.Free;
end;
procedure TbsSkinMenuItem.Draw;
var
  GX, GY: Integer;
  DrawGlyph: Boolean;
//  EB1: TspEffectBmp;
  kf: Double;
procedure CreateItemImage(B: TBitMap; AActive: Boolean);
var
  R, TR, SR, Rct: TRect;
  TextOffset: Integer;
  MIShortCut: String;
  IX, IY: Integer;
begin
  if MenuItem.ShortCut <> 0
  then
    MIShortCut := ShortCutToText(MenuItem.ShortCut)
  else
    MIShortCut := '';
  if AActive
  then Rct := MI.ActiveSkinRect
  else Rct := MI.SkinRect;
  CreateHSkinImage(MI.ItemLO, MI.ItemRO,
   B, ActivePicture, Rct,
   RectWidth(ObjectRect), RectHeight(ObjectRect));
  if Parent.ImgL = nil
  then TextOffset := 16
  else TextOffset := Parent.GlyphWidth;
  TR := MI.TextRct;
  TR.Right := B.Width - (RectWidth(MI.SkinRect) - MI.TextRct.Right);
  with B.Canvas do
  begin
    Brush.Style := bsClear;
    if AActive
    then
      Font.Color := MI.ActiveFontColor
    else
      if MenuItem.Enabled
      then
        Font.Color := MI.FontColor
      else
        Font.Color := MI.UnEnabledFontColor;
    Font.Name := MI.FontName;
    Font.Style := MI.FontStyle;
    Font.Height := MI.FontHeight;
    Font.CharSet := Self.Parent.ParentMenu.FDefaultMenuItemFont.Charset; 
    //
    R := Rect(TR.Left + TextOffset, 0, TR.Right - 16, 0);
    DrawText(B.Canvas.Handle, PChar(MenuItem.Caption), Length(MenuItem.Caption), R,
             DT_CALCRECT);
    OffsetRect(R, 0, TR.Top + RectHeight(TR) div 2 - R.Bottom div 2);
    Inc(R.Right, 2);
    DrawText(B.Canvas.Handle,
             PChar(MenuItem.Caption), Length(MenuItem.Caption), R, DT_CENTER or DT_VCENTER);
    // shortcut
    if MIShortCut <> ''
    then
      begin
        SR := Rect(0, 0, 0, 0);
        DrawText(B.Canvas.Handle, PChar(MIShortCut), Length(MIShortCut), SR,
                 DT_CALCRECT);
        SR := Rect(TR.Right - SR.Right - 16, R.Top, TR.Right - 16, R.Bottom);
        DrawText(B.Canvas.Handle,
           PChar(MIShortCut), Length(MIShortCut), SR, DT_CENTER or DT_VCENTER);
      end;
    //
    if MenuItem.Count <> 0
    then
      DrawSubImage(B.Canvas,
                   TR.Right - 7, TR.Top + RectHeight(TR) div 2 - 4,
                   B.Canvas.Font.Color);
    //
    DrawGlyph := (Parent.ImgL <> nil) and (MenuItem.ImageIndex > -1) and
       (MenuItem.ImageIndex < Parent.ImgL.Count);
    if DrawGlyph
    then
      begin
        GX := TR.Left + 2;
        GY := TR.Top + RectHeight(TR) div 2 - Parent.ImgL.Height div 2;
        if MenuItem.Checked
        then
          begin
            Brush.Style := bsClear;
            Pen.Color := Font.Color;
            Rectangle(GX - 1, GY - 1,
                      GX + Parent.ImgL.Width + 1,
                      GY + Parent.ImgL.Height + 1);
          end;
      end
    else
      begin
        IY := TR.Top + RectHeight(TR) div 2 - 4;
        IX := TR.Left + 2;
        if (MenuItem.Name = MI_CLOSENAME) or (MenuItem.Name = TMI_CLOSENAME) 
        then DrawCloseImage(B.Canvas, IX, IY, B.Canvas.Font.Color) else
        if MenuItem.Name = MI_MINNAME
        then DrawMinimizeImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
        else
        if MenuItem.Name = MI_MAXNAME
        then DrawMaximizeImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
        else
        if (MenuItem.Name = MI_RESTORENAME) or (MenuItem.Name = TMI_RESTORENAME)
        then DrawRestoreImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
        else
        if MenuItem.Name = MI_ROLLUPNAME
        then DrawRollUpImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
        else
        if MenuItem.Name = MI_MINTOTRAYNAME
        then DrawMTImage(B.Canvas, IX, IY, B.Canvas.Font.Color)
        else
        if MenuItem.Checked
        then
          if MenuItem.RadioItem
          then
            DrawRadioImage(B.Canvas,
                           TR.Left + 2, TR.Top + RectHeight(TR) div 2 - 3,
                           B.Canvas.Font.Color)
          else
            DrawCheckImage(B.Canvas,
                           TR.Left + 2, TR.Top + RectHeight(TR) div 2 - 4,
                           B.Canvas.Font.Color);
      end;
  end;
  //
  if DrawGlyph
      then
        Parent.ImgL.Draw(B.Canvas, GX, GY,
          MenuItem.ImageIndex, MenuItem.Enabled);
end;
var
  B, AB: TBitMap;
  EffB, EffAB: TbsEffectBmp;
  AD: Boolean;
begin
  if not FVisible then Exit;
  if MI = nil
  then
    begin
      DefaultDraw(Cnvs);
      Exit;
    end;  
  B := TBitMap.Create;
  if MenuItem.Caption = '-'
  then
    begin
      CreateHSkinImage(MI.DividerLO, MI.DividerRO,
        B, ActivePicture, MI.DividerRect,
       RectWidth(ObjectRect), RectHeight(ObjectRect));
    end   
  else
    begin
      AD := Active or Down;
      if not MI.Morphing or
      ((AD and (MorphKf = 1)) or (not AD and (MorphKf  = 0)))
      then
        CreateItemImage(B, AD)
      else
        begin
          CreateItemImage(B, False);
          AB := TBitMap.Create;
          CreateItemImage(AB, True);
          EffB := TbsEffectBmp.CreateFromhWnd(B.Handle);
          EffAB := TbsEffectBmp.CreateFromhWnd(AB.Handle);
          case MI.MorphKind of
            mkDefault: EffB.Morph(EffAB, MorphKf);
            mkGradient: EffB.MorphGrad(EffAB, MorphKf);
            mkLeftGradient: EffB.MorphLeftGrad(EffAB, MorphKf);
            mkRightGradient: EffB.MorphRightGrad(EffAB, MorphKf);
            mkLeftSlide: EffB.MorphLeftSlide(EffAB, MorphKf);
            mkRightSlide: EffB.MorphRightSlide(EffAB, MorphKf);
            mkPush: EffB.MorphPush(EffAB, MorphKf);
          end;
          EffB.Draw(B.Canvas.Handle, 0, 0);
          AB.Free;
          EffB.Free;
          EffAB.Free;
        end;
    end;
  Cnvs.Draw(ObjectRect.Left, ObjectRect.Top, B);
  B.Free;
end;
//================TbsSkinPopupWindow======================//
constructor TbsSkinPopupWindow.CreateEx;
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable,
                  csAcceptsControls];
  ParentMenu := AParentMenu;
  Ctl3D := False;
  ParentCtl3D := False;
  Visible := False;
  ItemList := TList.Create;
  MouseTimer := TTimer.Create(Self);
  MouseTimer.Enabled := False;
  MouseTimer.OnTimer := TestMouse;
  MouseTimer.Interval := MouseTimerInterval;
  MorphTimer := TTimer.Create(Self);
  MorphTimer.Enabled := False;
  MorphTimer.OnTimer := TestMorph;
  MorphTimer.Interval := MorphTimerInterval;
  FRgn := 0;
  WindowPicture := nil;
  MaskPicture := nil;
  if (AData = nil) or (AData.WindowPictureIndex = -1)
  then
    begin
      PW := nil;
      SD := nil;
    end
  else
    begin
      PW := AData;
      SD := ParentMenu.SkinData;
      with PW do
      begin
        if (WindowPictureIndex <> - 1) and
           (WindowPictureIndex < SD.FActivePictures.Count)
        then
          WindowPicture := SD.FActivePictures.Items[WindowPictureIndex];
        if (MaskPictureIndex <> - 1) and
           (MaskPictureIndex < SD.FActivePictures.Count)
        then
          MaskPicture := SD.FActivePictures.Items[MaskPictureIndex];
      end;
    end;
  ActiveItem := -1;
  OldActiveItem := -1;
  OMX := -1;
  OMY := -1;
  DSMI := nil;
  ScrollCode := 0;
end;
destructor TbsSkinPopupWindow.Destroy;
var
  i: Integer;
begin
  for i := 0 to ItemList.Count - 1 do
    TbsSkinMenuItem(ItemList.Items[i]).Free;
  ItemList.Clear;
  ItemList.Free;
  MouseTimer.Free;
  MorphTimer.Free;
  inherited Destroy;
  if FRgn <> 0 then DeleteObject(FRgn);
end;
procedure TbsSkinPopupWindow.TestMorph;
var
  i: Integer;
  StopMorph: Boolean;
begin
  if PW = nil then Exit;
  StopMorph := True;
  for i := 0 to ItemList.Count  - 1 do
    with TbsSkinMenuItem(ItemList.Items[i]) do
    begin
      if MI.Morphing and CanMorphing
      then
        begin
          DoMorphing;
          StopMorph := False;
        end;
    end;
  if StopMorph then MorphTimer.Enabled := False;
end;
function TbsSkinPopupWindow.CanScroll;
begin
  Result := False;
  case AScrollCode of
    1: Result := VisibleStartIndex > 0;
    2: Result := VisibleStartIndex + VisibleCount - 1 < ItemList.Count - 1;
  end;
end;
procedure TbsSkinPopupWindow.WMTimer;
begin
  inherited;
  case ScrollCode of
    1: if CanScroll(1) then ScrollUp(False) else StopScroll;
    2: if CanScroll(2) then ScrollDown(False) else StopScroll;
  end;
end;
procedure TbsSkinPopupWindow.DrawUpMarker;
var
  R: TRect;
  C: TColor;
begin
  if PW <> nil
  then
    begin
      R := Rect(NewItemsRect.Left, NewItemsRect.Top,
                NewItemsRect.Right, NewItemsRect.Top + MarkerItemHeight);
      if ScrollCode = 1
      then C := PW.ScrollMarkerActiveColor
      else C := PW.ScrollMarkerColor;
    end
  else
    begin
      R := Rect(3, 3, Width - 3, 3 + MarkerItemHeight);
      if ScrollCode = 1
      then C := clBtnText
      else C := clBtnShadow;
    end;  
  DrawArrowImage(Cnvs, R, C, 3);
end;
procedure TbsSkinPopupWindow.DrawDownMarker;
var
  R: TRect;
  C: TColor;
begin
  if PW <> nil
  then
    begin
      R := Rect(NewItemsRect.Left, NewItemsRect.Bottom - MarkerItemHeight,
            NewItemsRect.Right, NewItemsRect.Bottom);
      if ScrollCode = 2
      then C := PW.ScrollMarkerActiveColor
      else C := PW.ScrollMarkerColor;
    end
  else
    begin
      R := Rect(3, Height - MarkerItemHeight, Width - 3, Height - 3);
      if ScrollCode = 2
      then C := clBtnText
      else C := clBtnShadow;
    end;
  DrawArrowImage(Cnvs, R, C, 4);
end;
procedure TbsSkinPopupWindow.StartScroll;
var
  i: Integer;
begin
  i := ParentMenu.GetPWIndex(Self);
  ParentMenu.CloseMenu(i + 1);
  KillTimer(Handle, 1);
  SetTimer(Handle, 1, ScrollTimerInterval, nil);
end;
procedure TbsSkinPopupWindow.StopScroll;
begin
  ScrollCode := 0;
  DrawUpMarker(Canvas);
  DrawDownMarker(Canvas);
  KillTimer(Handle, 1);
end;
procedure TbsSkinPopupWindow.ScrollUp;
begin
  if VisibleStartIndex > 0
  then
    begin
      VisibleStartIndex := VisibleStartIndex - 1;
      CalcItemRects;
      RePaint;
    end
  else
    if Cycle
    then
      begin
        VisibleStartIndex := GetEndStartVisibleIndex;
        CalcItemRects;
        RePaint;
      end;
end;
procedure TbsSkinPopupWindow.ScrollDown(Cycle: Boolean);
begin
  if VisibleStartIndex + VisibleCount - 1 < ItemList.Count - 1
  then
    begin
      VisibleStartIndex := VisibleStartIndex + 1;
      CalcItemRects;
      RePaint;
    end
  else
    if Cycle
    then
      begin
        VisibleStartIndex := 0;
        CalcItemRects;
        RePaint;
      end;
end;
procedure TbsSkinPopupWindow.PopupKeyDown(CharCode: Integer);
var
  PW: TbsSkinPopupWindow;
 procedure NextItem;
 var
   i, j: Integer;
 begin
   if Scroll and (ScrollCode = 0) and (ActiveItem = VisibleStartIndex + VisibleCount - 1)
   then ScrollDown(True);
   OldActiveItem := ActiveItem;
   if ActiveItem < 0 then j := 0 else j := ActiveItem + 1;
   if j = ItemList.Count then j := 0;
   for i := j to ItemList.Count - 1 do
     with TbsSkinMenuItem(ItemList.Items[i]) do
     begin
       if MenuItem.Enabled and (MenuItem.Caption <> '-')
       then
         begin
           ActiveItem := i;
           Break;
         end
       else
         begin
           if Scroll and (ScrollCode = 0) and (i = VisibleStartIndex + VisibleCount - 1)
           then ScrollDown(True);
         end;
     end;
   if OldActiveItem <> ActiveItem
   then
     begin
       if ActiveItem > -1 then
       with TbsSkinMenuItem(ItemList.Items[ActiveItem]) do
       begin
         MouseEnter(True);
       end;
       if OldActiveItem > -1 then
       with TbsSkinMenuItem(ItemList.Items[OldActiveItem]) do
        begin
          MouseLeave;
        end;
     end;
 end;
 procedure PriorItem;
 var
   i, j: Integer;
 begin
   if Scroll and (ScrollCode = 0) and (ActiveItem = VisibleStartIndex)
   then ScrollUp(True);
   OldActiveItem := ActiveItem;
   if ActiveItem < 0 then j := ItemList.Count - 1 else j := ActiveItem - 1;
   if (j = -1) then j := ItemList.Count - 1;
   for i := j downto 0 do
     with TbsSkinMenuItem(ItemList.Items[i]) do
     begin
       if MenuItem.Enabled and (MenuItem.Caption <> '-')
       then
         begin
           ActiveItem := i;
           Break;
         end
       else
         begin
           if Scroll and (ScrollCode = 0) and  (i = VisibleStartIndex)
           then ScrollUp(True);
         end;
     end;
   if OldActiveItem <> ActiveItem
   then
     begin
       if ActiveItem > -1 then
       with TbsSkinMenuItem(ItemList.Items[ActiveItem]) do
       begin
         MouseEnter(True);
       end;
       if OldActiveItem > -1 then
       with TbsSkinMenuItem(ItemList.Items[OldActiveItem]) do
        begin
          MouseLeave;
        end;
     end;
 end;
function FindHotKeyItem: Boolean;
var
  i: Integer;
begin
  Result := False;
  for i := 0 to ItemList.Count - 1 do
      with TbsSkinMenuItem(ItemList.Items[i]) do
      begin
        if Enabled and IsAccel(CharCode, MenuItem.Caption)
        then
          begin
            MouseEnter(False);
            OldActiveItem := ActiveItem;
            ActiveItem := i;
            if OldActiveItem <> -1
            then
              TbsSkinMenuItem(ItemList.Items[OldActiveItem]).MouseLeave;
            MouseDown(0, 0);
            Result := True;
            Break;
          end;
      end
end;
begin
  if not Visible then Exit;
  if not FindHotKeyItem
  then 
  case CharCode of
    VK_DOWN:
      NextItem;
    VK_UP:
      PriorItem;
    VK_RIGHT:
      begin
        if ActiveItem <> -1
        then
          with TbsSkinMenuItem(ItemList.Items[ActiveItem]) do
          begin
            if MenuItem.Count <> 0 then MouseDown(0, 0);
          end;
      end;
    VK_RETURN:
      begin
        if ActiveItem <> -1
        then
          with TbsSkinMenuItem(ItemList.Items[ActiveItem]) do
          begin
            MouseDown(0, 0);
          end;
      end;
    VK_LEFT:
      begin
        if ParentMenu.FPopupList.Count > 1
        then
          begin
            ParentMenu.CloseMenu(ParentMenu.FPopupList.Count - 1);
            PW := TbsSkinPopupWindow(ParentMenu.FPopupList.Items[ParentMenu.FPopupList.Count - 1]);
            if PW.ActiveItem <> -1
            then
              TbsSkinMenuItem(PW.ItemList.Items[PW.ActiveItem]).Down := False;
          end
      end;
    VK_ESCAPE:
      begin
        ParentMenu.CloseMenu(ParentMenu.FPopupList.Count - 1);
        if ParentMenu.FPopupList.Count > 0
        then
          begin
            PW := TbsSkinPopupWindow(ParentMenu.FPopupList.Items[ParentMenu.FPopupList.Count - 1]);
            if PW.ActiveItem <> -1
            then
              TbsSkinMenuItem(PW.ItemList.Items[PW.ActiveItem]).Down := False;
          end;   
      end;
  end;
end;
procedure TbsSkinPopupWindow.UpDatePW;
var
  i: Integer;
  j: Integer;
begin
  j := ParentMenu.GetPWIndex(Self);
  if j + 1 < ParentMenu.FPopupList.Count
  then ParentMenu.CloseMenu(j + 1);
  for i := 0 to ItemList.Count - 1 do
    if TbsSkinMenuItem(ItemList.Items[i]).Down
    then
      with TbsSkinMenuItem(ItemList.Items[i]) do
      begin
        Down := False;
        ReDraw;
      end;
end;
procedure TbsSkinPopupWindow.SetMenuWindowRegion;
var
  TempRgn: HRgn;
begin
  if PW = nil then Exit;
  TempRgn := FRgn;
  CreateSkinRegion
    (FRgn, PW.LTPoint, PW.RTPoint, PW.LBPoint, PW.RBPoint, PW.ItemsRect,
     NewLtPoint, NewRTPoint, NewLBPoint, NewRBPoint, NewItemsRect,
     MaskPicture, Width, Height);
  SetWindowRgn(Handle, FRgn, True);
  if TempRgn <> 0 then DeleteObject(TempRgn);
end;
procedure TbsSkinPopupWindow.CreateRealImage;
var
  R: TRect;
  TextOffset: Integer;
begin
  if PW <> nil
  then
    CreateSkinImage(PW.LTPoint, PW.RTPoint, PW.LBPoint, PW.RBPoint,
      PW.ItemsRect, NewLTPoint, NewRTPoint, NewLBPoint, NewRBPoint,
      NewItemsRect, B, WindowPicture,
      Rect(0, 0, WindowPicture.Width, WindowPicture.Height),
      Width, Height, Scroll)
  else
    begin
      B.Width := Width;
      B.Height := Height;
      with B.Canvas do
      begin
        if ImgL = nil
        then TextOffset := 21
        else TextOffset := GlyphWidth + 2;
        R := Rect(0, 0, TextOffset, Height);
        Brush.Color := clBtnFace;
        FillRect(R);
        R := Rect(TextOffset, 0, Width, Height);
        Brush.Color := clWindow;
        FillRect(R);
      end;
      R := Rect(0, 0, Width, Height);
      Frame3D(B.Canvas, R, clBtnShadow, clBtnShadow, 1);
      Frame3D(B.Canvas, R, clWindow, clWindow, 1);
    end;
end;
procedure TbsSkinPopupWindow.CreateMenu;
var
  sw, sh: Integer;
  i, j: Integer;
  Menu: TMenu;
  function CalcItemTextWidth(Item: TMenuItem): Integer;
  var
    R: TRect;
    MICaption: String;
  begin
   if Item.ShortCut <> 0
   then
     MICaption := Item.Caption + '  ' + ShortCutToText(Item.ShortCut)
   else
     MICaption := Item.Caption;
    R := Rect(0, 0, 0, 0);
    DrawText(Canvas.Handle, PChar(MICaption), Length(MICaption), R,
             DT_CALCRECT);
    Result := R.Right + 2;
  end;
  function GetMenuWindowHeight: Integer;
  var
    i, j, ih: integer;
  begin
    j := 0;
    for i := VisibleStartIndex to VisibleCount - 1 do
    with TbsSkinMenuItem(ItemList.Items[i]) do
     begin
      if PW <> nil
      then
        begin
          if MenuItem.Caption = '-'
          then ih := RectHeight(DSMI.DividerRect)
          else ih := RectHeight(DSMI.SkinRect);
        end
      else
        begin
          if MenuItem.Caption = '-'
          then ih := 4
          else ih := ParentMenu.DefaultMenuItemHeight;
        end;
      inc(j, ih);
    end;
    if PW <> nil
    then
      Result := j + PW.ItemsRect.Top + (WindowPicture.Height - PW.ItemsRect.Bottom)
    else
      Result := j + 4;
  end;
  function GetMenuWindowWidth: Integer;
  var
    i, iw: Integer;
  begin
    iw := 0;
    for i := 0 to ItemList.Count - 1 do
    begin
      j := CalcItemTextWidth(TbsSkinMenuItem(ItemList.Items[i]).MenuItem);
      if j > iw then iw := j;
    end;
    inc(iw, 19);
    if ImgL <> nil
    then
      GlyphWidth := ImgL.Width + 5
    else
      GlyphWidth := 19;
    Inc(iw, GlyphWidth);
    if PW <> nil
    then
      begin
        Inc(iw, DSMI.TextRct.Left);
        Inc(iw, RectWidth(DSMI.SkinRect) - DSMI.TextRct.Right);
        Result := iw + PW.ItemsRect.Left + (WindowPicture.Width - PW.ItemsRect.Right);
      end
    else
      Result := iw + 10;
  end;
procedure CalcSizes;
var
  W, H: Integer;
begin
  //
  VisibleStartIndex := 0;
  VisibleCount := ItemList.Count;
  W := GetMenuWindowWidth;
  H := GetMenuWindowHeight;
  Scroll := False;
  //
  if H > RectHeight(ParentMenu.WorkArea)
  then
    begin
      H := RectHeight(ParentMenu.WorkArea);
      Scroll := True;
    end;  
  //
  Width := W;
  Height := H;
end;
function GetMenuItemData: TbsDataSkinMenuItem;
var
  i: Integer;
begin
  Result := nil;
  if (SD <> nil) and not SD.Empty
  then 
    for i := 0 to SD.ObjectList.Count - 1 do
    if TbsDataSkinObject(SD.ObjectList.Items[i]) is TbsDataSkinMenuItem
    then
      begin
        Result := TbsDataSkinMenuItem(SD.ObjectList.Items[i]);
        Break;
      end;
end;
begin
  DSMI := GetMenuItemData;
  if (PW <> nil) and (DSMI <> nil)
  then
    begin
      with Canvas.Font do
      begin
        Height := DSMI.FontHeight;
        Style := DSMI.FontStyle;
        Name := DSMI.FontName;
        CharSet := ParentMenu.FDefaultMenuItemFont.Charset;
      end;
    end;
  Menu := Item.GetParentMenu;
  ImgL := Menu.Images;
  j := Item.Count;
  for i := StartIndex to  j - 1 do
   if TMenuItem(Item.Items[i]).Visible
   then
    ItemList.Add(TbsSkinMenuItem.Create(Self, TMenuItem(Item.Items[i]), DSMI));
  //
  CalcSizes;
  if PW <> nil
  then
    begin
      sw := WindowPicture.Width;
      sh := WindowPicture.Height;
      NewLTPoint := PW.LTPoint;
      NewRTPoint := Point(Width - (sw - PW.RTPoint.X), PW.RTPoint.Y);
      NewLBPoint := Point(PW.LBPoint.X, Height - (sh - PW.LBPoint.Y));
      NewRBPoint := Point(Width - (sw - PW.RBPoint.X),
                          Height - (sh - PW.RBPoint.Y));
      NewItemsRect := Rect(PW.ItemsRect.Left, PW.ItemsRect.Top,
                           Width - (sw - PW.ItemsRect.Right),
                           Height - (sh - PW.ItemsRect.Bottom));
    end
  else
    NewItemsRect := Rect(2, 2, Width - 2, Height - 2);
  CalcItemRects;
  if MaskPicture <> nil then SetMenuWindowRegion;
end;
function TbsSkinPopupWindow.GetEndStartVisibleIndex: Integer;
var
  i, j, k, ih, H: Integer;
begin
  j := NewItemsRect.Bottom - MarkerItemHeight;
  H := MarkerItemHeight;
  k := 0;
  for i := ItemList.Count - 1 downto 0 do
  begin
    with TbsSkinMenuItem(ItemList.Items[i]) do
     begin
       if DSMI <> nil
       then
         begin
           if MenuItem.Caption = '-'
           then ih := RectHeight(DSMI.DividerRect)
           else ih := RectHeight(DSMI.SkinRect);
         end
       else
         begin
           if MenuItem.Caption = '-'
           then ih := 4
           else ih := ParentMenu.DefaultMenuItemHeight;
         end;
       j := j - ih;
       if j >= H
       then
         inc(k)
       else
         Break;
     end;
  end;
  Result := ItemList.Count - k;
end;
procedure TbsSkinPopupWindow.CalcItemRects;
var
  i, j, ih, H: Integer;
begin
  j := NewItemsRect.Top;
  H := NewItemsRect.Bottom;
  if Scroll
  then
    begin
      H := H - MarkerItemHeight;
      j := j + MarkerItemHeight;
    end;
  VisibleCount := 0;
  for i := VisibleStartIndex to ItemList.Count - 1 do
    with TbsSkinMenuItem(ItemList.Items[i]) do
     begin
      if DSMI <> nil
      then
        begin
          if MenuItem.Caption = '-'
          then ih := RectHeight(DSMI.DividerRect)
          else ih := RectHeight(DSMI.SkinRect)
        end
      else
        begin
          if MenuItem.Caption = '-'
          then ih := 4
          else ih := ParentMenu.DefaultMenuItemHeight;
        end;
      ObjectRect.Left := NewItemsRect.Left;
      ObjectRect.Right := NewItemsRect.Right;
      ObjectRect.Top := j;
      ObjectRect.Bottom :=  j + ih;
      if ObjectRect.Bottom <= H
      then
        begin
          FVisible := True;
          Inc(VisibleCount)
        end
      else
        Break;
      inc(j, ih);
    end;
  if Scroll
  then
    begin
      if VisibleStartIndex > 0
      then
        for i := 0 to VisibleStartIndex - 1 do
          TbsSkinMenuItem(ItemList.Items[i]).FVisible := False;
      if VisibleCount + VisibleStartIndex <= ItemList.Count - 1
      then
        for i := VisibleCount + VisibleStartIndex to ItemList.Count - 1 do
          TbsSkinMenuItem(ItemList.Items[i]).FVisible := False;
    end;
end;
procedure TbsSkinPopupWindow.CMMouseEnter;
begin
  inherited;
end;
procedure TbsSkinPopupWindow.CMMouseLeave;
begin
  inherited;
end;
procedure TbsSkinPopupWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := WS_POPUP;
    ExStyle := WS_EX_TOOLWINDOW;
    WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
  end;
end;
procedure TbsSkinPopupWindow.WMMouseActivate(var Message: TMessage);
begin
  Message.Result := MA_NOACTIVATE;
end;
procedure TbsSkinPopupWindow.Hide;
begin
  SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
    SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
  MorphTimer.Enabled := False;
  MouseTimer.Enabled := False;
  Visible := False;
end;
procedure TbsSkinPopupWindow.Show;
procedure CalcMenuPos(var X, Y: Integer; R: TRect);
var
  WA: TRect;
  ChangeY: Boolean;
  function GetY: Integer;
  var
    Offset: Integer;
  begin
    if Scroll
    then
      Result := WA.Top
    else
      begin
        if PopupByItem
        then
          begin
            Offset := R.Top + Height - NewItemsRect.Top - WA.Bottom;
            if Offset > 0
            then
              begin
                if R.Top < WA.Top + RectHeight(WA) div 2
                then
                  Result := WA.Bottom - Height
                else
                  begin
                    Result := R.Bottom - Height + NewItemsRect.Top;
                    if Result  < WA.Top then Result := WA.Top;
                  end
              end
            else
              Result := R.Top - NewItemsRect.Top;
          end
        else
          begin
            if PopupUp
            then
              begin
                if R.Top - Height < WA.Top
                then
                  begin
                    if R.Top < WA.Top + RectHeight(WA) div 2
                    then
                      begin
                        Result := R.Bottom;
                        Offset := Result + Height - WA.Bottom;
                        if Offset > 0
                        then
                          begin
                            Result  := Result - Offset;
                            ChangeY := True;
                          end;
                       end
                     else
                       begin
                         Result := WA.Top;
                         ChangeY := True;
                       end;
                  end
                else
                  Result  := R.Top - Height;
              end
            else
              begin
                Offset := R.Bottom + Height - WA.Bottom;
                if Offset > 0
                then
                  begin
                    if R.Top < WA.Top + RectHeight(WA) div 2
                    then
                      begin
                        Result := R.Bottom - Offset;
                        ChangeY := True
                      end
                    else
                      begin
                        if R.Top - Height < WA.Top
                        then
                          begin
                            Result := WA.Top;
                            ChangeY := True;
                          end
                        else
                          Result := R.Top - Height;
                      end
                  end
                else
                  Result := R.Bottom;
              end;
          end;
      end;
  end;
  function GetX: Integer;
  begin
    if PopupByItem or Scroll or ChangeY
    then
      begin
        if R.Right + Width + 1 > WA.Right
        then Result := R.Left - Width - 1 else Result := R.Right + 1;
      end
    else
      begin
        if R.Left + Width > WA.Right
        then Result := WA.Right - Width else
        if R.Left < WA.Left then Result := WA.Left else Result := R.Left;
      end;
  end;
begin
  WA := ParentMenu.WorkArea;
  ChangeY := False;
  Y := GetY;
  X := GetX;
end;
const
  WS_EX_LAYERED = $80000;
  AnimationStep = 2;
var
  i: Integer;
  ABV: Integer;
begin
  if CheckW2KWXP and ParentMenu.AlphaBlend and ParentMenu.AlphaBlendAnimation and
     ParentMenu.First
  then
    Application.ProcessMessages;
    
  CreateMenu(AItem, StartIndex);
  CalcMenuPos(ShowX, ShowY, R);
  //
  if CheckW2KWXP and ParentMenu.AlphaBlend
  then
    begin
      SetWindowLong(Handle, GWL_EXSTYLE,
                    GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
      if ParentMenu.First and ParentMenu.AlphaBlendAnimation
      then SetAlphaBlendTransparent(Handle, 0)
      else SetAlphaBlendTransparent(Handle, ParentMenu.AlphaBlendValue);
    end;
  //
  SetWindowPos(Handle, HWND_TOPMOST, ShowX, ShowY, 0, 0,
               SWP_NOACTIVATE or SWP_SHOWWINDOW or SWP_NOSIZE);
  Visible := True;
  if CheckW2KWXP and ParentMenu.AlphaBlend and ParentMenu.AlphaBlendAnimation and
     ParentMenu.First
  then
    begin
      i := 0;
      ABV := ParentMenu.AlphaBlendValue;
      repeat
        Inc(i, AnimationStep);
        if i > ABV then i := ABV;
        SetAlphaBlendTransparent(Handle, i);
      until i >= ABV;
    end;
  //
  MouseTimer.Enabled := True;
  ActiveItem := -1;
  if ItemList.Count > 0
  then
    for i := 0 to ItemList.Count - 1 do
     with TbsSkinMenuItem(ItemList.Items[i]) do
     begin
       if MenuItem.Enabled
       then
         begin
           ActiveItem := i;
           MouseEnter(True);
           Break;
         end;
     end;
end;
procedure TbsSkinPopupWindow.PaintMenu;
var
  C: TCanvas;
  i: Integer;
  B: TBitMap;
begin
  C := TCanvas.Create;
  C.Handle := DC;
  B := TBitMap.Create;
  CreateRealImage(B);
  // Draw items
  for i := VisibleStartIndex to VisibleStartIndex + VisibleCount - 1 do
    TbsSkinMenuItem(ItemList.Items[i]).Draw(B.Canvas);
  // markers
  if Scroll
  then
    begin
      DrawUpMarker(B.Canvas);
      DrawDownMarker(B.Canvas);
    end;
  C.Draw(0, 0, B);
  B.Free;
  C.Free;
end;
procedure TbsSkinPopupWindow.WMEraseBkgrnd;
begin
  PaintMenu(Message.WParam);
end;
procedure TbsSkinPopupWindow.MouseUp;
begin
  TestActive(X, Y);
  if (ActiveItem <> -1) and (Button = mbleft) and GetActive(X, Y)
  then
    with TbsSkinMenuItem(ItemList.Items[ActiveItem]) do
     if MenuItem.Caption <> '-' then MouseDown(X, Y);
end;
procedure TbsSkinPopupWindow.TestMouse;
var
  P, P1: TPoint;
begin
  GetCursorPos(P1);
  P := ScreenToClient(P1);
  if (OMX <> P.X) or (OMY <> P.Y)
  then 
    if InWindow(P1)
    then
      TestActive(P.X, P.Y)
    else
      if Scroll
      then
        begin
          ScrollCode := 0;
          DrawUpMarker(Canvas);
          DrawDownMarker(Canvas);
        end;
  OMX := P.X;
  OMY := P.Y;
end;
function TbsSkinPopupWindow.GetActive;
var
  i: Integer;
begin
  i := -1;
  if ItemList.Count = 0
  then
    Result := False
  else
  repeat
    Inc(i);
    with TbsSkinMenuItem(ItemList.Items[i]) do
      Result := FVisible and PtInRect(ObjectRect, Point(X, Y));
  until Result or (i = ItemList.Count - 1);
end;
procedure TbsSkinPopupWindow.TestActive;
var
  i: Integer;
  B: Boolean;
  R1, R2: TRect;
begin
  if Scroll
  then
    begin
      R1 := Rect(NewItemsRect.Left, NewItemsRect.Top,
            NewItemsRect.Right, NewItemsRect.Top + MarkerItemHeight);
      R2 := Rect(NewItemsRect.Left, NewItemsRect.Bottom - MarkerItemHeight,
            NewItemsRect.Right, NewItemsRect.Bottom);
      if PtInRect(R1, Point(X, Y)) and (ScrollCode = 0) and CanScroll(1)
      then
        begin
          ScrollCode := 1;
          DrawUpMarker(Canvas);
          StartScroll;
        end
      else
      if PtInRect(R2, Point(X, Y)) and (ScrollCode = 0)  and CanScroll(2)
      then
        begin
          ScrollCode := 2;
          DrawDownMarker(Canvas);
          StartScroll;
        end
      else
        if (ScrollCode <> 0) and not PtInRect(R1, Point(X, Y)) and
                                 not PtInRect(R2, Point(X, Y))
        then
          StopScroll;
     end;
  if (ItemList.Count = 0) then Exit;
  OldActiveItem := ActiveItem;
  i := -1;
  repeat
    Inc(i);
    with TbsSkinMenuItem(ItemList.Items[i]) do
    begin
      B := FVisible and PtInRect(ObjectRect, Point(X, Y));
    end;
  until B or (i = ItemList.Count - 1);
  if B then ActiveItem := i;
  if OldActiveItem >= ItemList.Count then OldActiveItem := -1;
  if ActiveItem >= ItemList.Count then ActiveItem := -1;
  if (OldActiveItem <> ActiveItem)
  then
    begin
      if OldActiveItem <> - 1
      then
        with TbsSkinMenuItem(ItemList.Items[OldActiveItem]) do
        begin
          if MenuItem.Enabled and (MenuItem.Caption <> '-')
          then
            MouseLeave;
        end;
      if ActiveItem <> - 1
      then
        with TbsSkinMenuItem(ItemList.Items[ActiveItem]) do
        begin
          if MenuItem.Enabled and (MenuItem.Caption <> '-')
          then
            MouseEnter(False);
        end;
    end;
end;
function TbsSkinPopupWindow.InWindow;
var
  H: HWND;
begin
  H := WindowFromPoint(P);
  Result := H = Handle;
end;
//====================TbsSkinMenu===================//
constructor TbsSkinMenu.CreateEx;
begin
  inherited Create(AOwner);
  AlphaBlendAnimation := False;
  AlphaBlend := False;
  AlphaBlendValue := 150;
  FPopupList := TList.Create;
  WaitTimer := TTimer.Create(Self);
  WaitTimer.Enabled := False;
  WaitTimer.OnTimer := WaitItem;
  WaitTimer.Interval := WaitTimerInterval;
  WItem := nil;
  FVisible := False;
  FForm := AForm;
  PopupCtrl := nil;
  FDefaultMenuItemHeight := 20;
  FDefaultMenuItemFont := TFont.Create;
  with FDefaultMenuItemFont do
  begin
    Name := 'Arial';
    Style := [];
    Height := 14;
  end;
end;
destructor TbsSkinMenu.Destroy;
begin
  CloseMenu(0);
  FPopupList.Free;
  WaitTimer.Free;
  FDefaultMenuItemFont.Free;
  inherited Destroy;
end;
procedure TbsSkinMenu.SetDefaultMenuItemFont(Value: TFont);
begin
  FDefaultMenuItemFont.Assign(Value);
end;
function TbsSkinMenu.GetWorkArea;
var
  R: TRect;
begin
  SystemParametersInfo(SPI_GETWORKAREA, 0, @R, 0);
  Result := R;
end;
procedure TbsSkinMenu.WaitItem(Sender: TObject);
begin
  if WItem <> nil then CheckItem(WItem.Parent, WItem, True, False);
  WaitTimer.Enabled := False;
end;
function TbsSkinMenu.GetPWIndex;
var
  i: Integer;
begin
  for i := 0 to FPopupList.Count - 1 do
    if PW = TbsSkinPopupWindow(FPopupList.Items[i]) then Break;
  Result := i;
end;
procedure TbsSkinMenu.CheckItem;
var
  Menu: TMenu;
  MenuI: TMenuItem;
  i: Integer;
  R: TRect;
begin
  if (MI.MenuItem.Count = 0) and not Down
  then
    begin
      WaitTimer.Enabled := False;
      WItem := nil;
      i := GetPWIndex(PW);
      if i < FPopupList.Count - 1 then CloseMenu(i + 1);
    end
  else
  if (MI.MenuItem.Count = 0) and Down
  then
    begin
      WaitTimer.Enabled := False;
      WItem := nil;
      MenuI := MI.MenuItem;
      Hide;
      //
      Menu := MenuI.GetParentMenu;
      Menu.DispatchCommand(MenuI.Command);
    end
  else
  if (MI.MenuItem.Count <> 0) and not Down and not Kb
  then
    begin
      WaitTimer.Enabled := False;
      WItem := nil;
      i := GetPWIndex(PW);
      if i < FPopupList.Count - 1 then CloseMenu(i + 1);
      WItem := MI;
      WaitTimer.Enabled := True;
    end
  else
  if (MI.MenuItem.Count <> 0) and Down
  then
    begin
      //
      MenuI := MI.MenuItem;
      Menu := MenuI.GetParentMenu;
      Menu.DispatchCommand(MenuI.Command);
      //
      WaitTimer.Enabled := False;
      WItem := nil;
      MI.Down := True;
      R.Left := PW.Left + MI.ObjectRect.Left;
      R.Top := PW.Top + MI.ObjectRect.Top;
      R.Right := PW.Left + MI.ObjectRect.Right;
      R.Bottom := PW.Top + MI.ObjectRect.Bottom;
      PopupSub(R, MI.MenuItem, 0, True, False);
    end
end;
procedure TbsSkinMenu.Popup;
var
  BSF: TbsBusinessSkinForm;
begin
  FFirst := not FVisible;
  PopupCtrl := APopupCtrl;
  if FPopupList.Count <> 0 then CloseMenu(0);
  WorkArea := GetWorkArea;
  SkinData := ASkinData;
  if (AItem.Count = 0) then Exit;
  FVisible := True;
  PopupSub(R, AItem, StartIndex, False, PopupUp);
  FFirst := False;
end;
procedure TbsSkinMenu.PopupSub;
var
  P: TbsSkinPopupWindow;
begin
  if (SkinData = nil) or (SkinData.Empty)
  then
    P := TbsSkinPopupWindow.CreateEx(Self, Self, nil)
  else
    P := TbsSkinPopupWindow.CreateEx(Self, Self, SkinData.PopupWindow);
  FPopupList.Add(P);
  with P do Show(R, AItem, StartIndex, PopupByItem, PopupUp);
end;
procedure TbsSkinMenu.CloseMenu;
var
  i: Integer;
begin
  for i := FPopupList.Count - 1 downto EndIndex do
  begin
    TbsSkinPopupWindow(FPopupList.Items[i]).Free;
    FPopupList.Delete(i);
  end;
  if EndIndex = 0
  then
    begin
      FVisible := False;
      WaitTimer.Enabled := False;
      if PopupCtrl <> nil
      then
        begin
          if PopupCtrl is TWinControl
          then
            SendMessage(TWinControl(PopupCtrl).Handle, WM_CLOSESKINMENU, 0, 0)
          else
            PopupCtrl.Perform(WM_CLOSESKINMENU, 0, 0);
          PopupCtrl := nil;
        end;
    end;
end;
procedure TbsSkinMenu.Hide;
begin
  CloseMenu(0);
  WaitTimer.Enabled := False;
  WItem := nil;
  if FForm <> nil then
  SendMessage(FForm.Handle, WM_CLOSESKINMENU, 0, 0);
  if PopupCtrl <> nil
  then
    begin
      if PopupCtrl is TWinControl
      then
        SendMessage(TWinControl(PopupCtrl).Handle, WM_CLOSESKINMENU, 0, 0)
      else
        PopupCtrl.Perform(WM_CLOSESKINMENU, 0, 0);
      PopupCtrl := nil;
    end;  
end;
//============= TbsSkinPopupMenu =============//
function FindBSFComponent(AForm: TForm): TbsBusinessSkinForm;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to AForm.ComponentCount - 1 do
   if AForm.Components[i] is TbsBusinessSkinForm
   then
     begin
       Result := TbsBusinessSkinForm(AForm.Components[i]);
       Break;
     end;
end;
constructor TbsSkinPopupMenu.Create;
begin
  inherited Create(AOwner);
  FComponentForm := nil;
  FSD := nil;
end;
procedure TbsSkinPopupMenu.Notification;
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FSD) then FSD := nil;
end;
procedure TbsSkinPopupMenu.PopupFromRect;
var
  BSF: TbsBusinessSkinForm;
begin
  if Assigned(OnPopup) then OnPopup(Self);
  if FComponentForm = nil
  then
    begin
      // BSF := FindBSFComponent(TForm(Owner))
      if Owner.InheritsFrom(TForm) then
        BSF := FindBSFComponent(TForm(Owner)) else
         if Owner.Owner.InheritsFrom(TForm) then
         BSF := FindBSFComponent(TForm(Owner.Owner)) else
         BSF := nil;
    end
  else
    BSF := FindBSFComponent(FComponentForm);
  if (BSF <> nil) and (FSD = nil)
  then
    if BSF.MenusSkinData = nil
    then
      FSD := BSF.SkinData
    else
      FSD := BSF.MenusSkinData;
  if BSF <> nil
  then
    begin
      BSF.SkinMenuOpen;
      BSF.SkinMenu.Popup(nil, FSD, 0, R, Items, APopupUp);
    end;
end;
procedure TbsSkinPopupMenu.Popup;
var
  BSF: TbsBusinessSkinForm;
var
  R: TRect;
begin
  if Assigned(OnPopup) then OnPopup(Self);
  if FComponentForm = nil
  then
    begin
      // BSF := FindBSFComponent(TForm(Owner))
      if Owner.InheritsFrom(TForm) then
        BSF := FindBSFComponent(TForm(Owner)) else
         if Owner.Owner.InheritsFrom(TForm) then
         BSF := FindBSFComponent(TForm(Owner.Owner)) else
         BSF := nil;
    end
  else
    BSF := FindBSFComponent(FComponentForm);
  if (BSF <> nil) and (FSD = nil)
  then
    if BSF.MenusSkinData = nil
    then
      FSD := BSF.SkinData
    else
      FSD := BSF.MenusSkinData;
  if BSF <> nil
  then
    begin
      BSF.SkinMenuOpen;
      R := Rect(X, Y, X, Y);
      BSF.SkinMenu.Popup(nil, FSD, 0, R, Items, False);
    end;
end;
procedure TbsSkinPopupMenu.PopupFromRect2;
var
  BSF: TbsBusinessSkinForm;
begin
  if Assigned(OnPopup) then OnPopup(Self);
  if FComponentForm = nil
  then
    begin
      // BSF := FindBSFComponent(TForm(Owner))
      if Owner.InheritsFrom(TForm) then
        BSF := FindBSFComponent(TForm(Owner)) else
         if Owner.Owner.InheritsFrom(TForm) then
         BSF := FindBSFComponent(TForm(Owner.Owner)) else
         BSF := nil;
    end
  else
    BSF := FindBSFComponent(FComponentForm);
  if (BSF <> nil) and (FSD = nil)
  then
    if BSF.MenusSkinData = nil
    then
      FSD := BSF.SkinData
    else
      FSD := BSF.MenusSkinData;
  if BSF <> nil
  then
    begin
      BSF.SkinMenuOpen;
      BSF.SkinMenu.Popup(ACtrl, FSD, 0, R, Items, APopupUp);
    end;
end;
procedure TbsSkinPopupMenu.Popup2;
var
  R: TRect;
  BSF: TbsBusinessSkinForm;
begin
  if Assigned(OnPopup) then OnPopup(Self);
  if FComponentForm = nil
  then
    begin
      // BSF := FindBSFComponent(TForm(Owner))
      if Owner.InheritsFrom(TForm) then
        BSF := FindBSFComponent(TForm(Owner)) else
         if Owner.Owner.InheritsFrom(TForm) then
         BSF := FindBSFComponent(TForm(Owner.Owner)) else
         BSF := nil;
    end
  else
    BSF := FindBSFComponent(FComponentForm);
  if (BSF <> nil) and (FSD = nil)
  then
    if BSF.MenusSkinData = nil
    then
      FSD := BSF.SkinData
    else
      FSD := BSF.MenusSkinData;
  if (BSF <> nil) and (FSD <> nil)
  then
    begin
      BSF.SkinMenuOpen;
      R := Rect(X, Y, X, Y);
      BSF.SkinMenu.Popup(ACtrl, FSD, 0, R, Items, False);
    end;
end;
end.

						