cxhint.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,789 行 · 第 1/4 页

{********************************************************************}
{                                                                    }
{       Developer Express Visual Component Library                   }
{       ExpressEditors                                               }
{                                                                    }
{       Copyright (c) 1998-2008 Developer Express Inc.               }
{       ALL RIGHTS RESERVED                                          }
{                                                                    }
{   The entire contents of this file is protected by U.S. and        }
{   International Copyright Laws. Unauthorized reproduction,         }
{   reverse-engineering, and distribution of all or any portion of   }
{   the code contained in this file is strictly prohibited and may   }
{   result in severe civil and criminal penalties and will be        }
{   prosecuted to the maximum extent possible under the law.         }
{                                                                    }
{   RESTRICTIONS                                                     }
{                                                                    }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES            }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE     }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS    }
{   LICENSED TO DISTRIBUTE THE EXPRESSEDITORS AND ALL                }
{   ACCOMPANYING VCL CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY. }
{                                                                    }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED       }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE         }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE        }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT   }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                       }
{                                                                    }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON        }
{   ADDITIONAL RESTRICTIONS.                                         }
{                                                                    }
{********************************************************************}

unit cxHint;

{$I cxVer.inc}

interface

uses
{$IFDEF DELPHI6}
  Variants,
{$ENDIF}
  Windows, Classes, Forms, Controls{must be after Forms for D11}, Graphics,
  ImgList, Messages, StdCtrls, SysUtils, cxClasses, cxContainer, cxControls,
  cxEdit, cxGraphics, cxLookAndFeels, cxTextEdit;

