ucxpmenu.old.pas

delphi 控件有需要的可以下载看看,可以用的,希望对你用 帮助

{
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).

* changes by QmD 30/11/2003 - [e-mail]
* Add BitBtnColor / BitBtnSelectColor by QmD 30/11/2003 - [e-mail]
* BitBtn Button multi-line corrected
* 29/03/2004  XPmenu incorporated in User Control Package. Class renamed to UCXPmenu to prevent conflicts (http://usercontrol.sourceforge.net)
}

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

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


unit UCXPMenu;

interface

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

type
  TUCAboutXpStyleVar=String[10];

  TUCXPStyle = 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;
    XPStyle: TUCXPStyle;
    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;

  TUCXPStyle = class(TComponent)
  private
    FActive: boolean;
    {Changes MMK FForm to TScrollingWinControl}
    FForm: TScrollingWinControl;

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

    Is16Bit: boolean;

    FUCSettings: TUCSettings;
    FXPSettings: TUCXPSet;
    FUCAboutXpStyleVar: TUCAboutXpStyleVar;  {+qmd}

    procedure SetActive(const Value: boolean);
    procedure SetForm(const Value: TScrollingWinControl);


    procedure SetUCSettings(const Value: TUCSettings); {+qmd}
  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;
       TxtFont: TFont; TextFormat: integer);
    procedure DrawIcon(Sender: TObject; ACanvas: TCanvas; B: TBitmap; IconRect: Trect; Hot, Selected, Enabled, Checked, FTopMenu, IsRightToLeft: boolean);
    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;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Form: TScrollingWinControl read FForm write SetForm;
  published
    property About: TUCAboutXpStyleVar read FUCAboutXpStyleVar write FUCAboutXpStyleVar;
    property Active: boolean read FActive write SetActive;
    property XPSettings : TUCXPSet read FXPSettings write FXPSettings;
    property UCSettings : TUCSettings read FUCSettings write SetUCSettings;
  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);


implementation

{ TUCXPStyle }

constructor TUCXPStyle.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FXPSettings := TUCXPSet.Create(Self);
  FForm := Owner as TScrollingWinControl;

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

destructor TUCXPStyle.Destroy;
begin
  InitItems(FForm, false, false);
//  XPSettings.Font.Free;
  inherited;
