xpmenu.pas

supcode_6013是图书馆管理系统

{    
XPMenu for Delphi
Author: Khaled Shagrouni
URL: http://www.shagrouni.com/english/software/xpmenu.html
e-mail: [e-mail]
Version 2.21, May 18, 2002


XPMenu is a Delphi component to mimic Office XP menu and toolbar style.
Copyright (C) 2001, 2002 Khaled Shagrouni.

This component is FREEWARE with source code. I still hold the copyright, but
you can use it for whatever you like: freeware, shareware or commercial software.
If you have any ideas for improvement or bug reports, don't hesitate to e-mail
me <[e-mail]> (Please state the XPMenu version and OS information).


Update http://www.tommstudio.com

}

{$IFDEF VER130}
{$DEFINE VER5U}
{$ENDIF}

{$IFDEF VER140}
{$DEFINE VER5U}
{$DEFINE VER6U}
{$ENDIF}


unit XPMenu;

interface

uses
  Windows, SysUtils, Classes, Graphics, Controls, ComCtrls,  Forms,
  Menus, Messages, Commctrl, ExtCtrls, StdCtrls, Buttons,dialogs;

type

  TXPContainer = (xccForm, xccFrame, xccToolbar, xccCoolbar, xccControlbar, xccPanel,
                  xccScrollBox, xccGroupBox, xccTabSheet, xccPageScroller);
  TXPContainers = set of TXPContainer;

  TXPControl = (xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcCombo,
                xcEdit, xcMaskEdit, xcMemo, xcRichEdit, xcCheckBox, xcRadioButton,
                xcButton, xcBitBtn, xcSpeedButton, xcPanel, xcGroupBox);

  TXPControls = set of TXPControl;

  TXPMenu = class;
  TControlSubClass = class(TComponent)   //:   "Fabian Jakubowski" <[e-mail]>
  private
    Control: TControl;
    FBuilding: boolean;
    FMouseInControl: boolean;
    FLButtonBressed: boolean;
    FBressed: boolean;
    FIsKeyDown: boolean;
    FIsFocused: boolean;
    orgWindowProc: TWndMethod;
    XPMenu: TXPMenu;
    FCtl3D: boolean;
    FBorderStyle: TBorderStyle;
    FMsg: Cardinal;
    procedure ControlSubClass(var Message: TMessage);
    procedure PaintControlXP;
    procedure PaintCombo;
    procedure PaintEdit;
    procedure PaintRichEdit;
    procedure PaintCheckBox;
    procedure PaintRadio;
    procedure PaintButton;
    procedure PaintBitButn;
    procedure PaintUpDownButton;
    procedure PaintSpeedButton;
    procedure PaintPanel;
    procedure PaintGroupBox;

  end;

  TXPMenu = class(TComponent)
  private
    FActive: boolean;
    {Changes MMK FForm to TScrollingWinControl}
    FForm: TScrollingWinControl;
    FFont: TFont;
    FColor: TColor;
    FIconBackColor: TColor;
    FMenuBarColor: TColor;
    FCheckedColor: TColor;
    FSeparatorColor: TColor;
    FSelectBorderColor: TColor;
    FSelectColor: TColor;
    FDisabledColor: TColor;
    FSelectFontColor: TColor;
    FIconWidth: integer;
    FDrawSelect: boolean;
    FUseSystemColors: boolean;

    FFColor, FFIconBackColor, FFSelectColor, FFSelectBorderColor,
    FFSelectFontColor, FCheckedAreaColor, FCheckedAreaSelectColor,
    FFCheckedColor, FFMenuBarColor, FFDisabledColor, FFSeparatorColor,
    FMenuBorderColor, FMenuShadowColor: TColor;

