aqdockingutils.pas

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

constructor TaqClassObjectList.Create(AOwnItems: Boolean);
begin
  inherited Create;
  FOwnItems := AOwnItems;
end;

function TaqClassObjectList.DeleteItem(ABucket, AIndex: Integer): Pointer;
begin
  Result := inherited DeleteItem(ABucket, AIndex);
  if FOwnItems then TObject(Result).Free;
end;

function TaqClassObjectList.FindParented(AItem: TClass): TObject;
begin
  while not Find(AItem, Pointer(Result)) do
  begin
    AItem := AItem.ClassParent;
    if AItem = nil then
    begin
      Result := nil;
      Exit;
    end;
  end;
end;

function TaqClassObjectList.GetData(AItem: TClass): TObject;
begin
  Result := TObject(inherited Data[AItem]);
end;

function TaqClassObjectList.Remove(AItem: TClass): TObject;
begin
  Result := TObject(inherited Remove(AItem));
end;

procedure TaqClassObjectList.SetData(AItem: TClass; const AData: TObject);
begin
  inherited Data[AItem] := AData;
end;

{ TaqIntegerList }

function TaqIntegerList.Add(AIndex: Integer; AData: TObject): TObject;
begin
  Result := TObject(inherited Add(Pointer(AIndex), AData));
end;

constructor TaqIntegerList.Create;
begin
  inherited Create;
end;

function TaqIntegerList.GetData(AIndex: Integer): TObject;
begin
  Result := inherited Data[Pointer(AIndex)];
end;

procedure TaqIntegerList.SetData(AIndex: Integer; const Value: TObject);
begin
  inherited Data[Pointer(AIndex)] := Value;
end;

{ TaqIntegerListIterator }

constructor TaqBucketListIterator.Create(AList: TaqBucketList);
begin
  inherited Create;
  FList := AList;
  FSearch := New(PaqBucketListSearch);
  PaqBucketListSearch(FSearch)^.CurBucket := -2;
  Reset;
end;

destructor TaqBucketListIterator.Destroy;
begin
  Dispose(FSearch);
  inherited;
end;

function TaqBucketListIterator.FindNext(out ABucket: Integer; out AIndex: Integer): Boolean;
var
  i: Integer;
begin
  with PaqBucketListSearch(FSearch)^ do
  begin
    if (CurBucket = FBucket) and (CurIndex = FIndex) then
    begin
      ABucket := NextBucket;
      AIndex := NextIndex;
      Result := SearchResult;
      Exit;
    end;
    CurBucket := FBucket;
    CurIndex := FIndex;
  end;
  Result := False;
  if FBucket < FList.BucketCount then
  begin
    if (FBucket >= 0) and (FIndex < TaqBucketListFriend(FList).Buckets[FBucket].Count - 1) then
    begin
      AIndex := FIndex + 1;
      ABucket := FBucket;
      Result := True;
    end
    else
    begin
      for i := FBucket + 1 to FList.BucketCount - 1 do
        if TaqBucketListFriend(FList).Buckets[i].Count > 0 then
        begin
          ABucket := i;
          AIndex := 0;
          Result := True;
          Break;
        end;
      if not Result then
        ABucket := FList.BucketCount;
    end;
  end;
  with PaqBucketListSearch(FSearch)^ do
  begin
    NextBucket := ABucket;
    NextIndex := AIndex;
    SearchResult := Result;
  end;
end;

function TaqBucketListIterator.HasNext: Boolean;
var
  i, j: Integer;
begin
  Result := FindNext(i, j);
end;

function TaqBucketListIterator.Next: TaqBucketListItem;
begin
  if not FindNext(FBucket, FIndex) then
    raise EaqBucketList.Create(SEListNoItems);
  with FList.Buckets[FBucket].Items[FIndex] do
  begin
    Result.Key := Item;
    Result.Data := Data;
    Assert(Result.Data <> nil);
  end;
end;

procedure TaqBucketListIterator.Reset;
begin
  FBucket := -1; FIndex := 0;
end;


{$IFDEF VCL}
type
  TGetWindowLongPtr = function(Handle: hWnd; nIndex: Integer): Longint; stdcall;
  TSetWindowLongPtr = function(Handle: hWnd; nIndex: Integer; dwNewLong: Longint): Longint; stdcall;

var
  user32dll: TaqHandle;
  GetWindowLongPtr : TGetWindowLongPtr;
  GetWindowLongPtrW: TGetWindowLongPtr;
  SetWindowLongPtr : TSetWindowLongPtr;
  SetWindowLongPtrW: TSetWindowLongPtr;

