aqdockingutils.pas

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

{$ENDIF}
  RTLConsts, aqDockingConst;

type
  TaqHookList = class(TObject)
  private
    FZombie: Boolean;
    FHooks: TaqBucketList;
    FLock: TRTLCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    procedure TryFree(Explicitly: Boolean = True);

    procedure AddHook(Control: TaqHandle; OldHook, Hook: Pointer);
    function RemoveHook(Control: TaqHandle; Hook: Pointer): Pointer;
    function GetPrevHook(Control: TaqHandle; Hook: Pointer): Pointer;
  end;


  TaqEmptyDesigner = class(TInterfacedObject, IaqCustomDesigner)
  protected
    { IaqCustomDesigner }
    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;

{$IFDEF VCL} 
  TaqControlCanvas = class(TControlCanvas);

  TaqApplicationHack = class(TComponent)
  private
    FPopupLevel: Integer;
    FPopupOwners: TList;
    FAppEvents: TaqApplicationEvents;
    procedure DoShowOwnedPopups(Show: Boolean);
  protected
    function ApplicationWindowHook(var Message: TMessage): Boolean;
    procedure ApplicationRestore(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

var
  AppHack: TaqApplicationHack = nil;
{$ELSE}
  TControlFriend = class(TControl);

  TaqControlCanvas = class(TControlCanvas)
  private
    FBitmap: TBitmap;
    FDoubleBuffered: Boolean;
  protected
    procedure BeginPainting; override;
  public
    destructor Destroy; override;
    procedure StopPaint;
    property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered;
  end;

  TMultiCaster = class(TComponent)
  private
    FAppEvents: TComponentList;
    FCacheAppEvent: TaqApplicationEvents;
    FCancelDispatching: Boolean;
    FDispatching: Integer;
    procedure BeginDispatch;
    procedure EndDispatch;
    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);
    function GetCount: Integer;
    function GetAppEvents(Index: Integer): TaqApplicationEvents;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Activate(AppEvent: TaqApplicationEvents);
    procedure AddAppEvent(AppEvent: TaqApplicationEvents);
    procedure CancelDispatch;
    function CheckDispatching(AppEvents: TaqApplicationEvents): Boolean;

    property AppEvents[Index: Integer]: TaqApplicationEvents read GetAppEvents; default;
    property Count: Integer read GetCount;
  end;

var
  MultiCaster: TMultiCaster = nil;
{$ENDIF}
type
  TaqBucketListIterator = class(TaqCustomBucketListIterator)
  private
    FList: TaqBucketList;
    FBucket, FIndex: Integer;
    FSearch: Pointer;
  protected
    function FindNext(out ABucket, AIndex: Integer): Boolean;
  public
    constructor Create(AList: TaqBucketList);
    destructor Destroy; override;

    procedure Reset; override;
    function HasNext: Boolean; override;
    function Next: TaqBucketListItem; override;
  end;

  TaqStringListIterator = class(TaqCustomBucketListIterator)
  private
    FList: TaqStringList;
    FItems: TaqStringArray;
    FIndex: Integer;
    FEntry: PaqStringEntry;
  public
    constructor Create(AList: TaqStringList);

    procedure Reset; override;
    function HasNext: Boolean; override;
    function Next: TaqBucketListItem; override;
  end;

var
  HookList: TaqHookList;

function GetHooks: TaqHookList;
begin
  if HookList = nil then
    HookList := TaqHookList.Create;
  Result := HookList;
end;

procedure aqWriteString(AStream: TStream; const AString: string);
var
  I: Integer;
begin
  I := Length(AString);
  AStream.Write(I, SizeOf(I));
  if I > 0 then
    AStream.Write(AString[1], I);
end;

function aqReadString(AStream: TStream): string;
var
  I: Integer;
begin
  AStream.Read(I, SizeOf(I));
  SetLength(Result, I);
  if I > 0 then
    AStream.Read(Result[1], I);
end;

procedure aqWriteGUID(AStream: TStream; const AValue: TGUID);
begin
  AStream.Write(AValue, SizeOf(AValue));
end;

procedure aqReadGUID(AStream: TStream; out AValue: TGUID);
begin
  AStream.Read(AValue, SizeOf(AValue))
end;

type
  TPersistentFriend = class(TPersistent);
  TComponentFriend = class(TComponent);
  TaqControlFriend = class(TaqControl);

procedure aqGetDesigner(Obj: TPersistent; out Result: IDesignerNotify);
var
  Temp: TPersistent;