{*******************Tommstudio.com update********************}

    FControlUseTrueXPStyle:boolean;               //是否使用真正的Xp样式的颜色
    FBtnRoundArc:integer;                  //圆弧的大小
    FBtnOutLineBorderColor,                //按钮外框的颜色
    FBtnInnerBorderMoveColor,              //鼠标移动到这里时内边框显示的颜色
    FBtnInnerBorderFocusColor,             //按钮得到焦点时内边框的颜色
    FBtnSurfaceNormalColor,                //按钮表明的颜色
    FBtnSurfaceDownColor,                  //鼠标移动到这里时按钮表明的颜色
    FBtnSurfaceBottomLineColor,            //鼠标没有按下时下边线条的颜色
    FRdoChkControlChkColor,                   //Radioc控件checked时的颜色
    FComboBoxChkColor,                    //combobox控件check的颜色
    FComboboxSurfaceMoveColor,           //Combobox控件鼠标移动到这里时的底色
    FComboboxSurfaceDownColor,            //Combobox控件鼠标按下的底色
    FControlDisabledBorderColor,          //所有控件在无效时的边框色
    FBtnSurfaceDownBottomLineColor:TColor; //鼠标按下时下边线条的颜色

{*******************Tommstudio.com update********************}

    Is16Bit: boolean;
    FOverrideOwnerDraw: boolean;
    FGradient: boolean;
    FFlatMenu: boolean;
    FAutoDetect: boolean;
    FXPContainers: TXPContainers;
    FXPControls: TXPControls;
    FGrayLevel: byte;
    FDimLevel: byte;
  //  FDoubleBuffered :Boolean;

{*******************Tommstudio.com update********************}
    procedure SetControlUseTrueXPStyle(const value:Boolean);
{*******************Tommstudio.com update********************}
    
    procedure SetActive(const Value: boolean);
    procedure SetAutoDetect(const Value: boolean);
    procedure SetForm(const Value: TScrollingWinControl);
    procedure SetFont(const Value: TFont);
    procedure SetColor(const Value: TColor);
    procedure SetIconBackColor(const Value: TColor);
    procedure SetMenuBarColor(const Value: TColor);
    procedure SetCheckedColor(const Value: TColor);
    procedure SetDisabledColor(const Value: TColor);
    procedure SetSelectColor(const Value: TColor);
    procedure SetSelectBorderColor(const Value: TColor);
    procedure SetSeparatorColor(const Value: TColor);
    procedure SetSelectFontColor(const Value: TColor);
    procedure SetIconWidth(const Value: integer);
    procedure SetDrawSelect(const Value: boolean);
    procedure SetUseSystemColors(const Value: boolean);
    procedure SetOverrideOwnerDraw(const Value: boolean);
    procedure SetGradient(const Value: boolean);
    procedure SetFlatMenu(const Value: boolean);
    procedure SetXPContainers(const Value: TXPContainers);
    procedure SetXPControls(const Value: TXPControls);

  protected
    procedure InitItems(wForm: TWinControl; Enable, Update: boolean);
    procedure DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
      Selected: Boolean);
    procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
      Selected: Boolean);
    {$IFDEF VER5U}
    procedure ToolBarDrawButton(Sender: TToolBar;
      Button: TToolButton; State: TCustomDrawState; var DefaultDraw: Boolean);
    {$ENDIF}
    procedure ControlBarPaint(Sender: TObject; Control: TControl;
      Canvas: TCanvas; var ARect: TRect; var Options: TBandPaintOptions);

    procedure ActivateMenuItem(MenuItem: TMenuItem);
    procedure SetGlobalColor(ACanvas: TCanvas);
    procedure DrawTopMenuItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
      BckColor:Tcolor; IsRightToLeft: boolean);
    procedure DrawCheckedItem(FMenuItem: TMenuItem; Selected, Enabled,
     HasImgLstBitmap: boolean; ACanvas: TCanvas; CheckedRect: TRect);
    procedure DrawTheText(Sender: TObject; txt, ShortCuttext: string;
       ACanvas: TCanvas; TextRect: TRect;
       Selected, Enabled, Default, TopMenu, IsRightToLeft: boolean;
       var TxtFont: TFont; TextFormat: integer);
    procedure DrawIcon(Sender: TObject; ACanvas: TCanvas; B: TBitmap;
     IconRect: Trect; Hot, Selected, Enabled, Checked, FTopMenu,
     IsRightToLeft: boolean);