procedure InitializeWindowManagmentFunctions;
const
  User32dllName         = 'user32.dll';
  GetWindowLongPtrName  = 'GetWindowLongPtrA';
  GetWindowLongPtrWName = 'GetWindowLongPtrW';
  SetWindowLongPtrName  = 'SetWindowLongPtrA';
  SetWindowLongPtrWName = 'SetWindowLongPtrW';

begin
  user32dll := LoadLibrary(PChar(User32dllName));
  GetWindowLongPtr  := GetProcAddress(user32dll, PChar(GetWindowLongPtrName));
  if @GetWindowLongPtr = nil then
     GetWindowLongPtr := GetWindowLong;
  GetWindowLongPtrW := GetProcAddress(user32dll, PChar(GetWindowLongPtrWName));
  if @GetWindowLongPtrW = nil then
    GetWindowLongPtrW := GetWindowLongW;

  SetWindowLongPtr  := GetProcAddress(user32dll, PChar(SetWindowLongPtrName));
  if @SetWindowLongPtr = nil then
    SetWindowLongPtr  := SetWindowLong;
  SetWindowLongPtrW := GetProcAddress(user32dll, PChar(SetWindowLongPtrWName));
  if @SetWindowLongPtrW = nil then
    SetWindowLongPtrW  := SetWindowLongW;
end;

procedure ReleaseWindowManagementFunctions;
begin
  FreeLibrary(user32dll);
end;
{$ENDIF}

{ TaqWindowEventFilter }

procedure TaqWindowEventFilter.AttachTo(ControlHandle: TaqHandle);
var
{$IFDEF VCL}
  PrevDefWndProc: Pointer;
{$ELSE}
  Method: TMethod;
{$ENDIF}
begin
{$IFDEF VCL}
  FDefWndProc := Classes.MakeObjectInstance(WndProc);
  FIsUnicode := IsWindowUnicode(ControlHandle);
  if FIsUnicode then
    PrevDefWndProc := Pointer(GetWindowLongPtrW(ControlHandle, GWL_WNDPROC))
  else
    PrevDefWndProc := Pointer(GetWindowLongPtr(ControlHandle, GWL_WNDPROC));

  GetHooks.AddHook(ControlHandle, PrevDefWndProc, FDefWndProc);
  if FIsUnicode then
     SetWindowLongPtrW(ControlHandle, GWL_WNDPROC, Integer(FDefWndProc))
  else
    SetWindowLongPtr(ControlHandle, GWL_WNDPROC, Integer(FDefWndProc));
{$ELSE}
  FHooks := QWidget_hook_create(ControlHandle);
  TEventFilterMethod(Method) := MainEventFilter;
  Qt_hook_hook_events(FHooks, Method);
{$ENDIF}
end;

procedure TaqWindowEventFilter.DetachFrom(ControlHandle: TaqHandle);
{$IFDEF VCL}
var
  PrevDefWndProc: Pointer;
{$ENDIF}
begin
{$IFDEF VCL}
  PrevDefWndProc := GetHooks.RemoveHook(ControlHandle, FDefWndProc);
  if FIsUnicode then
    SetWindowLongW(FControlHandle, GWL_WNDPROC, Longint(PrevDefWndProc))
  else
    SetWindowLong(FControlHandle, GWL_WNDPROC, Longint(PrevDefWndProc));
  Classes.FreeObjectInstance(FDefWndProc);
  FDefWndProc := nil;
{$ELSE}
  QWidget_hook_destroy(FHooks);
  FHooks := nil;
{$ENDIF}
end;

procedure TaqWindowEventFilter.AttachToWindow(Wnd: TaqControl);
begin
  if FControl <> nil then
    DetachFromWindow
  else
    FDestroying := False;
  FControl := Wnd;
  if FControl = nil then
    Exit;
{$IFDEF VCL}
  FControlHandle := FControl.Handle;
{$ELSE}
  FControlHandle := TWidgetControl(FControl).Handle;
{$ENDIF}
  AttachTo(FControlHandle);
end;

procedure TaqWindowEventFilter.DetachFromWindow;
begin
  if FControl <> nil then
    DetachFrom(FControlHandle);
  FControl := nil;
  FControlHandle := 0;
end;

destructor TaqWindowEventFilter.Destroy;
begin
  DetachFromWindow;
  inherited;
end;

procedure TaqWindowEventFilter.DoMove;
begin
  if Assigned(FOnMove) then
    FOnMove(FControl);
end;

procedure TaqWindowEventFilter.DoResize;
begin
  if Assigned(FOnResize) then
    FOnResize(FControl);
end;

