aqdockingutils.pas

来自「AutomatedDocking Library 控件源代码修改 适合Delp」· PAS 代码 · 共 2,359 行 · 第 1/5 页

{*******************************************************************}
{                                                                   }
{       AutomatedDocking Library (Cross-Platform Edition)           }
{                                                                   }
{       Copyright (c) 1999-2008 AutomatedQA Corp.                   }
{       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 AUTOMATEDQA CORP. THE REGISTERED DEVELOPER IS        }
{   LICENSED TO DISTRIBUTE THE AUTOMATEDDOCKING LIBRARY AND ALL     }
{   ACCOMPANYING VCL AND CLX 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 WRITTEN CONSENT          }
{   AND PERMISSION FROM AUTOMATEDQA CORP.                           }
{                                                                   }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON       }
{   ADDITIONAL RESTRICTIONS.                                        }
{                                                                   }
{*******************************************************************}

unit aqDockingUtils;

{$I aqDockingVer.inc}

interface

uses
  Classes, Types, SysUtils, Variants,
{$IFDEF MSWINDOWS}
  Windows, CommCtrl, ImgList, ActiveX,
{$ENDIF}
{$IFDEF VCL}
  Controls, ExtCtrls, Graphics, Messages, Menus, Forms, ComCtrls, AppEvnts,
{$ELSE}
  Qt, QControls, QGraphics, QForms, QComCtrls, QMenus, QActnList, QStdActns,
{$ENDIF}
  Contnrs;

type
{$IFDEF VCL}
  TaqControl = TWinControl;
  TaqHandle = THandle;
{$ELSE}
  TaqControl = TWidgetControl;
  TaqHandle = QWidgetH;
{$ENDIF}
  PaqHandle = ^TaqHandle;
  PHandle = ^THandle;
const
  aqNullHandle: TaqHandle = {$IFDEF VCL}0{$ELSE}nil{$ENDIF};
  GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}';

type
  TaqRegionComplexity = type Integer;
const
  aqRegionError: TaqRegionComplexity = RGN_ERROR;
  aqRegionSimple: TaqRegionComplexity = SIMPLEREGION;
  aqRegionComplex: TaqRegionComplexity = COMPLEXREGION;
  aqRegionEmpty: TaqRegionComplexity = NULLREGION;