//    procedure DrawArrow(ACanvas: TCanvas; X, Y: integer);
    procedure MeasureItem(Sender: TObject; ACanvas: TCanvas;
      var Width, Height: Integer);

    function GetImageExtent(MenuItem: TMenuItem): TPoint;
    function TopMenuFontColor(ACanvas: TCanvas; Color: TColor): TColor;
    procedure DrawGradient(ACanvas: TCanvas; ARect: TRect;
     IsRightToLeft: boolean);

    procedure DrawWindowBorder(hWnd: HWND; IsRightToLeft: boolean);

    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Form: TScrollingWinControl read FForm write SetForm;
  published
    property DimLevel: Byte read FDimLevel write FDimLevel;
    property GrayLevel: Byte read FGrayLevel write FGrayLevel;
    property Font: TFont read FFont write SetFont;
    property Color: TColor read FColor write SetColor;
    property IconBackColor: TColor read FIconBackColor write SetIconBackColor;
    property MenuBarColor: TColor read FMenuBarColor write SetMenuBarColor;
    property SelectColor: TColor read FSelectColor write SetSelectColor;
    property SelectBorderColor: TColor read FSelectBorderColor
     write SetSelectBorderColor;
    property SelectFontColor: TColor read FSelectFontColor
     write SetSelectFontColor;
    property DisabledColor: TColor read FDisabledColor write SetDisabledColor;
    property SeparatorColor: TColor read FSeparatorColor
     write SetSeparatorColor;
    property CheckedColor: TColor read FCheckedColor write SetCheckedColor;
    property IconWidth: integer read FIconWidth write SetIconWidth;
    property DrawSelect: boolean read FDrawSelect write SetDrawSelect;
    property UseSystemColors: boolean read FUseSystemColors
     write SetUseSystemColors;
    property OverrideOwnerDraw: boolean read FOverrideOwnerDraw
     write SetOverrideOwnerDraw;

    property Gradient: boolean read FGradient write SetGradient;
    property FlatMenu: boolean read FFlatMenu write SetFlatMenu;
    property AutoDetect: boolean read FAutoDetect write SetAutoDetect;
    property XPContainers: TXPContainers read FXPContainers write SetXPContainers
      default [xccForm, xccFrame, xccToolbar, xccCoolbar, xccControlbar, xccPanel,
                  xccScrollBox, xccGroupBox, xccTabSheet, xccPageScroller];
    property XPControls :TXPControls read FXPControls write SetXPControls
      default [xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcCombo,
               xcEdit, xcMaskEdit, xcMemo, xcRichEdit, xcCheckBox, xcRadioButton,
               xcButton, xcBitBtn, xcSpeedButton, xcPanel, xcGroupBox];

    property Active: boolean read FActive write SetActive;

{*******************Tommstudio.com update********************}
    property ControlUseTrueXPStyle:boolean read FControlUseTrueXPStyle write SetControlUseTrueXPStyle;  //是否使用真正的Xp样式的颜色
    property BtnRoundArc:integer read FBtnRoundArc write FBtnRoundArc;           //圆弧的大小
    property BtnOutLineBorderColor:TColor read FBtnOutLineBorderColor write FBtnOutLineBorderColor;
    property BtnInnerBorderMoveColor:TColor read FBtnInnerBorderMoveColor write FBtnInnerBorderMoveColor; //鼠标移动到这里时内边框显示的颜色
    property BtnInnerBorderFocusColor:TColor read FBtnInnerBorderFocusColor write FBtnInnerBorderFocusColor;  //按钮得到焦点时内边框的颜色
    property BtnSurfaceNormalColor:TColor read FBtnSurfaceNormalColor write FBtnSurfaceNormalColor;  //按钮表明的颜色
    property BtnSurfaceDownColor:TColor read FBtnSurfaceDownColor write FBtnSurfaceDownColor;  //鼠标移动到这里时按钮表明的颜色
    property BtnSurfaceBottomLineColor:TColor read FBtnSurfaceBottomLineColor write FBtnSurfaceBottomLineColor; //鼠标没有按下时下边线条的颜色
    property BtnSurfaceDownBottomLineColor:TColor read FBtnSurfaceDownBottomLineColor write FBtnSurfaceDownBottomLineColor; //鼠标按下时下边线条的颜色
    property RdoChkControlChkColor:TColor read FRdoChkControlChkColor write FRdoChkControlChkColor;
    property ComboBoxChkColor:TColor read FComboBoxChkColor write FComboBoxChkColor;
    property ComboboxSurfaceMoveColor:TColor read FComboboxSurfaceMoveColor write FComboboxSurfaceMoveColor;
    property ControlDisabledBorderColor:TColor read FControlDisabledBorderColor write FControlDisabledBorderColor;
{*******************Tommstudio.com update********************}
  end;



function GetShadeColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
function NewColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
procedure DimBitmap(ABitmap: TBitmap; Value: integer);
procedure DrawArrow(ACanvas: TCanvas; X, Y: integer);
function GrayColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
procedure GrayBitmap(ABitmap: TBitmap; Value: integer);
procedure DrawBitmapShadow(B: TBitmap; ACanvas: TCanvas; X, Y: integer; ShadowColor: TColor);
procedure DrawCheckMark(ACanvas: TCanvas; X, Y: integer);
procedure GetSystemMenuFont(Font: TFont);

{*******************Tommstudio.com update********************}
procedure DrawBtnSurface(ACanvas:TCanvas;Rect:TRect;Color:TColor);
procedure DrawBtnOuterLine(ACanvas:TCanvas;Rect:TRect;Color:TColor;BtnRoundArc:integer);
procedure DrawBtnInnerLine(ACanvas:TCanvas;Rect:TRect;Color:TColor;BtnRoundArc:integer);
procedure DrawBtnBottomLine(ACanvas:TCanvas;Rect:TRect;Color:TColor);
{*******************Tommstudio.com update********************}


procedure Register;

implementation


procedure Register;
begin
  RegisterComponents('XP', [TXPMenu]);
end;

{ TXPMenue }

constructor TXPMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ////////////////////////

{*******************Tommstudio.com update********************}
  SetControlUseTrueXPStyle(True);
  FBtnRoundArc:=5;
{*******************Tommstudio.com update********************}


  FFont := TFont.Create;
  GetSystemMenuFont(FFont);
  FForm := Owner as TScrollingWinControl;

  FUseSystemColors := true;


  FColor := clBtnFace;
  FIconBackColor := clBtnFace;
  FSelectColor := clHighlight;
  FSelectBorderColor := clHighlight;
  FMenuBarColor := clBtnFace;
  FDisabledColor := clInactiveCaption;
  FSeparatorColor := clBtnFace;
  FCheckedColor := clHighlight;
  FSelectFontColor := FFont.Color;
  FGrayLevel := 10;
  FDimLevel := 30;
  FIconWidth := 24;
  FDrawSelect := true;
  XPContainers := [xccForm, xccFrame, xccToolbar, xccCoolbar, xccControlbar, xccPanel,
                  xccScrollBox, xccGroupBox, xccTabSheet, xccPageScroller];
  XPControls := [xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcCombo,
                xcEdit, xcMaskEdit, xcMemo, xcRichEdit, xcCheckBox, xcRadioButton,
                xcButton, xcBitBtn, xcSpeedButton, xcPanel, xcGroupBox];

  {if FActive then
  begin
    InitItems(FForm, true, false);
  end;
  }
end;

destructor TXPMenu.Destroy;
begin
  InitItems(FForm, false, false);
  FFont.Free;

  inherited;
end;