begin
  Result := nil;
  if Obj = nil then Exit;
  Temp := TPersistentFriend(Obj).GetOwner;
  if Temp = nil then
  begin
    if (Obj is TComponent) and (csDesigning in TComponent(Obj).ComponentState) then
      TComponentFriend(Obj).QueryInterface(IDesignerNotify, Result);
  end
  else
  begin
    if (Obj is TComponent) and
      not (csDesigning in TComponent(Obj).ComponentState) then Exit;
    aqGetDesigner(Temp, Result);
  end;
end;

procedure aqNotifyDesigner(Self, Item: TPersistent; Operation: TOperation);
var
  Designer: IDesignerNotify;
begin
  aqGetDesigner(Self, Designer);
  if Designer <> nil then
    Designer.Notification(Item, Operation);
end;

{$IFDEF VCL}
procedure aqMergeMenu(Source: TMenu; Dest: HMENU; Proc: TaqAllowItemAdd);
var
  i: Integer;
  Item: TMenuItemInfo;
begin
  for i := 0 to Source.Items.Count - 1 do
    if (Assigned(Proc) and Proc(Source.Items[i])) or not Assigned(Proc) then
      if Source.Items[i].IsLine then
        AppendMenu(Dest, MF_SEPARATOR, 0, nil)
      else
      begin
        FillChar(Item, SizeOf(Item), 0);
        with Item do
        begin
          cbSize := SizeOf(TMenuItemInfo);
          if Source.Images <> nil then
            fMask := MIIM_TYPE or MIIM_ID or MIIM_CHECKMARKS
          else
            fMask := MIIM_TYPE or MIIM_ID;
          fType := MFT_STRING or MFT_OWNERDRAW;
          fState := 0;
          wID := Source.Items[i].Command;
          hSubMenu := 0;
          dwTypeData := PChar(Source.Items[i].Caption);
          cch := Length(Source.Items[i].Caption);
        end;
        InsertMenuItem(Dest, Cardinal(-1), True, Item);
      end;
end;

{$ELSE}

function IsChild(ParentWidget, Widget: TaqHandle): Boolean;
begin
  Result := ParentWidget <> Widget;
  if Result then
    while ParentWidget <> Widget do
    begin
      if Widget = nil then
      begin
        Result := False;
        Exit;
      end;
      Widget := QWidget_parentWidget(Widget);
    end;
end;

function IsChild(ParentWidget, Widget: TWidgetControl): Boolean;
begin
  Result := IsChild(ParentWidget.Handle, Widget.Handle);
end;

function GetCursorPos(var P: TPoint): Boolean;
begin
  P := Mouse.CursorPos;
  Result := True;
end;
{$ENDIF}

procedure aqMergeMenuItems(Source: TMenuItem; Dest: TMenu; Proc: TaqAllowItemAdd);
var
  i: Integer;
  Item: TMenuItem;
begin
  if (Source = nil) or (Dest = nil) then Exit;
  for i := 0 to Source.Count - 1 do
    if not Assigned(Proc) or (Assigned(Proc) and Proc(Source.Items[i])) then
    begin
      Item := TMenuItem.Create(Dest);
      with Source.Items[i] do
      begin
        Item.Action := Source.Items[i].Action;
        if Item.Action = nil then
        begin
          Item.Caption := Caption;
          Item.Bitmap := Bitmap;
{$IFDEF VCL}
          Item.Break := Break;
          Item.SubMenuImages := SubMenuImages;
          Item.Default := Default;
{$ENDIF}
          Item.Checked := Checked;
          Item.Enabled := Enabled;
          Item.GroupIndex := GroupIndex;
          Item.HelpContext := HelpContext;
          Item.Hint := Hint;
          Item.ImageIndex := ImageIndex;
          Item.RadioItem := RadioItem;
          Item.ShortCut := Shortcut;
          Item.Visible := Visible;
          Item.Tag := Tag;
          Item.OnClick := OnClick;
        end;
      end;
      Dest.Items.Add(Item);
    end;
end;

function aqIsCaptured: Boolean;
begin
{$IFDEF VCL}
  Result := Windows.GetCapture <> 0;
{$ELSE}
  Result := QWidget_mouseGrabber <> nil;
{$ENDIF}
end;

var
  FHintWindow: THintWindow;
  FPos: TPoint = (X: -1; Y: -1);
  HintInfo: THintInfo;
  FVisible: Boolean;

procedure RestoreHintWindow;
begin
  if not FVisible then
    aqShowHintWindow(FPos, HintInfo.HintStr);
end;

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

  procedure ValidateHintWindow(HintClass: THintWindowClass);
  begin
    if HintClass = nil then HintClass := HintWindowClass;
    if (FHintWindow = nil) or (FHintWindow.ClassType <> HintClass) then
    begin
      if FHintWindow <> nil then
      begin
        FHintWindow.Hide;
        Application.ProcessMessages;
      end;
      FHintWindow.Free;
      FHintWindow := HintClass.Create(Application);
    end;
  end;

