bsskinmenus.pas

一套非常好用的delphi控件,方便程序员工作

{*******************************************************************}
{                                                                   }
{       Almediadev Visual Component Library                         }
{       BusinessSkinForm                                            }
{       Version 4.27                                                }
{                                                                   }
{       Copyright (c) 2000-2006 Almediadev                          }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{       Home:  http://www.almdev.com                                }
{       Support: [e-mail]                                 }
{                                                                   }
{*******************************************************************}

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;
    WaitCommand: Boolean;
    //
    CurrentFrame: Integer;
    //
    constructor Create(AParent: TbsSkinPopupWindow; AMenuItem: TMenuItem;
                       AData: TbsDataSkinMenuItem);
    function EnableMorphing: Boolean;
    function EnableAnimation: Boolean;
    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;
    Scroll2: 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 CreateMenu2(Item, Item2: 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 Show2(R: TRect; AItem, AItem2: TMenuItem; StartIndex: Integer;
                   PopupByItem: Boolean;  PopupUp: Boolean);
    procedure PaintMenu(DC: HDC);
    procedure PopupKeyDown(CharCode: Integer);
  end;

  TbsSkinMenu = class(TComponent)
  protected
    FUseSkinFont: Boolean;
    FFirst: Boolean;
    FDefaultMenuItemHeight: Integer;
    FDefaultMenuItemFont: TFont;
    PopupCtrl, DCtrl: TControl;
    FForm: TForm;
    WaitTimer: TTimer;
    WItem: TbsSkinMenuItem;
    WorkArea: TRect;
    FVisible: Boolean;
    SkinData: TbsSkinData;
    FOnMenuClose: TNotifyEvent;

    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 PopupSub2(R: TRect; AItem, AItem2: TMenuItem; StartIndex: Integer;
                       PopupByItem, PopupUp: Boolean);
    procedure WaitItem(Sender: TObject);

  public
    FPopupList: TList;
    AlphaBlend: Boolean;
    AlphaBlendValue: Byte;
    AlphaBlendAnimation: Boolean;
    MaxMenuItemsInWindow: Integer;
    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 Popup2(APopupCtrl: TControl; ASkinData: TbsSkinData; StartIndex: Integer;
                    R: TRect; AItem, AItem2: TMenuItem; PopupUp: Boolean);
    procedure Hide;
    property DefaultMenuItemFont: TFont
      read FDefaultMenuItemFont write SetDefaultMenuItemFont;
    property DefaultMenuItemHeight: Integer
      read FDefaultMenuItemHeight write FDefaultMenuItemHeight;
    property UseSkinFont: Boolean
     read FUseSkinFont write FUseSkinFont;
    property OnMenuClose: TNotifyEvent read FOnMenuClose write FOnMenuClose;  
  end;

  TbsSkinPopupMenu = class(TPopupMenu)
  private
    FPopupPoint: TPoint;
  protected
    FSD: TbsSkinData;
    FComponentForm: TForm;
    FOnMenuClose: TNotifyEvent;
    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;
    property PopupPoint: TPoint read FPopupPoint;
  published
    property SkinData: TbsSkinData read FSD write FSD;
    property OnMenuClose: TNotifyEvent read
      FOnMenuClose write FOnMenuClose;
  end;


  function CanMenuClose(Msg: Cardinal): Boolean;

const
   WM_CLOSESKINMENU = WM_USER + 204;
   WM_AFTERDISPATCH = WM_USER + 205;

implementation

   Uses BusinessSkinForm, bsEffects, bsConst;

const
  MouseTimerInterval = 50;
  MorphTimerInterval = 20;
  MorphInc = 0.2;
  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';

  CS_DROPSHADOW_ = $20000;

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
  WaitCommand := False;
  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;
  CurrentFrame := 0;
end;

function TbsSkinMenuItem.EnableMorphing: Boolean;
begin
  Result := (MI <> nil) and MI.Morphing and (Parent.SD <> nil) and
             not (Parent.SD.Empty) and
             Parent.SD.EnableSkinEffects;
end;

function TbsSkinMenuItem.EnableAnimation: Boolean;
begin
  Result := (MI <> nil) and not IsNullRect(MI.AnimateSkinRect) and (Parent.SD <> nil) and
             not (Parent.SD.Empty) and
             Parent.SD.EnableSkinEffects;
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 EnableAnimation
  then
    begin
      if  Parent.MorphTimer.Interval <> MI.AnimateInterval
      then
        Parent.MorphTimer.Interval := MI.AnimateInterval;
       if EnableAnimation and not MI.InActiveAnimation and not Active
       then
        begin
          CurrentFrame := 0;
          Draw(Parent.Canvas);
       end
      else
        Parent.MorphTimer.Enabled := True
    end
  else
  if (MI <> nil) and EnableMorphing
  then
    begin
      if Parent.MorphTimer.Interval <> MorphTimerInterval
      then
        Parent.MorphTimer.Interval := MorphTimerInterval;
      Parent.MorphTimer.Enabled := True
    end
  else
    Draw(Parent.Canvas);
end;

procedure TbsSkinMenuItem.MouseDown(X, Y: Integer);
begin
  WaitCommand := False;
  if not Down and MenuItem.Enabled
  then
    Parent.ParentMenu.CheckItem(Parent, Self, True, False);
end;

procedure TbsSkinMenuItem.MouseEnter;
var
  i: Integer;
begin
  Active := True;
  if EnableAnimation then CurrentFrame := 0;          
  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 WaitCommand and not Kb
  then
    begin
      ReDraw;
    end
  else  
  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;

  if Parent.Hint <> MenuItem.Hint then Parent.Hint := MenuItem.Hint;
end;

procedure TbsSkinMenuItem.MouseLeave;
begin
  Active := False;
  if EnableAnimation then CurrentFrame := MI.FrameCount + 1;
  WaitCommand := 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: WideString;
  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;