{to check for new sub items}
procedure TXPMenu.ActivateMenuItem(MenuItem: TMenuItem);

  procedure Activate(MenuItem: TMenuItem);
  begin
    if (MenuItem.Tag <> 999) then
    if addr(MenuItem.OnDrawItem) <> addr(TXPMenu.DrawItem) then
    begin
      if (not assigned(MenuItem.OnDrawItem)) or (FOverrideOwnerDraw) then
        MenuItem.OnDrawItem := DrawItem;
      if (not assigned(MenuItem.OnMeasureItem)) or (FOverrideOwnerDraw) then
        MenuItem.OnMeasureItem := MeasureItem;
    end
  end;

var
  i, j: integer;
begin

  Activate(MenuItem);
  for i := 0 to MenuItem.Parent.Count -1 do
  begin
    Activate(MenuItem.Parent.Items[i]);
    for j := 0 to MenuItem.Parent.Items[i].Count - 1 do
      ActivateMenuItem(MenuItem.Parent.Items[i].Items[j]);
  end;

end;

procedure TXPMenu.InitItems(wForm: TWinControl; Enable, Update: boolean );

  procedure Activate(MenuItem: TMenuItem);
  begin
    if Enable then
    begin
      if (MenuItem.Tag <> 999) then
      begin
        if (not assigned(MenuItem.OnDrawItem)) or (FOverrideOwnerDraw) then
          MenuItem.OnDrawItem := DrawItem;
        if (not assigned(MenuItem.OnMeasureItem)) or (FOverrideOwnerDraw) then
          MenuItem.OnMeasureItem := MeasureItem;
      end;
    end
    else
    begin
      if addr(MenuItem.OnDrawItem) = addr(TXPMenu.DrawItem) then
        MenuItem.OnDrawItem := nil;
      if addr(MenuItem.OnMeasureItem) = addr(TXPMenu.MeasureItem) then
        MenuItem.OnMeasureItem := nil;
    end;
  end;

  procedure ItrateMenu(MenuItem: TMenuItem);
  var
    i: integer;
  begin
    Activate(MenuItem);
    for i := 0 to MenuItem.Count - 1 do
      ItrateMenu(MenuItem.Items[i]);
  end;

var
  i, x: integer;
  Comp: TComponent;

begin
  for i := 0 to wForm.ComponentCount - 1 do
  begin
    Comp := wForm.Components[i];

    if (Comp is TMainMenu) and (xcMainMenu in XPControls) and (TMainMenu(Comp).Tag <> 999)then
    begin
      for x := 0 to TMainMenu(Comp).Items.Count - 1 do
      begin
        TMainMenu(Comp).OwnerDraw := Enable;
        Activate(TMainMenu(Comp).Items[x]);
        ItrateMenu(TMainMenu(Comp).Items[x]);
      end;
    end;

    if (Comp is TPopupMenu) and (xcPopupMenu in XPControls) then
    begin
      for x := 0 to TPopupMenu(Comp).Items.Count - 1 do
      begin
        TPopupMenu(Comp).OwnerDraw := Enable;
        Activate(TPopupMenu(Comp).Items[x]);
        ItrateMenu(TPopupMenu(Comp).Items[x]);

      end;
    end;

    {$IFDEF VER5U}
    if (Comp is TToolBar) and (xcToolBar in FXPControls) then
      if not (csDesigning in ComponentState) then
      begin
        if not TToolBar(Comp).Flat then
          TToolBar(Comp).Flat := true;

        if Enable then
        begin
          for x := 0 to TToolBar(Comp).ButtonCount - 1 do
            if (not assigned(TToolBar(Comp).OnCustomDrawButton))
              or (FOverrideOwnerDraw) then
            begin
              TToolBar(Comp).OnCustomDrawButton :=
                ToolBarDrawButton;

            end;
        end
        else
        begin
          if addr(TToolBar(Comp).OnCustomDrawButton) =
            addr(TXPMenu.ToolBarDrawButton) then
          TToolBar(Comp).OnCustomDrawButton := nil;
        end;
        if Update then
          TToolBar(Comp).Invalidate;
      end;