type
  TcxCustomHintStyleController = class;
  TcxCustomHintStyle = class;
  TcxCustomHintWindow = class;
  TcxHintAnimationDelay = 0..1000;
  TcxHintStyleChangedEvent = procedure (Sender: TObject; AStyle: TcxCustomHintStyle) of object;
  TcxShowHintEvent = procedure(Sender: TObject; var HintStr: string;
    var CanShow: Boolean; var HintInfo: THintInfo) of object;
  TcxShowHintExEvent = procedure(Sender: TObject; var Caption, HintStr: string;
    var CanShow: Boolean; var HintInfo: THintInfo) of object;
  TcxCallOutPosition = (cxbpNone, cxbpAuto, cxbpLeftBottom, cxbpLeftTop, cxbpTopLeft,
    cxbpTopRight, cxbpRightBottom, cxbpRightTop, cxbpBottomRight, cxbpBottomLeft);
  TcxHintIconType = (cxhiNone, cxhiApplication, cxhiInformation, cxhiWarning,
    cxhiError, cxhiQuestion, cxhiWinLogo, cxhiCurrentApplication, cxhiCustom);
  TcxHintAnimate = TcxHintAnimationStyle;
  TcxHintIconSize = (cxisDefault, cxisLarge, cxisSmall);

  IcxHint = interface
  ['{0680CE5D-391B-45A1-B55D-AFCAE92F2DA6}']
    function GetAnimate: TcxHintAnimate;
    function GetAnimationDelay: TcxHintAnimationDelay;
    function GetBorderColor: TColor;
    function GetCallOutPosition: TcxCallOutPosition;
    function GetColor: TColor;
    function GetIconSize: TcxHintIconSize;
    function GetIconType: TcxHintIconType;
    function GetHintCaption: string;
    function GetRounded: Boolean;
    function GetRoundRadius: Integer;
    function GetStandard: Boolean;
    function GetHintFont: TFont;
    function GetHintCaptionFont: TFont;
    function GetHintIcon: TIcon;
    procedure SetHintCaption(Value: string);
    property HintCaption: string read GetHintCaption write SetHintCaption;
  end;

  { TcxCustomHintStyle }
  
  TcxCustomHintStyle = class(TPersistent)
  private
    FAnimate: TcxHintAnimate;
    FAnimationDelay: TcxHintAnimationDelay;
    FCallOutPosition: TcxCallOutPosition;
    FBorderColor: TColor;
    FColor: TColor;
    FFont: TFont;
    FCaptionFont: TFont;
    FIcon: TIcon;
    FIconSize: TcxHintIconSize;
    FIconType: TcxHintIconType;
    FRounded: Boolean;
    FRoundRadius: Integer;
    FStandard: Boolean;
    FDirectAccessMode: Boolean;
    FIsDestroying: Boolean;
    FModified: Boolean;
    FOwner: TPersistent;
    FUpdateCount: Integer;
    FOnChanged: TNotifyEvent;
    function GetControl: TcxControl;
    function GetFont: TFont;
    procedure SetAnimate(Value: TcxHintAnimate);
    procedure SetAnimationDelay(Value: TcxHintAnimationDelay);
    procedure SetCallOutPosition(Value: TcxCallOutPosition);
    procedure SetBorderColor(Value: TColor);
    procedure SetCaptionFont(Value: TFont);
    procedure SetColor(Value: TColor);
    procedure SetFont(Value: TFont);
    procedure SetIcon(Value: TIcon);
    procedure SetIconSize(Value: TcxHintIconSize);
    procedure SetIconType(Value: TcxHintIconType);
    procedure SetRounded(Value: Boolean);
    procedure SetRoundRadius(Value: Integer);
    procedure SetStandard(Value: Boolean);
    procedure IconChangeHandler(Sender: TObject);
    procedure InternalRestoreDefault;
  protected
    FHintStyleController: TcxCustomHintStyleController;
    function GetOwner: TPersistent; override;
    function BaseGetHintStyleController: TcxCustomHintStyleController;
    procedure BaseSetHintStyleController(Value: TcxCustomHintStyleController);
    procedure Changed; virtual;
    procedure ControllerChangedNotification(AStyleController: TcxCustomHintStyleController); virtual;
    procedure ControllerFreeNotification(AHintStyleController: TcxCustomHintStyleController); virtual;
    procedure HintStyleControllerChanged; virtual;
    property HintStyleController: TcxCustomHintStyleController read BaseGetHintStyleController
      write BaseSetHintStyleController;
    property IsDestroying: Boolean read FIsDestroying write FIsDestroying;
    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
  public
    constructor Create(AOwner: TPersistent; ADirectAccessMode: Boolean); virtual;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure BeginUpdate;
    procedure EndUpdate;
    class function GetDefaultHintStyleController: TcxCustomHintStyleController; virtual;
    procedure RestoreDefaults; virtual;
    property Control: TcxControl read GetControl;
    property DirectAccessMode: Boolean read FDirectAccessMode;
  published
    property Animate: TcxHintAnimate read FAnimate write SetAnimate default cxhaAuto;
    property AnimationDelay: TcxHintAnimationDelay read FAnimationDelay write SetAnimationDelay default 100;
    property BorderColor: TColor read FBorderColor write SetBorderColor default clWindowFrame;
    property CallOutPosition: TcxCallOutPosition read FCallOutPosition write SetCallOutPosition default cxbpNone;
    property CaptionFont: TFont read FCaptionFont write SetCaptionFont;
    property Color: TColor read FColor write SetColor default clInfoBk;
    property Font: TFont read GetFont write SetFont;
    property Icon: TIcon read FIcon write SetIcon;
    property IconSize: TcxHintIconSize read FIconSize write SetIconSize default cxisDefault;
    property IconType: TcxHintIconType read FIconType write SetIconType default cxhiNone;
    property Rounded: Boolean read FRounded write SetRounded default False;
    property RoundRadius: Integer read FRoundRadius write SetRoundRadius default 11;
    property Standard: Boolean read FStandard write SetStandard default False;
  end;

  TcxCustomHintWindowClass = class of TcxCustomHintWindow;
  TcxHintStyleClass = class of TcxCustomHintStyle;

  { TcxCustomHintStyleController }

  TcxCustomHintStyleController = class(TComponent)
  private
    FGlobal: Boolean;
    FActive: Boolean;
    FIsDestruction: Boolean;
    FListeners: TList;
    FOnHintStyleChanged: TcxHintStyleChangedEvent;
    FOnShowHint: TcxShowHintEvent;
    FOnShowHintEx: TcxShowHintExEvent;
    FHintShortPause: Integer;
    FHintPause: Integer;
    FHintHidePause: Integer;
    FHintWindow: TcxCustomHintWindow;
    FPreviousHintWindowClass: THintWindowClass;
    FUpdateCount: Integer;
    procedure DoApplicationShowHint(var HintStr: string; var CanShow: Boolean;
      var HintInfo: THintInfo);
    procedure DoShowHint(var AHintStr: string; var ACanShow: Boolean;
      var AHintInfo: THintInfo);
    procedure DoShowHintEx(var AHintStr, AHintCaption: string; var ACanShow: Boolean;
      var AHintInfo: THintInfo);
    function IsGlobalStored: Boolean;
    procedure SetGlobal(Value: Boolean);
    procedure SetHintStyle(Value: TcxCustomHintStyle);
    procedure HintStyleChanged(Sender: TObject);
    procedure SetHintShortPause(Value: Integer);
    procedure SetHintPause(Value: Integer);
    procedure SetHintHidePause(Value: Integer);
    procedure SetApplicationHintProperties;
    procedure ShowHintHandler(var HintStr: string; var CanShow: Boolean;
      var HintInfo: THintInfo);
  protected
    FHintStyle: TcxCustomHintStyle;
    function GetHintStyleClass: TcxHintStyleClass; virtual;
    function GetHintWindowClass: TcxCustomHintWindowClass; virtual;
    procedure InitHintWindowClass; virtual;
    procedure Loaded; override;
    procedure BeginUpdate; virtual;
    procedure EndUpdate; virtual;
    procedure AddListener(AListener: TcxCustomHintStyle); virtual;
    procedure Changed;
    procedure DoHintStyleChanged(AStyle: TcxCustomHintStyle); virtual;
    procedure RemoveListener(AListener: TcxCustomHintStyle); virtual;
    procedure UninitHintWindowClass; virtual;
    property Active: Boolean read FActive;
    property Global: Boolean read FGlobal write SetGlobal stored IsGlobalStored;
    property HintHidePause: Integer read FHintHidePause write SetHintHidePause
      default 2500;
    property HintPause: Integer read FHintPause write SetHintPause default 500;
    property HintShortPause: Integer read FHintShortPause
      write SetHintShortPause default 50;
    property HintStyle: TcxCustomHintStyle read FHintStyle write SetHintStyle;
    property IsDestruction: Boolean read FIsDestruction write FIsDestruction;
    property Listeners: TList read FListeners;
    property OnHintStyleChanged: TcxHintStyleChangedEvent
      read FOnHintStyleChanged write FOnHintStyleChanged;
    property OnShowHint: TcxShowHintEvent read FOnShowHint write FOnShowHint;
    property OnShowHintEx: TcxShowHintExEvent read FOnShowHintEx write FOnShowHintEx;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure SaveShowHintEvent; virtual;
    procedure RestoreShowHintEvent; virtual;

    procedure ShowHint(X, Y: Integer; ACaption, AHint: string; AMaxWidth: Integer = 0);
    procedure HideHint;
    function GetHintWidth(AHint: string): Integer;
    function GetHintHeight(AHint: string): Integer;

    property HintWindow: TcxCustomHintWindow read FHintWindow;
  end;

  { TcxHintStyleController }

  TcxHintStyleController = class(TcxCustomHintStyleController)
  published
    property Global;
    property HintStyle;
    property HintShortPause;
    property HintPause;
    property HintHidePause;
    property OnHintStyleChanged;
    property OnShowHint;
    property OnShowHintEx;
  end;

  { TcxCustomHintWindow }

  TcxCustomHintWindow = class(TcxBaseHintWindow)
  private
    FCallOutPosition: TcxCallOutPosition;
    FBorderColor: TColor;
    FHintColor: TColor;
    FCaption, FText: string;
    FCaptionFont: TFont;
    FIcon: TIcon;
    FIconSize: TcxHintIconSize;
    FIconType: TcxHintIconType;
    FRounded: Boolean;
    FRoundRadius: Integer;
    FWordWrap: Boolean;
    Rgn: HRGN;
    FLeftRightMargint, FIconLeftMargin: Integer;
    FTopBottomMargin, FIconTopMargin: Integer;
    FIconHeight: Integer;
    FIconWidth: Integer;
    FCaptionRect: TRect;
    FTextRect: TRect;
    FHintWndRect: TRect;
    FCallOutSize: Byte;
    FCalculatedCallOutPos: TcxCallOutPosition;
    FIndentDelta: Integer;
    function GetAnimate: TcxHintAnimate;
    procedure SetAnimate(AValue: TcxHintAnimate);
    procedure SetIcon(Value: TIcon);
    procedure WMShowWindow(var Message: TWMShowWindow); message WM_SHOWWINDOW;
  protected
    procedure EnableRegion; override;

    procedure CreateBalloonForm; virtual;
    procedure Paint; override;
    procedure CalculateValues; virtual;
    procedure CalculateController; virtual;
    procedure CalculateIcon; virtual;
    function CalculateAutoCallOutPosition(const ARect: TRect): TcxCallOutPosition; virtual;
    procedure CalculateRects(const ACaption, AText: string;
      const AMaxWidth: Integer); virtual;
    procedure LoadPropertiesFromController(const AHintController: TcxCustomHintStyleController);
    procedure LoadPropertiesFromHintInterface(const AHintIntf: IcxHint);
    procedure LoadPropertiesFromHintStyle(const AHintStyle: TcxCustomHintStyle);

    property StandardHint: Boolean read FStandardHint write FStandardHint;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ActivateHint(ARect: TRect; const AHint: string); override;
    function CalcHintRect(MaxWidth: Integer; const AHint: string;
      AData: Pointer): TRect; override;
      
    property Animate: TcxHintAnimate read GetAnimate write SetAnimate; // obsolete
    property BorderColor: TColor read FBorderColor write FBorderColor;
    property CallOutPosition: TcxCallOutPosition read FCallOutPosition write FCallOutPosition;
    property Caption: string read FCaption write FCaption;
    property CaptionFont: TFont read FCaptionFont write FCaptionFont;
    property Icon: TIcon read FIcon write SetIcon;
    property IconSize: TcxHintIconSize read FIconSize write FIconSize;
    property IconType: TcxHintIconType read FIconType write FIconType;
    property Rounded: Boolean read FRounded write FRounded;
    property RoundRadius: Integer read FRoundRadius write FRoundRadius;
    property WordWrap: Boolean read FWordWrap write FWordWrap;
  end;

  { TcxHintWindow }
  
  TcxHintWindow = class(TcxCustomHintWindow)
  end;