type
  TaqBucketList = class;
  TaqClassList = class;
  TaqStringList = class;

  TaqBucketListItem = record
    Key: Pointer;
    Data: Pointer;
  end;

  TaqCustomBucketListIterator = class(TObject)
  public
    procedure Reset; virtual; abstract;
    function HasNext: Boolean; virtual; abstract;
    function Next: TaqBucketListItem; virtual; abstract;
  end;

  TaqBucketList = class(TBucketList)
  private
    FCount: Integer;
  protected
    function AddItem(ABucket: Integer; AItem, AData: Pointer): Pointer; override;
    function DeleteItem(ABucket: Integer; AIndex: Integer): Pointer; override;
  public
    function Iterator: TaqCustomBucketListIterator;
    property Count: Integer read FCount;
  end;

  TaqIntegerList = class(TaqBucketList)
  private
    function GetData(AIndex: Integer): TObject;
    procedure SetData(AIndex: Integer; const Value: TObject);
  public
    constructor Create;

    function Add(AIndex: Integer; AData: TObject): TObject;
    property Data[AIndex: Integer]: TObject read GetData write SetData; default;
  end;

  TaqClassObjectList = class(TaqBucketList)
  private
    FOwnItems: Boolean;
  protected
    function GetData(AItem: TClass): TObject;
    procedure SetData(AItem: TClass; const AData: TObject);
    function DeleteItem(ABucket: Integer; AIndex: Integer): Pointer; override;
  public
    constructor Create(AOwnItems: Boolean = True);

    function Add(AItem: TClass; AData: TObject): TObject;
    function Remove(AItem: TClass): TObject;
    function FindParented(AItem: TClass): TObject;

    property Data[AItem: TClass]: TObject read GetData write SetData; default;
  end;

  TaqClassListEvent = procedure (Sender: TaqClassList;
    const ClassName: string; Item: TPersistentClass) of object;

  TaqClassList = class(TObject)
  private
    FItems: TStrings;
    FOnUnregister: TaqClassListEvent;
    FOnRegister: TaqClassListEvent;
    function GetCount: Integer;
    function GetItem(Index: Integer): TPersistentClass;
    function GetName(Item: TPersistentClass): string;
  protected
    procedure DoRegister(const ClassName: string; Item: TPersistentClass); virtual;
    procedure DoUnregister(const ClassName: string; Item: TPersistentClass); virtual;
  public
    constructor Create;
    destructor Destroy; override;
    function GetClassName(Index: Integer): string;
    function FindClass(const Name: string): TPersistentClass;
    procedure RegisterClass(const Name: string; Item: TPersistentClass);
    function UnregisterClass(const Name: string): TPersistentClass;

    property Count: Integer read GetCount;
    property Items[Index: Integer]: TPersistentClass read GetItem; default;
    property Names[Item: TPersistentClass]: string read GetName;
    property OnRegister: TaqClassListEvent read FOnRegister write FOnRegister;
    property OnUnregister: TaqClassListEvent read FOnUnregister write FOnUnregister;
  end;

  PaqStringEntry = ^TaqStringEntry;
  TaqStringEntry = packed record
    Key: string;
    Value: Pointer;
    Next: PaqStringEntry;
  end;
  TaqStringArray = array of PaqStringEntry;

  TaqStringList = class(TObject)
  private
    FItems: TaqStringArray;
    FCount: Integer;
    FCapacity: Integer;
    FThreshold: Integer;
    FLoadFactor: Single;
    function CalculateHash(const Value: string): Integer;
    procedure Rehash;
    function Get(const Key: string): Pointer;
    procedure Put(const Key: string; Value: Pointer);
    function FindItem(const Key: string): PaqStringEntry;
  public
    constructor Create(Capacity: Integer = 11);
    destructor Destroy; override;

    function Add(const Key: string; Data: Pointer): Pointer;
    function Remove(const Key: string): Pointer;
    function Find(const Key: string; out Value: Pointer): Boolean;
    procedure Clear;
    function Iterator: TaqCustomBucketListIterator;

    property Items[const Key: string]: Pointer read Get write Put; default;
    property Count: Integer read FCount;
  end;

  TaqWindowNotifyEvent = procedure (Sender: TControl) of object;

  TaqWindowEventFilter = class(TObject)
  private
    FControlHandle: TaqHandle;
    FControl: TaqControl;
    FDestroying: Boolean;
    FOnMove: TaqWindowNotifyEvent;
    FOnResize: TaqWindowNotifyEvent;
    FOnDestroy: TaqWindowNotifyEvent;
    FOnScroll: TaqWindowNotifyEvent;
{$IFDEF VCL}
    FDefWndProc: Pointer;
    FIsUnicode : Boolean;
    procedure WndProc(var Message: TMessage); virtual;
{$ELSE}
    FHooks: QWidget_hookH;
    function MainEventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl;
{$ENDIF}
  protected
    procedure DoMove;
    procedure DoResize;
    procedure DoScroll;
    procedure DoDestroy;

    procedure AttachTo(ControlHandle: TaqHandle);
    procedure DetachFrom(ControlHandle: TaqHandle);
  public
    destructor Destroy; override;

    procedure AttachToWindow(Wnd: TaqControl);
    procedure DetachFromWindow; virtual;

    property Window: TaqControl read FControl;
    property Handle: TaqHandle read FControlHandle;
    property OnMove: TaqWindowNotifyEvent read FOnMove write FOnMove;
    property OnResize: TaqWindowNotifyEvent read FOnResize write FOnResize;
    property OnScroll: TaqWindowNotifyEvent read FOnScroll write FOnScroll;
    property OnDestroy: TaqWindowNotifyEvent read FOnDestroy write FOnDestroy;
  end;

  TaqWindowEventFilterEx = class(TaqWindowEventFilter)
  private
    FInitialized: Boolean;
  public
    constructor Create;

    procedure AttachToWindowByHandle(Handle: TaqHandle);
    procedure DetachFromWindow; override;
  end;

