{**********************************************************************************************
 *                   刀劍如夢軟件創作室整理                                                   *
 *主頁名稱：Delphi編程驛站                                                                    *
 *本站的宗旨：讓Delphi編程愛好者更好地進行技術交流與探討。                                    *
 *主頁地址：http://yckxzjj.vip.sina.com                                                       *
 *E-Mail地址：yckxzjj@163.com                                                                 *
 *QQ號碼：20775028                                                                            *
 *欄目設置：                                                                                  *
 *    主欄目→程序人生、編程技巧、精品控件、實例源碼、網友作品、技術交流、軟件項目及好書推薦。*
 *    輔欄目→網站簡介、網站導航、本站服務、網站更新、關于版主及友情鏈接。                    *
 *Delphi編程驛站，Delphi交流的空間站！網絡中愿與您共同進步！我一直在努力！！！                *
 *Delphi編程驛站，以Delphi為主題的編程站點，明確的主題、一致的版面。                          *
 *本站點已獲得萬維品網“三星級”評定、閃光品網“精品站點”BEST認證評定                        *
 *及騰龍品網的“推薦站點”。                                                                  *
 **********************************************************************************************
}
{
XPMenu for Delphi
Author: Khaled Shagrouni
URL: http://www.shagrouni.com/english/software/xpmenu.html
e-mail: khaled@shagrouni.com
        shagrouni@hotmail.com
Version 3.0 - 08.04.2003



XPMenu is a Delphi component to mimic Office XP menu and toolbar style.
Copyright (C) 2001, 2003 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 <shagrouni@hotmail.com> (Please state the XPMenu version and OS information).
}

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

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

{$IFDEF VER150}
{$DEFINE VER5U}
{$DEFINE VER6U}
{$DEFINE VER7U}
{$ENDIF}

unit XPMenu;

interface

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

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

  TXPControl = (xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcCombo, xcListBox,
                xcEdit, xcMaskEdit, xcMemo, xcRichEdit, xcMiscEdit, xcCheckBox,
                xcRadioButton, xcButton, xcBitBtn, xcSpeedButton, xcUpDown, xcPanel,
                xcGroupBox, xcTreeView, xcListView, xcProgressBar, xcHotKey);
                {xcStringGrid, xcDrawGrid, xcDBGrid);}

  TXPControls = set of TXPControl;

  TXPMenu = class;

  TControlSubClass = class(TComponent)   //:   "Fabian Jakubowski" <fj@sambreville.com>
  private
    Control: TControl;
    FBuilding: boolean;
    FMouseInControl: boolean;
    FLButtonBressed: boolean;
    FBressed: boolean;
    FIsKeyDown: boolean;
    FIsFocused: boolean;
    orgWindowProc: TWndMethod;
    XPMenu: TXPMenu;
    FCtl3D: boolean;
    FBorderStyle: TBorderStyle;
  {FOnDrawCell: TDrawCellEvent;}
    FDefaultDrawing: boolean;
    FSelCol, FSelRow: integer;
    FMsg: Cardinal;
    procedure ControlSubClass(var Message: TMessage);
    procedure PaintControlXP;
    procedure PaintCombo;
    procedure PaintDBLookupCombo;
    procedure PaintEdit;
    procedure PaintRichEdit;
    procedure PaintCheckBox;
    procedure PaintRadio;
    procedure PaintButton;
    procedure PaintBitButn;
    procedure PaintUpDownButton;
    procedure PaintSpeedButton;
    procedure PaintPanel;
    procedure PaintGroupBox;
    procedure PaintNCWinControl;
    procedure PaintProgressBar;
    procedure PaintHotKey;
  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;
    FColorsChanged: boolean; // +jt

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

    Is16Bit: boolean;
    FOverrideOwnerDraw: boolean;
    FGradient: boolean;
    FFlatMenu: boolean;
    FAutoDetect: boolean;
    FXPContainers: TXPContainers;
    FXPControls: TXPControls;
    FGrayLevel: byte;
    FDimLevel: byte;
    FDrawMenuBar: boolean;
    FUseDimColor: boolean;
    FDimParentColor, FDimParentColorSelect: integer;
   // FUseParentClor: boolean;
// +jt
    FSettingWindowRng: boolean;    FIsW2k:            boolean;    FIsWXP:            boolean;    FIsWNT:            boolean;    FTransparentColor: TColor;// +jt

   // Do not allow the component to be used for subclassing
    FDisableSubclassing: boolean;
    procedure SetDisableSubclassing(const Value: boolean);

    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);
    procedure SetDrawMenuBar(const Value: boolean);
    procedure SetUseDimColor(const Value: boolean);

  protected
    procedure Loaded; override; //add by Cunha, liyang.
    procedure InitItems(wForm: TWinControl; Enable, Update: boolean);
    procedure InitItem(Comp: TComponent; Enable, Update: boolean); // Tom: "Thomas Knoblauch" <thomas@tom-the-bomb.de> 27.08
    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 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 MeasureItem(Sender: TObject; ACanvas: TCanvas;
      var Width, Height: Integer);

    //function GetImageExtent(MenuItem: TMenuItem): TPoint;
    function GetImageExtent(MenuItem: TMenuItem; FTopMenu: TMenu): TPoint; // +jt
    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;
    procedure InitComponent(Comp: TComponent); // Tom: Added for usage by the main program ."Thomas Knoblauch" <thomas@tom-the-bomb.de> 27.08
    procedure ActivateMenuItem(MenuItem: TMenuItem; SubMenus: boolean); // +jt
    property Form: TScrollingWinControl read FForm write SetForm;
