xpmenu.pas

以前写的一个利用P2P 技术的一个通讯的例子。里面用到了 DBISAM 、INDY 控件。

{
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, xccToolbar, xccCoolbar);
   TXPContainers = set of TXPContainer;

   TXPControl = (xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcSpeedButton);

   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 PaintSpeedButton;
   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时的颜色
      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, xccToolbar, xccCoolbar];
      property XPControls: TXPControls read FXPControls write SetXPControls
         default [xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcSpeedButton];

      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 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, xccToolbar, xccCoolbar];
   XPControls := [xcMainMenu, xcPopupMenu, xcToolbar, xcControlbar, xcSpeedButton];

   {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;