{$IFDEF VCL}
  TaqCustomControl = class(TCustomControl)
  protected             
    procedure WMEraseBackground(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure Paint; override;
  end;
{$ELSE}
   // NOTE: TaqCustomControl is introduced to fix the problem with
   // TCustomControl.UpdateMask and to avoid flickering.
  TaqCustomControl = class(TWidgetControl)
  private
    FCanvas: TCanvas;
    FDoubleBuffered: Boolean;
    procedure UpdateMask;
    function GetCanvas: TCanvas;
    function GetAlignDisabled: Boolean;
  protected
    procedure PaletteChanged(Sender: TObject); override;
    procedure BoundsChanged; override;
    procedure CreateWidget; override;
    procedure Painting(Sender: QObjectH; EventRegion: QRegionH); override;
    function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; override;
    procedure Paint; virtual;
    procedure MaskChanged; override;
    procedure DrawMask(Canvas: TCanvas); virtual;
    property Canvas: TCanvas read GetCanvas;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Invalidate; override;

    property AlignDisabled: Boolean read GetAlignDisabled;
    property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered;
  end;
{$ENDIF}

  TaqChangeLink = class(TObject)
  private
    FSender: TObject;
    FOwner: TComponent;
    FOnChange: TNotifyEvent;
  protected
    property Owner: TComponent read FOwner;
  public
    constructor Create(AOwner: TComponent = nil);
    procedure Change; dynamic;

    property Sender: TObject read FSender write FSender;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TaqFreeNotificationEvent = procedure (Sender: TComponent) of object;

  TaqFreeNotifier = class(TComponent)
  private
    FOnFreeNotification: TaqFreeNotificationEvent;
  protected
    procedure DoFreeNotification(Sender: TComponent); virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    procedure AddSender(ASender: TComponent);
    procedure RemoveSender(ASender: TComponent);
    property OnFreeNotification: TaqFreeNotificationEvent read FOnFreeNotification write FOnFreeNotification;
  end;

  TaqTargetFreeNotifier = class(TaqFreeNotifier)
  private
    FTarget: TComponent;
    function GetTargetFreed: Boolean;
  protected
    procedure DoFreeNotification(Sender: TComponent); override;
  public
    constructor Create(ATarget: TComponent); override;
    property TargetFreed: Boolean read GetTargetFreed;
  end;

  TaqAllowItemAdd = function (AItem: TMenuItem): Boolean;

{$IFDEF VCL}
  TaqApplicationEvents = class(TApplicationEvents);
{$ELSE}
  TaqApplicationEvents = class(TComponent)
  private
    FOnActionExecute: TActionEvent;
    FOnActionUpdate: TActionEvent;
    FOnException: TExceptionEvent;
    FOnHelp: THelpEvent;
    FOnHint: TNotifyEvent;
    FOnIdle: TIdleEvent;
    FOnDeactivate: TNotifyEvent;
    FOnActivate: TNotifyEvent;
    FOnMinimize: TNotifyEvent;
    FOnRestore: TNotifyEvent;
    FOnShortCut: TShortCutEvent;
    FOnShowHint: TShowHintEvent;
    FOnModalBegin: TNotifyEvent;
    FOnModalEnd: TNotifyEvent;
    procedure DoActionExecute(Action: TBasicAction; var Handled: Boolean);
    procedure DoActionUpdate(Action: TBasicAction; var Handled: Boolean);
    procedure DoActivate(Sender: TObject);
    procedure DoDeactivate(Sender: TObject);
    procedure DoException(Sender: TObject; E: Exception);
    procedure DoIdle(Sender: TObject; var Done: Boolean);
    function DoHelp(HelpType: THelpType; HelpContext: THelpContext;
      const HelpKeyword: String; const HelpFile: String; var Handled: Boolean): Boolean;
    procedure DoHint(Sender: TObject);
    procedure DoMinimize(Sender: TObject);
    procedure DoRestore(Sender: TObject);
    procedure DoShowHint(var HintStr: WideString; var CanShow: Boolean;
      var HintInfo: THintInfo);
    procedure DoShortcut(Key: Integer; Shift: TShiftState; var Handled: Boolean);
    procedure DoModalBegin(Sender: TObject);
    procedure DoModalEnd(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    procedure Activate;
    procedure CancelDispatch;

    property OnActionExecute: TActionEvent read FOnActionExecute write FOnActionExecute;
    property OnActionUpdate: TActionEvent read FOnActionUpdate write FOnActionUpdate;
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
    property OnException: TExceptionEvent read FOnException write FOnException;
    property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
    property OnHelp: THelpEvent read FOnHelp write FOnHelp;
    property OnHint: TNotifyEvent read FOnHint write FOnHint;
    property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
    property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
    property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
    property OnShortCut: TShortCutEvent read FOnShortCut write FOnShortCut;
    property OnModalBegin: TNotifyEvent read FOnModalBegin write FOnModalBegin;
    property OnModalEnd: TNotifyEvent read FOnModalEnd write FOnModalEnd;
  end;
{$ENDIF}


{$IFDEF VCL}
  TImageListDIB = class(TImageList)
  private
    procedure CopyImages(Value: HImageList; Index: Integer = -1);
    function  InternalGetInstRes(Instance: THandle; ResType: TResType;
      Name: PChar; Width: Integer; LoadFlags: Cardinal;
      MaskColor: TColor): Boolean;
  public
    function GetInstRes(Instance: THandle; ResType: TResType; const Name: string;
      Width: Integer; LoadFlags: Cardinal; MaskColor: TColor): Boolean;
    procedure CreateRegionFromItem(ImageIndex: Integer; var Region: THandle);
  end;
{$ENDIF VCL}

  IaqCustomDesigner = interface(IInterface)
  ['{02A07181-F50B-4DDE-A2B0-F078BF26DB18}']
    procedure SelectComponent(Component: TPersistent); overload;
    procedure SelectComponent(Manager: TComponent; Component: TPersistent); overload;
    function UniqueName(Owner: TComponent; const BaseName: string): string;
    procedure Modified(Instance: TPersistent);
  end;

procedure aqWriteGUID(AStream: TStream; const AValue: TGUID);
procedure aqReadGUID(AStream: TStream; out AValue: TGUID);
procedure aqWriteString(AStream: TStream; const AString: string);
function aqReadString(AStream: TStream): string;
procedure aqGetDesigner(Obj: TPersistent; out Result: IDesignerNotify);
procedure aqNotifyDesigner(Self, Item: TPersistent; Operation: TOperation);

{$IFDEF VCL}
procedure aqMergeMenu(Source: TMenu; Dest: HMENU; Proc: TaqAllowItemAdd = nil);
{$ENDIF}
procedure aqMergeMenuItems(Source: TMenuItem; Dest: TMenu; Proc: TaqAllowItemAdd = nil);

{$IFNDEF VCL}
function IsChild(ParentWidget, Widget: TaqHandle): Boolean; overload;
function IsChild(ParentWidget, Widget: TWidgetControl): Boolean; overload;
function GetCursorPos(var P: TPoint): Boolean;
{$ENDIF}
function aqGetParent(Handle: TaqHandle): TaqHandle;
procedure aqEnumChildWindows(Parent: TaqHandle; Children: TList);
function aqIsWindowHigher(Wnd1, Wnd2: TaqHandle): Integer;

function aqIsCaptured: Boolean;

procedure aqShowHintWindow(Pos: TPoint; const Text: string);
procedure aqHideHintWindow;

procedure aqEditCaption(Item: TListItem);
procedure aqMakeVisible(Item: TListItem);

procedure aqSelectionSort(SortList: PPointerList; L, R: Integer;
  SCompare: TListSortCompare);

function aqGetWindowHandle(Window: TControl): THandle;
function aqGetRootParent(Control: TControl): TaqControl;
function aqGetRootParentHandle(Control: TControl): TaqHandle;
procedure aqLockWindowRedraw(Handle: TaqHandle);
procedure aqUnlockWindowRedraw(Handle: TaqHandle);

function aqMouseTrack(const P1, P2: TPoint): Integer;
function aqButtonToShiftState(Button: TMouseButton): TShiftState;

function aqIsRgnEmpty(Region: TaqHandle): Boolean;
procedure aqTransformRegion(var Region: TaqHandle; const Transformation: TXForm);
function aqDuplicateRegion(Region: TaqHandle): TaqHandle;
function aqEqualRgn(Region1, Region2: TaqHandle): Boolean;
function aqGetRegionComplexity(Region: TaqHandle): TaqRegionComplexity;

function aqPointToStr(Value: TPoint): string;
function aqRectToStr(Value: TRect): string;
function aqVarToIntDef(Value: OleVariant; DefValue: Integer = 0): Integer;
function aqVarToBoolDef(Value: OleVariant; DefValue: Boolean = False): Boolean;
function aqVarToByteDef(Value: OleVariant; DefValue: Byte = 0): Byte;
function aqVarToPointDef(Value: OleVariant; const DefValue: TPoint): TPoint;
function aqVarToRectDef(Value: OleVariant; const DefValue: TRect): TRect;
{$IFNDEF DELPHI7}
function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;
{$ENDIF}

var
  aqIDEDesigner: IaqCustomDesigner;

implementation

uses
  StrUtils, Math,
{$IFDEF LINUX}
  Libc, QDialogs,
{$ENDIF}
{$IFNDEF VCL}
  QConsts,