procedure TaqWindowEventFilter.DoScroll;
begin
  if Assigned(FOnScroll) then
    FOnScroll(FControl);
end;

procedure TaqWindowEventFilter.DoDestroy;
begin
  if Assigned(FOnDestroy) then
    FOnDestroy(FControl);
end;

{$IFDEF VCL}
procedure TaqWindowEventFilter.WndProc(var Message: TMessage);

  procedure CallDefWndProc;
  begin
    with Message do
    begin
      if FIsUnicode then
        Result := CallWindowProcW(GetHooks.GetPrevHook(FControlHandle, FDefWndProc),
          FControlHandle, Msg, WParam, LParam)
      else
        Result := CallWindowProc(GetHooks.GetPrevHook(FControlHandle, FDefWndProc),
          FControlHandle, Msg, WParam, LParam);
    end;
  end;

var
  TempHandle: THandle;
begin
  Assert(FControlHandle <> 0);
  case Message.Msg of
    WM_MOVE:
      if not FDestroying then
      begin
        CallDefWndProc;
        DoMove;
        Exit;
      end;
    WM_SIZE:
      if not FDestroying then
      begin
        CallDefWndProc;
        DoResize;
        Exit;
      end;
    WM_HSCROLL, WM_VSCROLL:
      if not FDestroying then
      begin
        CallDefWndProc;
        DoScroll;
        Exit;
      end;
    WM_SETFOCUS:
      if FDestroying then
        Exit;
    WM_DESTROY:
    begin
      if not FDestroying then
      begin
        TempHandle := FControlHandle;
        FDestroying := True;
        DoDestroy;
        DetachFromWindow;
        with Message do
          SendMessage(TempHandle, Msg, WParam, LParam);
        Exit;
      end;
    end;
  end;
  CallDefWndProc;
end;
{$ELSE}
function TaqWindowEventFilter.MainEventFilter(Sender: QObjectH;
  Event: QEventH): Boolean;
begin
  Assert(FControl <> nil);
  case QEvent_type(Event) of
    QEventType_Move: DoMove;
    QEventType_Resize: DoResize;
  end;
  Result := TaqControlFriend(FControl).MainEventFilter(Sender, Event);
end;
{$ENDIF}

{$IFDEF MSWINDOWS}
{ TaqWindowEventFilterEx }

constructor TaqWindowEventFilterEx.Create;
begin
  inherited Create;
  FInitialized := False;
end;

procedure TaqWindowEventFilterEx.AttachToWindowByHandle(Handle: TaqHandle);
begin
  if (FControlHandle <> 0) then
    DetachFromWindow
  else
    FDestroying := False;

  FControlHandle := Handle;
  FControl := FindControl(Handle);
  if FControlHandle = 0 then
    Exit;
  FInitialized := True;
  AttachTo(FControlHandle);
end;

procedure TaqWindowEventFilterEx.DetachFromWindow;
begin
  if not FInitialized then
    inherited
  else
  begin
    if FControlHandle <> 0 then
      DetachFrom(FControlHandle);
    FControlHandle := 0;
    FControl := nil;
    FInitialized := False;
  end;
end;

{$ENDIF}


{ TaqCustomControl }

{$IFDEF VCL}

procedure TaqCustomControl.Paint;
begin
  // By default, fill client rect with default Brush.
  Canvas.Brush := Brush;
  Canvas.FillRect(ClientRect);
end;

procedure TaqCustomControl.WMEraseBackground(var Message: TWMEraseBkgnd);
begin
  // Do not clear control's background. Move all painting procedures to
  // the Paint method.
  Message.Result := 1;
end;

{$ELSE}

procedure TaqCustomControl.BoundsChanged;
begin
  inherited BoundsChanged;
  if Masked then
    UpdateMask;
end;

constructor TaqCustomControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TaqControlCanvas.Create;
  TaqControlCanvas(FCanvas).Control := Self;
end;

procedure TaqCustomControl.CreateWidget;
begin
  FHandle := QWidget_create(ParentWidget, nil, WidgetFlags);
  Hooks := QWidget_hook_create(FHandle);

  // Control should not not clear its background, all
  // painting operations are moved to the Paint method.
  QWidget_setBackgroundMode(Handle, QWidgetBackgroundMode_NoBackground);
end;

destructor TaqCustomControl.Destroy;
begin
  FreeAndNil(FCanvas);
  inherited Destroy;
end;

procedure TaqCustomControl.DrawMask(Canvas: TCanvas);
var
  R: TRect;
  I: Integer;
begin
  R := ClientRect;
  Canvas.Brush.Color := clMask;