end;


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

  procedure Activate(MenuItem: TMenuItem);
  begin
    if (MenuItem.Tag <> 999) then
    if addr(MenuItem.OnDrawItem) <> addr(TUCXPStyle.DrawItem) then
    begin
      if (not assigned(MenuItem.OnDrawItem)) or (FXPSettings.OverrideOwnerDraw) then
        MenuItem.OnDrawItem := DrawItem;
      if (not assigned(MenuItem.OnMeasureItem)) or (FXPSettings.OverrideOwnerDraw) 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 TUCXPStyle.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 (FXPSettings.OverrideOwnerDraw) then
          MenuItem.OnDrawItem := DrawItem;
        if (not assigned(MenuItem.OnMeasureItem)) or (FXPSettings.OverrideOwnerDraw) then
          MenuItem.OnMeasureItem := MeasureItem;
      end;
    end
    else
    begin
      if addr(MenuItem.OnDrawItem) = addr(TUCXPStyle.DrawItem) then
        MenuItem.OnDrawItem := nil;
      if addr(MenuItem.OnMeasureItem) = addr(TUCXPStyle.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 FXPSettings.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 FXPSettings.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(TUCXPStyle.ToolBarDrawButton) then
          TToolBar(Comp).OnCustomDrawButton := nil;
        end;
        if Update then
          TToolBar(Comp).Invalidate;
      end;
    {$ENDIF}

    if (Comp is TControlBar) and (xcControlBar in FXPSettings.XPControls) then
      if not (csDesigning in ComponentState) then
      begin
        if Enable then
        begin
          if (not assigned(TControlBar(Comp).OnBandPaint))
            or (FXPSettings.OverrideOwnerDraw) then
          begin
            TControlBar(Comp).OnBandPaint := ControlBarPaint;
          end;
        end
        else
        begin
          if addr(TControlBar(Comp).OnBandPaint) =
            addr(TUCXPStyle.ControlBarPaint) then
          TControlBar(Comp).OnBandPaint := nil;
        end;
        if Update then
          TControlBar(Comp).Invalidate;
      end;

    if not (csDesigning in ComponentState) then
      if {$IFDEF VER6U}
         ((Comp is TCustomCombo) and (xcCombo in FXPControls)) or
         ((Comp is TCustomLabeledEdit) and (xcEdit in FXPControls)) or

         {$ELSE}
         (( (Comp is TCustomComboBox) or (Comp is TDateTimePicker) ) and (xcCombo in FXPSettings.XPControls)) or
         {$ENDIF}
         (( (Comp is TEdit) or (Comp is TCustomEdit) )and (xcEdit in FXPSettings.XPControls)) or
         ((Comp.ClassName = 'TMaskEdit') and (xcMaskEdit in FXPSettings.XPControls)) or
         ((Comp.ClassName = 'TDBEdit') and (xcMaskEdit in FXPSettings.XPControls)) or
         ((Comp is TCustomMemo) and (xcMemo in FXPSettings.XPControls)) or
         ((Comp is TCustomRichEdit) and (xcRichEdit in FXPSettings.XPControls)) or

         ((Comp is TCustomCheckBox) and (xcCheckBox in FXPSettings.XPControls)) or
         ((Comp is TRadioButton) and (xcRadioButton in FXPSettings.XPControls)) or
         ((Comp.ClassName = 'TBitBtn') and (xcBitBtn in FXPSettings.XPControls)) or
         ((Comp.ClassName = 'TButton') and (xcButton in FXPSettings.XPControls)) or
         ((Comp.ClassName = 'TUpDown') and (xcButton in FXPSettings.XPControls)) or
         ((Comp is TSpeedButton) and (xcSpeedButton in FXPSettings.XPControls)) or
         ((Comp is TCustomPanel) and (xcPanel in FXPSettings.XPControls)) or
         ((Comp is TCustomGroupBox) and (xcGroupBox in FXPSettings.XPControls))
         then
        if ((TControl(Comp).Parent is TToolbar) and (xccToolBar in FXPSettings.XPContainers))or
           ((TControl(Comp).Parent is TCoolbar) and (xccCoolbar in FXPSettings.XPContainers)) or
           ((TControl(Comp).Parent is TCustomPanel) and (xccPanel in FXPSettings.XPContainers)) or
           ((TControl(Comp).Parent is TControlbar) and (xccControlbar in FXPSettings.XPContainers)) or
           ((TControl(Comp).Parent is TScrollBox) and (xccScrollBox in FXPSettings.XPContainers)) or
           ((TControl(Comp).Parent is TCustomGroupBox) and (xccGroupBox in FXPSettings.XPContainers)) or
           ((TControl(Comp).Parent is TTabSheet) and (xccTabSheet in FXPSettings.XPContainers)) or
           ((TControl(Comp).Parent.ClassName = 'TdxTabSheet') and (xccTabSheet in FXPSettings.XPContainers)) or //DeveloperExpress
           ((TControl(Comp).Parent is TPageScroller)  and (xccPageScroller in FXPSettings.XPContainers)) or
           {$IFDEF VER5U}
           ((TControl(Comp).Parent is TCustomFrame)  and (xccFrame in FXPContainers)) or
           {$ENDIF}
           ((TControl(Comp).Parent.ClassName = 'TDBCtrlPanel')  and (xccFrame in FXPSettings.XPContainers)) or

           ((TControl(Comp).Parent is TCustomForm) and (xccForm in FXPSettings.XPContainers))


           then
        begin
          if (Enable) and (Comp.Tag <> 999) and (TControl(Comp).Parent.Tag <> 999) then
                                      {skip if Control/Control.parent.tag = 999}
            with TControlSubClass.Create(Self)  do
            begin
              Control := TControl(Comp);
              if Addr(Control.WindowProc) <> Addr(TControlSubClass.ControlSubClass) then
              begin
                orgWindowProc := Control.WindowProc;
                Control.WindowProc := ControlSubClass;
              end;
              XPStyle := self;

              if (Control is TCustomEdit) then
              begin
                FCtl3D := TEdit(Control).Ctl3D;
                FBorderStyle := TRichEdit(Control).BorderStyle;
              end;

            end;

          if Update then
          begin
           // if Comp is TWinControl then    //Cause error with non wincontrol
              TControl(Comp).invalidate    //in TControlSubClass.ControlSubClass
           // else
           //   TControl(Comp).Update;
          end;

        end;


    // Recursive call for possible containers.
    {$IFDEF VER5U}
    if ((Comp is TCustomFrame) and (xccFrame in FXPContainers))
     or (Comp is TCustomForm) then  //By Geir Wikran <[e-mail]>
      self.InitItems(Comp as TWinControl, Enable, Update);
    {$ENDIF}


  end;
end;

procedure TUCXPStyle.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
  Selected: Boolean);