var
  ClientOrigin, ParentOrigin: TPoint;
  HintWinRect: TRect;
begin
  if Text <> '' then
  begin
    if (Pos.X = FPos.X) and (Pos.Y = FPos.Y) and (HintInfo.HintStr = Text) and
      FVisible then
      Exit;
    FVisible := True;
    FPos := Pos;

    HintInfo.HintControl := nil;
    HintInfo.HintPos := Pos;
    HintInfo.HintMaxWidth := Screen.Width;
    HintInfo.HintColor := Application.HintColor;
    HintInfo.CursorRect := Rect(Pos.X, Pos.Y, Pos.X + 1, Pos.Y + 1);
    ClientOrigin := Point(0, 0);
    ParentOrigin.X := 0;
    ParentOrigin.Y := 0;
    HintInfo.CursorPos := Point(0, 0);
    HintInfo.HintStr := Text;
    HintInfo.ReshowTimeout := 0;
    HintInfo.HideTimeout := 0;
    HintInfo.HintWindowClass := HintWindowClass;
    HintInfo.HintData := nil;

    ValidateHintWindow(HintWindowClass);
    
    // Calculate the width of the hint based on HintStr and MaxWidth.
    with HintInfo do
      HintWinRect := FHintWindow.CalcHintRect(HintMaxWidth, HintStr, HintData);
    OffsetRect(HintWinRect, HintInfo.HintPos.X, HintInfo.HintPos.Y);

    FHintWindow.Color := HintInfo.HintColor;
    FHintWindow.ActivateHintData(HintWinRect, HintInfo.HintStr, HintInfo.HintData);
    FHintWindow.Refresh;
  end
  else
    aqHideHintWindow;
end;

procedure aqHideHintWindow;
begin
  if (FHintWindow <> nil) and FHintWindow.HandleAllocated and
{$IFDEF VCL}
    IsWindowVisible(FHintWindow.Handle) then
    ShowWindow(FHintWindow.Handle, SW_HIDE);
{$ELSE}
    QWidget_isVisible(FHintWindow.Handle) then
    QWidget_hide(FHintWindow.Handle);
{$ENDIF}
  FVisible := False;
end;

type
  EaqBucketList = type Exception;

  TaqBucketListFriend = class(TaqBucketList);

  PaqBucketListSearch = ^TaqBucketListSearch;
  TaqBucketListSearch = record
    CurBucket, CurIndex: Integer;
    NextBucket, NextIndex: Integer;
    SearchResult: Boolean;
  end;

type
  TListViewFriend = class(TListView);
{$IFNDEF VCL}
  TCustomViewControlFriend = class(TCustomViewControl);
  TItemEditorFriend = class(TItemEditor);
{$ENDIF}

procedure aqEditCaption(Item: TListItem);
{$IFNDEF VCL}
const
  CEditorOffset = $204;
type
  PItemEditor = ^TItemEditor;

  function GetEditor(ListView: TCustomViewControl): TItemEditor;
  begin
    Result := PItemEditor(Pointer(Cardinal(Pointer(ListView)) + CEditorOffset))^;
  end;

  procedure SetEditor(ListView: TCustomViewControl; Value: TItemEditor);
  begin
    PItemEditor(Pointer(Cardinal(Pointer(ListView)) + CEditorOffset))^ := Value;
  end;

  procedure CheckRemoveEditor(ListView: TCustomViewControl);
  begin
    if not Assigned(GetEditor(ListView)) then
      Exit;
    TItemEditorFriend(GetEditor(ListView)).EditFinished(True);
    SetEditor(ListView, nil);
  end;

  procedure EditItem(ListView: TCustomViewControl);
  begin
    CheckRemoveEditor(ListView);
    if not (csDesigning in ListView.ComponentState) and
      not TCustomViewControlFriend(ListView).ReadOnly then
    begin
      SetEditor(ListView, TCustomViewControlFriend(ListView).CreateEditor);
      TItemEditorFriend(GetEditor(ListView)).Execute;
    end;
  end;
{$ENDIF}
begin
{$IFDEF VCL}
  Item.EditCaption;
{$ELSE}
   // Fix for TCustomViewControl: CLX guys forgot to publish the EditItem method,
   // so we have to hack the private field FEditor unfortunately.
   // NOTE: This should be removed as soon as TCustomViewControl is fixed.
  EditItem(Item.ListView);
{$ENDIF}
end;

procedure aqMakeVisible(Item: TListItem);
begin
{$IFNDEF VCL}
{$IF Defined(DELPHI7) or Defined(Kylix3)}
  Item.MakeVisible;