// +jt
    property IsWXP: boolean read FIsWXP;    property IsW2k: boolean read FIsW2k;    property IsWNT: boolean read FIsWNT;    property TransparentColor: TColor read FTransparentColor write FTransparentColor;// +jt
  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 DrawMenuBar: boolean read FDrawMenuBar write SetDrawMenuBar;
    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 UseDimColor: boolean read FUseDimColor write SetUseDimColor;
    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, xcListBox,
               xcEdit, xcMaskEdit, xcMemo, xcRichEdit, xcMiscEdit, xcCheckBox,
               xcRadioButton, xcButton, xcBitBtn, xcSpeedButton, xcUpDown, xcPanel,
               xcGroupBox, xcTreeView, xcListView, xcProgressBar, xcHotKey];
               {xcStringGrid, xcDrawGrid, xcDBGrid];}

    property Active: boolean read FActive write SetActive;
    property DisableSubclassing: boolean read FDisableSubclassing write SetDisablesubclassing
      default false;
  end;

  TXPMenuManager = class(TPersistent)
  private
    FXPMenuList: TList;
    FPendingFormsList: TList;
    FFormList: TList;
    FActiveXPMenu: TXPMenu;
    FDisableSubclassing: boolean;

    function MainWindowHook(var Message: TMessage): boolean;
    procedure CollectForms;
    procedure RemoveChildSubclassing(AForm: TCustomForm);
    procedure SetDisableSubclassing(AValue: boolean);
    function FindSubclassingXPMenu(Exclude: TXPMenu): TXPMenu;

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

  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(AXPMenu: TXPMenu);
    procedure Delete(AXPMenu: TXPMenu);
    procedure UpdateActiveXPMenu(AXPMenu: TXPMenu);
    procedure AddForm(AForm: TCustomForm);
    procedure RemoveForm(AForm: TCustomForm);
    function IsFormSubclassed(AForm: TCustomForm): boolean;
    function IsComponentSubclassed(AComponent: TComponent): boolean;

    property ActiveXPMenu: TXPMenu read FActiveXPMenu;
    property DisableSubclassing: boolean read FDisableSubclassing write SetDisableSubclassing
      default false;
  end;

function GetShadeColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
function MergColor(Colors: Array of TColor): TColor;
function NewColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
procedure DimBitmap(ABitmap: TBitmap; Value: integer);

procedure DrawArrow(ACanvas: TCanvas; X, Y: integer); overload;
procedure DrawArrow(ACanvas: TCanvas; X, Y, Orientation: integer); overload;
function GrayColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
function GetInverseColor(AColor: TColor): 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);
procedure Register;

const
  WM_DRAWMENUBORDER     = CN_NOTIFY + 101;   // +jt
  WM_DRAWMENUBORDER2    = CN_NOTIFY + 102;   // +jt

// Gloabal access to the XPMenuManager
var
  XPMenuManager: TXPMenuManager;

implementation

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

// Set up the global variable that represents the XPMenuManager
procedure InitControls;
begin
  if XPMenuManager = nil then
    XPMenuManager := TXPMenuManager.Create;
end;

// Delete the global variable that represents the XPMenuManager
procedure DoneControls;
begin
  if (XPMenuManager <> nil) then
  begin
    XPMenuManager.Free;
    XPMenuManager := nil;
  end;
end;

// Test if mouse cursor is in the given rect of the application's main form
function IsMouseInRect(TheForm: TScrollingWinControl; DestRect: TRect): boolean;
var
  p: TPoint;

begin

  if Assigned(TheForm) then
  begin
    p := Mouse.CursorPos;
    p.x := p.x - TheForm.Left;
    p.y := p.y - TheForm.Top;

    Dec(DestRect.Right);
    Dec(DestRect.Bottom, 2);
    Result := (p.x >= DestRect.Left) and (p.x <= DestRect.Right) and
              (p.y >= DestRect.Top) and (p.y <= DestRect.Bottom);
  end
  else Result := false;
end;

{ TXPMenue }

constructor TXPMenu.Create(AOwner: TComponent);
var
  OSVersionInfo: TOSVersionInfo; // +jt
begin
  inherited Create(AOwner);
  FFont := TFont.Create;

  FDisableSubclassing := false;        // enable XPMenu to be used for global subclassing


{$IFDEF VER5U}
  FFont.Assign(Screen.MenuFont);
{$ELSE}
  GetSystemMenuFont(FFont);
{$ENDIF}
  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, xcListBox,
                xcEdit, xcMaskEdit, xcMemo, xcRichEdit, xcMiscEdit, xcCheckBox,
                xcRadioButton, xcButton, xcBitBtn, xcSpeedButton, xcUpDown, xcPanel,
                xcGroupBox, xcTreeView, xcListView, xcProgressBar, xcHotKey];
            {xcStringGrid, xcDrawGrid, xcDBGrid];}

  if Assigned(FForm) then
    SetGlobalColor(TForm(FForm).Canvas);

// +jt
  FTransparentColor := clFuchsia;  FColorsChanged    := false;  OSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo);  GetVersionEx(OSVersionInfo);  FIsWXP:=false;  FIsW2k:=false;