implementation

uses
  Dialogs, cxEditConsts, cxEditUtils, cxExtEditUtils, dxThemeConsts,
  dxThemeManager, dxUxTheme;

type
{$IFNDEF DELPHI6}
  TAnimateWindowProc = function(hWnd: HWND; dwTime: DWORD; dwFlags: DWORD): BOOL; stdcall;
{$ENDIF}

  { TcxHintedControlController }

  TcxHintedControlController = class(TComponent)
  private
    FHintedControl: TControl;
    procedure SetHintedControl(Value: TControl);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    destructor Destroy; override;
    property HintedControl: TControl read FHintedControl write SetHintedControl;
  end;

{$IFNDEF DELPHI6}
const
  SPI_GETTOOLTIPANIMATION = $1016;
  SPI_GETTOOLTIPFADE = $1018;
{$ENDIF}

var
{$IFNDEF DELPHI6}
  AnimateWindowProc: TAnimateWindowProc = nil;
  UserHandle: THandle;
{$ENDIF}
  FControllerList: TList;
  FHintedControlController: TcxHintedControlController;
  FIsApplicationOnShowHintSaved: Boolean;
  FSavedApplicationOnShowHint: TShowHintEvent;

function FindHintController: TcxCustomHintStyleController; forward;
function FindHintedControl: TControl; forward;
function GetHintedControl: TControl; forward;
function GetWindowParent(AWnd: HWND): TWinControl; forward;
procedure SetHintedControl(Value: TControl); forward;