begin
  if FActive then
    MenueDrawItem(Sender, ACanvas, ARect, Selected);
end;



function TUCXPStyle.GetImageExtent(MenuItem: TMenuItem): TPoint;
var
  HasImgLstBitmap: boolean;
  B: TBitmap;
  FTopMenu: boolean;
begin
  FTopMenu := false;
  B := TBitmap.Create;
  B.Width := 0;
  B.Height := 0;
  Result.x := 0;
  Result.Y := 0;
  HasImgLstBitmap := false;

  {Changes MMK TForm and TFrame}
  if (FForm is TForm) and ((FForm as TForm).Menu <> nil) then
    if MenuItem.GetParentComponent.Name = (FForm as TForm).Menu.Name then
    begin
      FTopMenu := true;
      if (FForm as TForm).Menu.Images <> nil then
        if MenuItem.ImageIndex <> -1 then
          HasImgLstBitmap := true;

    end;

  {End Changes}


  if (MenuItem.Parent.GetParentMenu.Images <> nil)
  {$IFDEF VER5U}
  or (MenuItem.Parent.SubMenuImages <> nil)
  {$ENDIF}
  then
  begin
    if MenuItem.ImageIndex <> -1 then
      HasImgLstBitmap := true
    else
      HasImgLstBitmap := false;
  end;

  if HasImgLstBitmap then
  begin
  {$IFDEF VER5U}
    if MenuItem.Parent.SubMenuImages <> nil then
      MenuItem.Parent.SubMenuImages.GetBitmap(MenuItem.ImageIndex, B)
    else
  {$ENDIF}
      MenuItem.Parent.GetParentMenu.Images.GetBitmap(MenuItem.ImageIndex, B)
  end
  else
    if MenuItem.Bitmap.Width > 0 then
      B.Assign(TBitmap(MenuItem.Bitmap));

  Result.x := B.Width;
  Result.Y := B.Height;

  if not FTopMenu then
    if Result.x < FXPSettings.IconWidth then
      Result.x := FXPSettings.IconWidth;

  B.Free;
end;

procedure TUCXPStyle.MeasureItem(Sender: TObject; ACanvas: TCanvas;
  var Width, Height: Integer);
var
  s: string;
  W, H: integer;
  P: TPoint;
  IsLine: boolean;
  OSVersionInfo: TOSVersionInfo;
begin
  if FActive then
  begin
    S := TMenuItem(Sender).Caption;

    if S = '-' then IsLine := true else IsLine := false;
    if IsLine then
      S := '';

    if Trim(ShortCutToText(TMenuItem(Sender).ShortCut)) <> '' then
      S := S + ShortCutToText(TMenuItem(Sender).ShortCut) + 'WWW';