function FindHintController: TcxCustomHintStyleController;

  function FindHintControllerOnParents: TcxCustomHintStyleController;

    function FindHintControllerAmongComponents(
      AControl: TWinControl): TcxCustomHintStyleController;
    var
      AController: TcxCustomHintStyleController;
      I: Integer;
    begin
      Result := nil;
      for I := 0 to AControl.ComponentCount - 1 do
        if AControl.Components[I] is TcxCustomHintStyleController then
        begin
          AController := TcxCustomHintStyleController(AControl.Components[I]);
          if AController.Active then
          begin
            Result := AController;
            Break;
          end;
        end;
    end;

  var
    AHintedControl: TControl;
    AParent: TWinControl;
  begin
    Result := nil;
    AHintedControl := FindHintedControl;
    if AHintedControl = nil then
      Exit;
    if (AHintedControl is TWinControl) and TWinControl(AHintedControl).HandleAllocated then
      AParent := GetWindowParent(TWinControl(AHintedControl).Handle)
    else
      AParent := AHintedControl.Parent;
    while AParent <> nil do
    begin
      Result := FindHintControllerAmongComponents(AParent);
      if (Result <> nil) or not AParent.HandleAllocated then
        Break;
      AParent := GetWindowParent(AParent.Handle);
    end;
  end;

var
  AController: TcxCustomHintStyleController;
  I: Integer;
begin
  Result := FindHintControllerOnParents;
  if Result = nil then
    for I := FControllerList.Count - 1 downto 0 do
    begin
      AController := TcxCustomHintStyleController(FControllerList[I]);
      if AController.Active and AController.Global then
      begin
        Result := AController;
        Break;
      end;
    end;
end;

function FindHintedControl: TControl;
var
  AWnd: HWND;
begin
  if GetHintedControl <> nil then
    Result := GetHintedControl
  else
  begin
    Result := nil;
    AWnd := WindowFromPoint(InternalGetCursorPos);
    if AWnd <> 0 then
    begin
      Result := FindControl(AWnd);