diff options
Diffstat (limited to 'apps/X11/VCL/TControl.cpp')
| -rw-r--r-- | apps/X11/VCL/TControl.cpp | 1874 |
1 files changed, 0 insertions, 1874 deletions
diff --git a/apps/X11/VCL/TControl.cpp b/apps/X11/VCL/TControl.cpp deleted file mode 100644 index 3a0ac4d..0000000 --- a/apps/X11/VCL/TControl.cpp +++ /dev/null @@ -1,1874 +0,0 @@ -#include <TControl.h> - -TControl::TControl(TComponent *AOwner) : TComponent(AOwner) { -} - -TControl::~TControl() { -} - - -/* -procedure TControl.Repaint; -var - DC: HDC; -begin - if (Visible or (csDesigning in ComponentState) and - not (csNoDesignVisible in ControlStyle)) and (Parent <> nil) and - Parent.HandleAllocated then - if csOpaque in ControlStyle then - begin - DC := GetDC(Parent.Handle); - try - IntersectClipRect(DC, Left, Top, Left + Width, Top + Height); - Parent.PaintControls(DC, Self); - finally - ReleaseDC(Parent.Handle, DC); - end; - end else - begin - Invalidate; - Update; - end; -end; -*/ -void TControl::Repaint() { -} - - -/* -{ TControl } - -constructor TControl.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FWindowProc := WndProc; - FControlStyle := [csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks]; - FFont := TFont.Create; - FFont.OnChange := FontChanged; - FAnchors := [akLeft, akTop]; - FConstraints := TSizeConstraints.Create(Self); - FConstraints.OnChange := DoConstraintsChange; - FColor := clWindow; - FVisible := True; - FEnabled := True; - FParentFont := True; - FParentColor := True; - FParentShowHint := True; - FParentBiDiMode := True; - FIsControl := False; - FDragCursor := crDrag; - FFloatingDockSiteClass := TCustomDockForm; -end; - -destructor TControl.Destroy; -begin - Application.ControlDestroyed(Self); - SetParent(nil); - if (FHostDockSite <> nil) and not (csDestroying in FHostDockSite.ComponentState) then - begin - FHostDockSite.Perform(CM_UNDOCKCLIENT, 0, Integer(Self)); - Dock(NullDockSite, BoundsRect); - FHostDockSite := nil; - end; - FActionLink.Free; - FActionLink := nil; - FConstraints.Free; - FFont.Free; - StrDispose(FText); - inherited Destroy; -end; - -function TControl.GetDragImages: TDragImageList; -begin - Result := nil; -end; - -function TControl.GetEnabled: Boolean; -begin - Result := FEnabled; -end; - -function TControl.GetPalette: HPALETTE; -begin - Result := 0; -end; - -function TControl.HasParent: Boolean; -begin - Result := FParent <> nil; -end; - -function TControl.GetParentComponent: TComponent; -begin - Result := Parent; -end; - -procedure TControl.SetParentComponent(Value: TComponent); -begin - if Value is TWinControl then SetParent(TWinControl(Value)); -end; - -function TControl.PaletteChanged(Foreground: Boolean): Boolean; -var - OldPalette, Palette: HPALETTE; - WindowHandle: HWnd; - DC: HDC; -begin - Result := False; - if not Visible then Exit; - Palette := GetPalette; - if Palette <> 0 then - begin - DC := GetDeviceContext(WindowHandle); - OldPalette := SelectPalette(DC, Palette, not Foreground); - if RealizePalette(DC) <> 0 then Invalidate; - SelectPalette(DC, OldPalette, True); - ReleaseDC(WindowHandle, DC); - Result := True; - end; -end; - -function TControl.GetAction: TBasicAction; -begin - if ActionLink <> nil then - Result := ActionLink.Action else - Result := nil; -end; - -procedure TControl.SetAction(Value: TBasicAction); -begin - if Value = nil then - begin - ActionLink.Free; - ActionLink := nil; - Exclude(FControlStyle, csActionClient); - end - else - begin - Include(FControlStyle, csActionClient); - if ActionLink = nil then - ActionLink := GetActionLinkClass.Create(Self); - ActionLink.Action := Value; - ActionLink.OnChange := DoActionChange; - ActionChange(Value, csLoading in Value.ComponentState); - Value.FreeNotification(Self); - end; -end; - -function TControl.IsAnchorsStored: Boolean; -begin - Result := Anchors <> AnchorAlign[Align]; -end; - -procedure TControl.SetDragMode(Value: TDragMode); -begin - FDragMode := Value; -end; - -procedure TControl.RequestAlign; -begin - if Parent <> nil then Parent.AlignControl(Self); -end; - -procedure TControl.Resize; -begin - if Assigned(FOnResize) then FOnResize(Self); -end; - -procedure TControl.ReadState(Reader: TReader); -begin - Include(FControlState, csReadingState); - if Reader.Parent is TWinControl then Parent := TWinControl(Reader.Parent); - inherited ReadState(Reader); - Exclude(FControlState, csReadingState); - if Parent <> nil then - begin - Perform(CM_PARENTCOLORCHANGED, 0, 0); - Perform(CM_PARENTFONTCHANGED, 0, 0); - Perform(CM_PARENTSHOWHINTCHANGED, 0, 0); - Perform(CM_SYSFONTCHANGED, 0, 0); - Perform(CM_PARENTBIDIMODECHANGED, 0, 0); - end; -end; - -procedure TControl.Notification(AComponent: TComponent; - Operation: TOperation); -begin - inherited Notification(AComponent, Operation); - if Operation = opRemove then - if AComponent = PopupMenu then PopupMenu := nil - else if AComponent = Action then Action := nil; -end; - -procedure TControl.SetAlign(Value: TAlign); -var - OldAlign: TAlign; -begin - if FAlign <> Value then - begin - OldAlign := FAlign; - FAlign := Value; - Anchors := AnchorAlign[Value]; - if not (csLoading in ComponentState) and (not (csDesigning in ComponentState) or - (Parent <> nil)) then - if ((OldAlign in [alTop, alBottom]) = (Value in [alRight, alLeft])) and - not (OldAlign in [alNone, alClient]) and not (Value in [alNone, alClient]) then - SetBounds(Left, Top, Height, Width) - else - AdjustSize; - end; - RequestAlign; -end; - -procedure TControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); -begin - if CheckNewSize(AWidth, AHeight) and - ((ALeft <> FLeft) or (ATop <> FTop) or - (AWidth <> FWidth) or (AHeight <> FHeight)) then - begin - InvalidateControl(Visible, False); - UpdateLastResize(AWidth, AHeight); - FLeft := ALeft; - FTop := ATop; - FWidth := AWidth; - FHeight := AHeight; - Invalidate; - Perform(WM_WINDOWPOSCHANGED, 0, 0); - RequestAlign; - if not (csLoading in ComponentState) then Resize; - end; -end; - -procedure TControl.SetLeft(Value: Integer); -begin - SetBounds(Value, FTop, FWidth, FHeight); - Include(FScalingFlags, sfLeft); -end; - -procedure TControl.SetTop(Value: Integer); -begin - SetBounds(FLeft, Value, FWidth, FHeight); - Include(FScalingFlags, sfTop); -end; - -procedure TControl.SetWidth(Value: Integer); -begin - SetBounds(FLeft, FTop, Value, FHeight); - Include(FScalingFlags, sfWidth); -end; - -procedure TControl.SetHeight(Value: Integer); -begin - SetBounds(FLeft, FTop, FWidth, Value); - Include(FScalingFlags, sfHeight); -end; - -procedure TControl.Dock(NewDockSite: TWinControl; ARect: TRect); -var - PrevDockSite: TWinControl; -begin - if HostDockSite <> NewDockSite then - begin - if (FHostDockSite <> nil) and (FHostDockSite.FDockClients <> nil) then - FHostDockSite.FDockClients.Remove(Self); - if (NewDockSite <> nil) and (NewDockSite <> NullDockSite) and - (NewDockSite.FDockClients <> nil) then - NewDockSite.FDockClients.Add(Self); - end; - Include(FControlState, csDocking); - try - if NewDockSite <> NullDockSite then - DoDock(NewDockSite, ARect); - if FHostDockSite <> NewDockSite then - begin - PrevDockSite := FHostDockSite; - if NewDockSite <> NullDockSite then - begin - FHostDockSite := NewDockSite; - if NewDockSite <> nil then NewDockSite.DoAddDockClient(Self, ARect); - end - else - FHostDockSite := nil; - if PrevDockSite <> nil then PrevDockSite.DoRemoveDockClient(Self); - end; - finally - Exclude(FControlState, csDocking); - end; -end; - -procedure TControl.DoDock(NewDockSite: TWinControl; var ARect: TRect); -begin - { Erase TControls before UpdateboundsRect modifies position } - if not (Self is TWinControl) then InvalidateControl(Visible, False); - if Parent <> NewDockSite then - UpdateBoundsRect(ARect) else - BoundsRect := ARect; - if (NewDockSite = nil) or (NewDockSite = NullDockSite) then Parent := nil; -end; - -procedure TControl.SetHostDockSite(Value: TWinControl); -begin - Dock(Value, BoundsRect); -end; - -function TControl.GetBoundsRect: TRect; -begin - Result.Left := Left; - Result.Top := Top; - Result.Right := Left + Width; - Result.Bottom := Top + Height; -end; - -procedure TControl.SetBoundsRect(const Rect: TRect); -begin - with Rect do SetBounds(Left, Top, Right - Left, Bottom - Top); -end; - -function TControl.GetClientRect: TRect; -begin - Result.Left := 0; - Result.Top := 0; - Result.Right := Width; - Result.Bottom := Height; -end; - -function TControl.GetClientWidth: Integer; -begin - Result := ClientRect.Right; -end; - -procedure TControl.SetClientWidth(Value: Integer); -begin - SetClientSize(Point(Value, ClientHeight)); -end; - -function TControl.GetClientHeight: Integer; -begin - Result := ClientRect.Bottom; -end; - -procedure TControl.SetClientHeight(Value: Integer); -begin - SetClientSize(Point(ClientWidth, Value)); -end; - -function TControl.GetClientOrigin: TPoint; -begin - if Parent = nil then - raise EInvalidOperation.CreateFmt(SParentRequired, [Name]); - Result := Parent.ClientOrigin; - Inc(Result.X, FLeft); - Inc(Result.Y, FTop); -end; - -function TControl.ClientToScreen(const Point: TPoint): TPoint; -var - Origin: TPoint; -begin - Origin := ClientOrigin; - Result.X := Point.X + Origin.X; - Result.Y := Point.Y + Origin.Y; -end; - -function TControl.ScreenToClient(const Point: TPoint): TPoint; -var - Origin: TPoint; -begin - Origin := ClientOrigin; - Result.X := Point.X - Origin.X; - Result.Y := Point.Y - Origin.Y; -end; - -procedure TControl.SendCancelMode(Sender: TControl); -var - Control: TControl; -begin - Control := Self; - while Control <> nil do - begin - if Control is TCustomForm then - TCustomForm(Control).SendCancelMode(Sender); - Control := Control.Parent; - end; -end; - -procedure TControl.SendDockNotification(Msg: Cardinal; WParam, LParam: Integer); -var - NotifyRec: TDockNotifyRec; -begin - if (FHostDockSite <> nil) and (DragObject = nil) and - (ComponentState * [csLoading, csDestroying] = []) then - begin - with NotifyRec do - begin - ClientMsg := Msg; - MsgWParam := WParam; - MsgLParam := LParam; - end; - FHostDockSite.Perform(CM_DOCKNOTIFICATION, Integer(Self), Integer(@NotifyRec)); - end; -end; - -procedure TControl.Changed; -begin - Perform(CM_CHANGED, 0, Longint(Self)); -end; - -procedure TControl.ChangeScale(M, D: Integer); -var - X, Y, W, H: Integer; - Flags: TScalingFlags; -begin - if M <> D then - begin - if csLoading in ComponentState then - Flags := ScalingFlags else - Flags := [sfLeft, sfTop, sfWidth, sfHeight, sfFont]; - if sfLeft in Flags then - X := MulDiv(FLeft, M, D) else - X := FLeft; - if sfTop in Flags then - Y := MulDiv(FTop, M, D) else - Y := FTop; - if (sfWidth in Flags) and not (csFixedWidth in ControlStyle) then - if sfLeft in Flags then - W := MulDiv(FLeft + FWidth, M, D) - X else - W := MulDiv(FWidth, M, D) - else W := FWidth; - if (sfHeight in Flags) and not (csFixedHeight in ControlStyle) then - if sfHeight in Flags then - H := MulDiv(FTop + FHeight, M, D) - Y else - H := MulDiv(FTop, M, D ) - else H := FHeight; - SetBounds(X, Y, W, H); - if not ParentFont and (sfFont in Flags) then - Font.Size := MulDiv(Font.Size, M, D); - end; - FScalingFlags := []; -end; - -procedure TControl.SetAutoSize(Value: Boolean); -begin - if FAutoSize <> Value then - begin - FAutoSize := Value; - if Value then AdjustSize; - end; -end; - -procedure TControl.SetName(const Value: TComponentName); -var - ChangeText: Boolean; -begin - ChangeText := (csSetCaption in ControlStyle) and (Name = Text) and - ((Owner = nil) or not (Owner is TControl) or - not (csLoading in TControl(Owner).ComponentState)); - inherited SetName(Value); - if ChangeText then Text := Value; -end; - -procedure TControl.SetClientSize(Value: TPoint); -var - Client: TRect; -begin - Client := GetClientRect; - SetBounds(FLeft, FTop, Width - Client.Right + Value.X, Height - - Client.Bottom + Value.Y); -end; - -procedure TControl.SetParent(AParent: TWinControl); -begin - if FParent <> AParent then - begin - if Parent = Self then - raise EInvalidOperation.Create(SControlParentSetToSelf); - if FParent <> nil then FParent.RemoveControl(Self); - if AParent <> nil then AParent.InsertControl(Self); - end; -end; - -procedure TControl.SetVisible(Value: Boolean); -begin - if FVisible <> Value then - begin - VisibleChanging; - FVisible := Value; - Perform(CM_VISIBLECHANGED, Ord(Value), 0); - RequestAlign; - end; -end; - -procedure TControl.SetEnabled(Value: Boolean); -begin - if FEnabled <> Value then - begin - FEnabled := Value; - Perform(CM_ENABLEDCHANGED, 0, 0); - end; -end; - -function TControl.GetTextLen: Integer; -begin - Result := Perform(WM_GETTEXTLENGTH, 0, 0); -end; - -function TControl.GetTextBuf(Buffer: PChar; BufSize: Integer): Integer; -begin - Result := Perform(WM_GETTEXT, BufSize, Longint(Buffer)); -end; - -function TControl.GetUndockHeight: Integer; -begin - if FUndockHeight > 0 then Result := FUndockHeight - else Result := Height; -end; - -function TControl.GetUndockWidth: Integer; -begin - if FUndockWidth > 0 then Result := FUndockWidth - else Result := Width; -end; - -function TControl.GetTBDockHeight: Integer; -begin - if FTBDockHeight > 0 then Result := FTBDockHeight - else Result := UndockHeight; -end; - -function TControl.GetLRDockWidth: Integer; -begin - if FLRDockWidth > 0 then Result := FLRDockWidth - else Result := UndockWidth; -end; - -procedure TControl.SetPopupMenu(Value: TPopupMenu); -begin - FPopupMenu := Value; - if Value <> nil then - begin - Value.ParentBiDiModeChanged(Self); - Value.FreeNotification(Self); - end; -end; - -procedure TControl.SetTextBuf(Buffer: PChar); -begin - Perform(WM_SETTEXT, 0, Longint(Buffer)); - Perform(CM_TEXTCHANGED, 0, 0); -end; - -function TControl.GetText: TCaption; -var - Len: Integer; -begin - Len := GetTextLen; - SetString(Result, PChar(nil), Len); - if Len <> 0 then GetTextBuf(Pointer(Result), Len + 1); -end; - -procedure TControl.SetText(const Value: TCaption); -begin - if GetText <> Value then SetTextBuf(PChar(Value)); -end; - -procedure TControl.SetBiDiMode(Value: TBiDiMode); -begin - if FBiDiMode <> Value then - begin - FBiDiMode := Value; - FParentBiDiMode := False; - Perform(CM_BIDIMODECHANGED, 0, 0); - end; -end; - -procedure TControl.FontChanged(Sender: TObject); -begin - FParentFont := False; - FDesktopFont := False; - if Font.Height <> FFontHeight then - begin - Include(FScalingFlags, sfFont); - FFontHeight := Font.Height; - end; - Perform(CM_FONTCHANGED, 0, 0); -end; - -procedure TControl.SetFont(Value: TFont); -begin - FFont.Assign(Value); -end; - -function TControl.IsFontStored: Boolean; -begin - Result := not ParentFont and not DesktopFont; -end; - -function TControl.IsShowHintStored: Boolean; -begin - Result := not ParentShowHint; -end; - -function TControl.IsBiDiModeStored: Boolean; -begin - Result := not ParentBiDiMode; -end; - -procedure TControl.SetParentFont(Value: Boolean); -begin - if FParentFont <> Value then - begin - FParentFont := Value; - if FParent <> nil then Perform(CM_PARENTFONTCHANGED, 0, 0); - end; -end; - -procedure TControl.SetDesktopFont(Value: Boolean); -begin - if FDesktopFont <> Value then - begin - FDesktopFont := Value; - Perform(CM_SYSFONTCHANGED, 0, 0); - end; -end; - -procedure TControl.SetShowHint(Value: Boolean); -begin - if FShowHint <> Value then - begin - FShowHint := Value; - FParentShowHint := False; - Perform(CM_SHOWHINTCHANGED, 0, 0); - end; -end; - -procedure TControl.SetParentShowHint(Value: Boolean); -begin - if FParentShowHint <> Value then - begin - FParentShowHint := Value; - if FParent <> nil then Perform(CM_PARENTSHOWHINTCHANGED, 0, 0); - end; -end; - -procedure TControl.SetColor(Value: TColor); -begin - if FColor <> Value then - begin - FColor := Value; - FParentColor := False; - Perform(CM_COLORCHANGED, 0, 0); - end; -end; - -function TControl.IsColorStored: Boolean; -begin - Result := not ParentColor; -end; - -procedure TControl.SetParentColor(Value: Boolean); -begin - if FParentColor <> Value then - begin - FParentColor := Value; - if FParent <> nil then Perform(CM_PARENTCOLORCHANGED, 0, 0); - end; -end; - -procedure TControl.SetParentBiDiMode(Value: Boolean); -begin - if FParentBiDiMode <> Value then - begin - FParentBiDiMode := Value; - if FParent <> nil then Perform(CM_PARENTBIDIMODECHANGED, 0, 0); - end; -end; - -procedure TControl.SetCursor(Value: TCursor); -begin - if FCursor <> Value then - begin - FCursor := Value; - Perform(CM_CURSORCHANGED, 0, 0); - end; -end; - -function TControl.GetMouseCapture: Boolean; -begin - Result := GetCaptureControl = Self; -end; - -procedure TControl.SetMouseCapture(Value: Boolean); -begin - if MouseCapture <> Value then - if Value then SetCaptureControl(Self) else SetCaptureControl(nil); -end; - -procedure TControl.BringToFront; -begin - SetZOrder(True); -end; - -procedure TControl.SendToBack; -begin - SetZOrder(False); -end; - -procedure TControl.SetZOrderPosition(Position: Integer); -var - I, Count: Integer; - ParentForm: TCustomForm; -begin - if FParent <> nil then - begin - I := FParent.FControls.IndexOf(Self); - if I >= 0 then - begin - Count := FParent.FControls.Count; - if Position < 0 then Position := 0; - if Position >= Count then Position := Count - 1; - if Position <> I then - begin - FParent.FControls.Delete(I); - FParent.FControls.Insert(Position, Self); - InvalidateControl(Visible, True); - ParentForm := ValidParentForm(Self); - if csPalette in ParentForm.ControlState then - TControl(ParentForm).PaletteChanged(True); - end; - end; - end; -end; - -procedure TControl.SetZOrder(TopMost: Boolean); -begin - if FParent <> nil then - if TopMost then - SetZOrderPosition(FParent.FControls.Count - 1) else - SetZOrderPosition(0); -end; - -function TControl.GetDeviceContext(var WindowHandle: HWnd): HDC; -begin - if Parent = nil then - raise EInvalidOperation.CreateFmt(SParentRequired, [Name]); - Result := Parent.GetDeviceContext(WindowHandle); - SetViewportOrgEx(Result, Left, Top, nil); - IntersectClipRect(Result, 0, 0, Width, Height); -end; - -procedure TControl.InvalidateControl(IsVisible, IsOpaque: Boolean); -var - Rect: TRect; - - function BackgroundClipped: Boolean; - var - R: TRect; - List: TList; - I: Integer; - C: TControl; - begin - Result := True; - List := FParent.FControls; - I := List.IndexOf(Self); - while I > 0 do - begin - Dec(I); - C := List[I]; - with C do - if C.Visible and (csOpaque in ControlStyle) then - begin - IntersectRect(R, Rect, BoundsRect); - if EqualRect(R, Rect) then Exit; - end; - end; - Result := False; - end; - -begin - if (IsVisible or (csDesigning in ComponentState) and - not (csNoDesignVisible in ControlStyle)) and (Parent <> nil) and - Parent.HandleAllocated then - begin - Rect := BoundsRect; - InvalidateRect(Parent.Handle, @Rect, not (IsOpaque or - (csOpaque in Parent.ControlStyle) or BackgroundClipped)); - end; -end; - -procedure TControl.Invalidate; -begin - InvalidateControl(Visible, csOpaque in ControlStyle); -end; - -procedure TControl.Hide; -begin - Visible := False; -end; - -procedure TControl.Show; -begin - if Parent <> nil then Parent.ShowControl(Self); - if not (csDesigning in ComponentState) or - (csNoDesignVisible in ControlStyle) then Visible := True; -end; - -procedure TControl.Update; -begin - if Parent <> nil then Parent.Update; -end; - -procedure TControl.Refresh; -begin - Repaint; -end; - -function TControl.GetControlsAlignment: TAlignment; -begin - Result := taLeftJustify; -end; - -function TControl.IsRightToLeft: Boolean; -begin - Result := SysLocale.MiddleEast and (BiDiMode <> bdLeftToRight); -end; - -function TControl.UseRightToLeftReading: Boolean; -begin - Result := SysLocale.MiddleEast and (BiDiMode <> bdLeftToRight); -end; - -function TControl.UseRightToLeftAlignment: Boolean; -begin - Result := SysLocale.MiddleEast and (BiDiMode = bdRightToLeft); -end; - -function TControl.UseRightToLeftScrollBar: Boolean; -begin - Result := SysLocale.MiddleEast and - (BiDiMode in [bdRightToLeft, bdRightToLeftNoAlign]); -end; - -procedure TControl.BeginAutoDrag; -begin - BeginDrag(Mouse.DragImmediate, Mouse.DragThreshold); -end; - -procedure TControl.BeginDrag(Immediate: Boolean; Threshold: Integer); -var - P: TPoint; -begin - if (Self is TCustomForm) and (FDragKind <> dkDock) then - raise EInvalidOperation.Create(SCannotDragForm); - CalcDockSizes; - if (DragControl = nil) or (DragControl = Pointer($FFFFFFFF)) then - begin - DragControl := nil; - if csLButtonDown in ControlState then - begin - GetCursorPos(P); - P := ScreenToClient(P); - Perform(WM_LBUTTONUP, 0, Longint(PointToSmallPoint(P))); - end; - { Use default value when Threshold < 0 } - if Threshold < 0 then - Threshold := Mouse.DragThreshold; - // prevent calling EndDrag within BeginDrag - if DragControl <> Pointer($FFFFFFFF) then - DragInitControl(Self, Immediate, Threshold); - end; -end; - -procedure TControl.EndDrag(Drop: Boolean); -begin - if Dragging then DragDone(Drop) - // prevent calling EndDrag within BeginDrag - else if DragControl = nil then DragControl := Pointer($FFFFFFFF); -end; - -procedure TControl.DragCanceled; -begin -end; - -function TControl.Dragging: Boolean; -begin - Result := DragControl = Self; -end; - -procedure TControl.DragOver(Source: TObject; X, Y: Integer; - State: TDragState; var Accept: Boolean); -begin - Accept := False; - if Assigned(FOnDragOver) then - begin - Accept := True; - FOnDragOver(Self, Source, X, Y, State, Accept); - end; -end; - -procedure TControl.DragDrop(Source: TObject; X, Y: Integer); -begin - if Assigned(FOnDragDrop) then FOnDragDrop(Self, Source, X, Y); -end; - -procedure TControl.DoStartDrag(var DragObject: TDragObject); -begin - if Assigned(FOnStartDrag) then FOnStartDrag(Self, DragObject); -end; - -procedure TControl.DoEndDrag(Target: TObject; X, Y: Integer); -begin - if Assigned(FOnEndDrag) then FOnEndDrag(Self, Target, X, Y); -end; - -procedure TControl.PositionDockRect(DragDockObject: TDragDockObject); -var - NewWidth, NewHeight: Integer; - TempX, TempY: Double; -begin - with DragDockObject do - begin - if (DragTarget = nil) or (not TWinControl(DragTarget).UseDockManager) then - begin - NewWidth := Control.UndockWidth; - NewHeight := Control.UndockHeight; - // Drag position for dock rect is scaled relative to control's click point. - TempX := DragPos.X - ((NewWidth) * FMouseDeltaX); - TempY := DragPos.Y - ((NewHeight) * FMouseDeltaY); - with FDockRect do - begin - Left := Round(TempX); - Top := Round(TempY); - Right := Left + NewWidth; - Bottom := Top + NewHeight; - end; - { Allow DragDockObject final say on this new dock rect } - AdjustDockRect(FDockRect); - end - else begin - GetWindowRect(TWinControl(DragTarget).Handle, FDockRect); - if TWinControl(DragTarget).UseDockManager and - (TWinControl(DragTarget).DockManager <> nil) then - TWinControl(DragTarget).DockManager.PositionDockRect(Control, - DropOnControl, DropAlign, FDockRect); - end; - end; -end; - -procedure TControl.DockTrackNoTarget(Source: TDragDockObject; X, Y: Integer); -begin - PositionDockRect(Source); -end; - -procedure TControl.DoEndDock(Target: TObject; X, Y: Integer); -begin - if Assigned(FOnEndDock) then FOnEndDock(Self, Target, X, Y); -end; - -procedure TControl.DoStartDock(var DragObject: TDragObject); -begin - if Assigned(FOnStartDock) then FOnStartDock(Self, TDragDockObject(DragObject)); -end; - -procedure TControl.DefaultDockImage(DragDockObject: TDragDockObject; - Erase: Boolean); -var - DesktopWindow: HWND; - DC: HDC; - OldBrush: HBrush; - DrawRect: TRect; - PenSize: Integer; -begin - with DragDockObject do - begin - PenSize := FrameWidth; - if Erase then DrawRect := FEraseDockRect - else DrawRect := FDockRect; - end; - DesktopWindow := GetDesktopWindow; - DC := GetDCEx(DesktopWindow, 0, DCX_CACHE or DCX_LOCKWINDOWUPDATE); - try - OldBrush := SelectObject(DC, DragDockObject.Brush.Handle); - with DrawRect do - begin - PatBlt(DC, Left + PenSize, Top, Right - Left - PenSize, PenSize, PATINVERT); - PatBlt(DC, Right - PenSize, Top + PenSize, PenSize, Bottom - Top - PenSize, PATINVERT); - PatBlt(DC, Left, Bottom - PenSize, Right - Left - PenSize, PenSize, PATINVERT); - PatBlt(DC, Left, Top, PenSize, Bottom - Top - PenSize, PATINVERT); - end; - SelectObject(DC, OldBrush); - finally - ReleaseDC(DesktopWindow, DC); - end; -end; - -procedure TControl.DrawDragDockImage(DragDockObject: TDragDockObject); -begin - DefaultDockImage(DragDockObject, False); -end; - -procedure TControl.EraseDragDockImage(DragDockObject: TDragDockObject); -begin - DefaultDockImage(DragDockObject, True); -end; - -procedure TControl.DoDragMsg(var DragMsg: TCMDrag); -var - S: TObject; - Accepts, IsDockOp: Boolean; -begin - with DragMsg, DragRec^ do - begin - S := Source; - IsDockOp := S is TDragDockObject; - if DragFreeObject and not IsDockOp then - S := (S as TDragControlObject).Control; - with ScreenToClient(Pos) do - case DragMessage of - dmDragEnter, dmDragLeave, dmDragMove: - begin - Accepts := True; - if IsDockOp then - begin - TWinControl(Target).DockOver(TDragDockObject(S), X, Y, - TDragState(DragMessage), Accepts) - end - else - DragOver(S, X, Y, TDragState(DragMessage), Accepts); - Result := Ord(Accepts); - end; - dmDragDrop: - begin - if IsDockOp then TWinControl(Target).DockDrop(TDragDockObject(S), X, Y) - else DragDrop(S, X, Y); - end; - end; - end; -end; - -function TControl.ManualDock(NewDockSite: TWinControl; DropControl: TControl; - ControlSide: TAlign): Boolean; -var - R: TRect; - DockObject: TDragDockObject; - HostDockSiteHandle: THandle; -begin - if (NewDockSite = nil) or (NewDockSite = NullDockSite) then - begin - if (HostDockSite <> nil) and HostDockSite.UseDockManager and - (HostDockSite.DockManager <> nil) then - begin - HostDockSite.DockManager.GetControlBounds(Self, R); - MapWindowPoints(HostDockSite.Handle, 0, R.TopLeft, 2); - end - else begin - R.TopLeft := Point(Left, Top); - if Parent <> nil then R.TopLeft := Parent.ClientToScreen(R.TopLeft); - end; - R := Bounds(R.Left, R.Top, UndockWidth, UndockHeight); - Result := ManualFloat(R); - end - else - begin - CalcDockSizes; - Result := (HostDockSite = nil) or HostDockSite.DoUndock(NewDockSite, Self); - if Result then - begin - DockObject := TDragDockObject.Create(Self); - try - if HostDockSite <> nil then - HostDockSiteHandle := HostDockSite.Handle else - HostDockSiteHandle := 0; - R := BoundsRect; - if HostDockSiteHandle <> 0 then - MapWindowPoints(HostDockSiteHandle, 0, R, 2); - with DockObject do - begin - FDragTarget := NewDockSite; - FDropAlign := ControlSide; - FDropOnControl := DropControl; - DockRect := R; - end; - MapWindowPoints(0, NewDockSite.Handle, R.TopLeft, 1); - NewDockSite.DockDrop(DockObject, R.Left, R.Top); - finally - DockObject.Free; - end; - end; - end; -end; - -function TControl.ManualFloat(ScreenPos: TRect): Boolean; -var - FloatHost: TWinControl; -begin - Result := (HostDockSite = nil) or HostDockSite.DoUndock(nil, Self); - if Result then - begin - FloatHost := CreateFloatingDockSite(ScreenPos); - if FloatHost <> nil then - Dock(FloatHost, Rect(0, 0, FloatHost.ClientWidth, FloatHost.ClientHeight)) - else - Dock(FloatHost, ScreenPos); - end; -end; - -function TControl.ReplaceDockedControl(Control: TControl; - NewDockSite: TWinControl; DropControl: TControl; ControlSide: TAlign): Boolean; -var - OldDockSite: TWinControl; -begin - Result := False; - if (Control.HostDockSite = nil) or ((Control.HostDockSite.UseDockManager) and - (Control.HostDockSite.DockManager <> nil)) then - begin - OldDockSite := Control.HostDockSite; - if OldDockSite <> nil then - OldDockSite.DockManager.SetReplacingControl(Control); - try - ManualDock(OldDockSite, nil, alTop); - finally - if OldDockSite <> nil then - OldDockSite.DockManager.SetReplacingControl(nil); - end; - if Control.ManualDock(NewDockSite, DropControl, ControlSide) then - Result := True; - end; -end; - -procedure TControl.DoConstraintsChange(Sender: TObject); -begin - AdjustSize; -end; - -function TControl.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; -begin - Result := True; -end; - -function TControl.CanResize(var NewWidth, NewHeight: Integer): Boolean; -begin - Result := True; - if Assigned(FOnCanResize) then FOnCanResize(Self, NewWidth, NewHeight, Result); -end; - -function TControl.DoCanAutoSize(var NewWidth, NewHeight: Integer): Boolean; -var - W, H: Integer; -begin - if Align <> alClient then - begin - W := NewWidth; - H := NewHeight; - Result := CanAutoSize(W, H); - if Align in [alNone, alLeft, alRight] then - NewWidth := W; - if Align in [alNone, alTop, alBottom] then - NewHeight := H; - end - else Result := True; -end; - -function TControl.DoCanResize(var NewWidth, NewHeight: Integer): Boolean; -begin - Result := CanResize(NewWidth, NewHeight); - if Result then DoConstrainedResize(NewWidth, NewHeight); -end; - -procedure TControl.ConstrainedResize(var MinWidth, MinHeight, MaxWidth, - MaxHeight: Integer); -begin - if Assigned(FOnConstrainedResize) then FOnConstrainedResize(Self, MinWidth, - MinHeight, MaxWidth, MaxHeight); -end; - -procedure TControl.DoConstrainedResize(var NewWidth, NewHeight: Integer); -var - MinWidth, MinHeight, MaxWidth, MaxHeight: Integer; -begin - if Constraints.MinWidth > 0 then - MinWidth := Constraints.MinWidth - else - MinWidth := 0; - if Constraints.MinHeight > 0 then - MinHeight := Constraints.MinHeight - else - MinHeight := 0; - if Constraints.MaxWidth > 0 then - MaxWidth := Constraints.MaxWidth - else - MaxWidth := 0; - if Constraints.MaxHeight > 0 then - MaxHeight := Constraints.MaxHeight - else - MaxHeight := 0; - { Allow override of constraints } - ConstrainedResize(MinWidth, MinHeight, MaxWidth, MaxHeight); - if (MaxWidth > 0) and (NewWidth > MaxWidth) then - NewWidth := MaxWidth - else if (MinWidth > 0) and (NewWidth < MinWidth) then - NewWidth := MinWidth; - if (MaxHeight > 0) and (NewHeight > MaxHeight) then - NewHeight := MaxHeight - else if (MinHeight > 0) and (NewHeight < MinHeight) then - NewHeight := MinHeight; -end; - -function TControl.Perform(Msg: Cardinal; WParam, LParam: Longint): Longint; -var - Message: TMessage; -begin - Message.Msg := Msg; - Message.WParam := WParam; - Message.LParam := LParam; - Message.Result := 0; - if Self <> nil then WindowProc(Message); - Result := Message.Result; -end; - -procedure TControl.CalcDockSizes; -begin - if Floating then - begin - UndockHeight := Height; - UndockWidth := Width; - end - else if HostDockSite <> nil then - begin - if (DockOrientation = doVertical) or - (HostDockSite.Align in [alTop, alBottom]) then - TBDockHeight := Height - else if (DockOrientation = doHorizontal) or - (HostDockSite.Align in [alLeft, alRight]) then - LRDockWidth := Width; - end; -end; - -procedure TControl.UpdateBoundsRect(const R: TRect); -begin - UpdateLastResize(R.Right - R.Left, R.Bottom - R.Top); - FLeft := R.Left; - FTop := R.Top; - FWidth := R.Right - R.Left; - FHeight := R.Bottom - R.Top; -end; - -procedure TControl.VisibleChanging; -begin -end; - -procedure TControl.WndProc(var Message: TMessage); -var - Form: TCustomForm; -begin - if (csDesigning in ComponentState) then - begin - Form := GetParentForm(Self); - if (Form <> nil) and (Form.Designer <> nil) and - Form.Designer.IsDesignMsg(Self, Message) then Exit; - end - else if (Message.Msg >= WM_KEYFIRST) and (Message.Msg <= WM_KEYLAST) then - begin - Form := GetParentForm(Self); - if (Form <> nil) and Form.WantChildKey(Self, Message) then Exit; - end - else if (Message.Msg >= WM_MOUSEFIRST) and (Message.Msg <= WM_MOUSELAST) then - begin - if not (csDoubleClicks in ControlStyle) then - case Message.Msg of - WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK, WM_MBUTTONDBLCLK: - Dec(Message.Msg, WM_LBUTTONDBLCLK - WM_LBUTTONDOWN); - end; - case Message.Msg of - WM_MOUSEMOVE: Application.HintMouseMessage(Self, Message); - WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: - begin - if FDragMode = dmAutomatic then - begin - BeginAutoDrag; - Exit; - end; - Include(FControlState, csLButtonDown); - end; - WM_LBUTTONUP: - Exclude(FControlState, csLButtonDown); - end; - end - else if Message.Msg = CM_VISIBLECHANGED then - with Message do - SendDockNotification(Msg, WParam, LParam); - Dispatch(Message); -end; - -procedure TControl.DefaultHandler(var Message); -var - P: PChar; -begin - with TMessage(Message) do - case Msg of - WM_GETTEXT: - begin - if FText <> nil then P := FText else P := ''; - Result := StrLen(StrLCopy(PChar(LParam), P, WParam - 1)); - end; - WM_GETTEXTLENGTH: - if FText = nil then Result := 0 else Result := StrLen(FText); - WM_SETTEXT: - begin - P := StrNew(PChar(LParam)); - StrDispose(FText); - FText := P; - SendDockNotification(Msg, WParam, LParam); - end; - end; -end; - -procedure TControl.ReadIsControl(Reader: TReader); -begin - FIsControl := Reader.ReadBoolean; -end; - -procedure TControl.WriteIsControl(Writer: TWriter); -begin - Writer.WriteBoolean(FIsControl); -end; - -procedure TControl.DefineProperties(Filer: TFiler); - - function DoWrite: Boolean; - begin - if Filer.Ancestor <> nil then - Result := TControl(Filer.Ancestor).IsControl <> IsControl else - Result := IsControl; - end; - -begin - { The call to inherited DefinedProperties is omitted since the Left and - Top special properties are redefined with real properties } - Filer.DefineProperty('IsControl', ReadIsControl, WriteIsControl, DoWrite); -end; - -procedure TControl.Click; -begin - { Call OnClick if assigned and not equal to associated action's OnExecute. - If associated action's OnExecute assigned then call it, otherwise, call - OnClick. } - if Assigned(FOnClick) and (Action <> nil) and (@FOnClick <> @Action.OnExecute) then - FOnClick(Self) - else if not (csDesigning in ComponentState) and (ActionLink <> nil) then - ActionLink.Execute - else if Assigned(FOnClick) then - FOnClick(Self); -end; - -procedure TControl.DblClick; -begin - if Assigned(FOnDblClick) then FOnDblClick(Self); -end; - -procedure TControl.MouseDown(Button: TMouseButton; - Shift: TShiftState; X, Y: Integer); -begin - if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y); -end; - -procedure TControl.DoMouseDown(var Message: TWMMouse; Button: TMouseButton; - Shift: TShiftState); -begin - if not (csNoStdEvents in ControlStyle) then - with Message do - MouseDown(Button, KeysToShiftState(Keys) + Shift, XPos, YPos); -end; - -procedure TControl.WMLButtonDown(var Message: TWMLButtonDown); -begin - SendCancelMode(Self); - inherited; - if csCaptureMouse in ControlStyle then MouseCapture := True; - if csClickEvents in ControlStyle then Include(FControlState, csClicked); - DoMouseDown(Message, mbLeft, []); -end; - -procedure TControl.WMNCLButtonDown(var Message: TWMNCLButtonDown); -begin - SendCancelMode(Self); - inherited; -end; - -procedure TControl.WMLButtonDblClk(var Message: TWMLButtonDblClk); -begin - SendCancelMode(Self); - inherited; - if csCaptureMouse in ControlStyle then MouseCapture := True; - if csClickEvents in ControlStyle then DblClick; - DoMouseDown(Message, mbLeft, [ssDouble]); -end; - -function TControl.GetPopupMenu: TPopupMenu; -begin - Result := FPopupMenu; -end; - -procedure TControl.CheckMenuPopup(const Pos: TSmallPoint); -var - Control: TControl; - PopupMenu: TPopupMenu; -begin - if csDesigning in ComponentState then Exit; - Control := Self; - while Control <> nil do - begin - PopupMenu := Control.GetPopupMenu; - if (PopupMenu <> nil) then - begin - if not PopupMenu.AutoPopup then Exit; - SendCancelMode(nil); - PopupMenu.PopupComponent := Control; - with ClientToScreen(SmallPointToPoint(Pos)) do - PopupMenu.Popup(X, Y); - Exit; - end; - Control := Control.Parent; - end; -end; - -function TControl.CheckNewSize(var NewWidth, NewHeight: Integer): Boolean; -var - W, H, W2, H2: Integer; -begin - Result := False; - W := NewWidth; - H := NewHeight; - if DoCanResize(W, H) then - begin - W2 := W; - H2 := H; - Result := not AutoSize or (DoCanAutoSize(W2, H2) and (W2 = W) and (H2 = H)) or - DoCanResize(W2, H2); - if Result then - begin - NewWidth := W2; - NewHeight := H2; - end; - end; -end; - -procedure TControl.WMRButtonDown(var Message: TWMRButtonDown); -begin - inherited; - DoMouseDown(Message, mbRight, []); -end; - -procedure TControl.WMRButtonDblClk(var Message: TWMRButtonDblClk); -begin - inherited; - DoMouseDown(Message, mbRight, [ssDouble]); -end; - -procedure TControl.WMMButtonDown(var Message: TWMMButtonDown); -begin - inherited; - DoMouseDown(Message, mbMiddle, []); -end; - -procedure TControl.WMMButtonDblClk(var Message: TWMMButtonDblClk); -begin - inherited; - DoMouseDown(Message, mbMiddle, [ssDouble]); -end; - -procedure TControl.MouseMove(Shift: TShiftState; X, Y: Integer); -begin - if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y); -end; - -procedure TControl.WMMouseMove(var Message: TWMMouseMove); -begin - inherited; - if not (csNoStdEvents in ControlStyle) then - with Message do MouseMove(KeysToShiftState(Keys), XPos, YPos); -end; - -procedure TControl.MouseUp(Button: TMouseButton; - Shift: TShiftState; X, Y: Integer); -begin - if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y); -end; - -procedure TControl.DoMouseUp(var Message: TWMMouse; Button: TMouseButton); -begin - if not (csNoStdEvents in ControlStyle) then - with Message do MouseUp(Button, KeysToShiftState(Keys), XPos, YPos); -end; - -procedure TControl.WMLButtonUp(var Message: TWMLButtonUp); -begin - inherited; - if csCaptureMouse in ControlStyle then MouseCapture := False; - if csClicked in ControlState then - begin - Exclude(FControlState, csClicked); - if PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then Click; - end; - DoMouseUp(Message, mbLeft); -end; - -procedure TControl.WMRButtonUp(var Message: TWMRButtonUp); -begin - inherited; - DoMouseUp(Message, mbRight); - if Message.Result = 0 then CheckMenuPopup(Message.Pos); -end; - -procedure TControl.WMMButtonUp(var Message: TWMMButtonUp); -begin - inherited; - DoMouseUp(Message, mbMiddle); -end; - -procedure TControl.WMCancelMode(var Message: TWMCancelMode); -begin - inherited; - if MouseCapture then - begin - MouseCapture := False; - if csLButtonDown in ControlState then Perform(WM_LBUTTONUP, 0, - Integer($FFFFFFFF)); - end - else - Exclude(FControlState, csLButtonDown); -end; - -procedure TControl.WMWindowPosChanged(var Message: TWMWindowPosChanged); -begin - inherited; - { Update min/max width/height to actual extents control will allow } - if ComponentState * [csReading, csLoading] = [] then - begin - with Constraints do - begin - if (MaxWidth > 0) and (Width > MaxWidth) then - FMaxWidth := Width - else if (MinWidth > 0) and (Width < MinWidth) then - FMinWidth := Width; - if (MaxHeight > 0) and (Height > MaxHeight) then - FMaxHeight := Height - else if (MinHeight > 0) and (Height < MinHeight) then - FMinHeight := Height; - end; - if Message.WindowPos <> nil then - with Message.WindowPos^ do - if (FHostDockSite <> nil) and not (csDocking in ControlState) and - (Flags and SWP_NOSIZE = 0) and (cx <> 0) and (cy <> 0) then - CalcDockSizes; - end; -end; - -procedure TControl.CMVisibleChanged(var Message: TMessage); -begin - if not (csDesigning in ComponentState) or - (csNoDesignVisible in ControlStyle) then - InvalidateControl(True, FVisible and (csOpaque in ControlStyle)); -end; - -procedure TControl.CMEnabledChanged(var Message: TMessage); -begin - Invalidate; -end; - -procedure TControl.CMFontChanged(var Message: TMessage); -begin - Invalidate; -end; - -procedure TControl.CMColorChanged(var Message: TMessage); -begin - Invalidate; -end; - -procedure TControl.CMParentColorChanged(var Message: TMessage); -begin - if FParentColor then - begin - if Message.wParam <> 0 then - SetColor(TColor(Message.lParam)) else - SetColor(FParent.FColor); - FParentColor := True; - end; -end; - -procedure TControl.CMParentBiDiModeChanged(var Message: TMessage); -begin - if FParentBiDiMode then - begin - if FParent <> nil then BiDiMode := FParent.BiDiMode; - FParentBiDiMode := True; - end; -end; - -procedure TControl.CMBiDiModeChanged(var Message: TMessage); -begin - if (SysLocale.MiddleEast) and (Message.wParam = 0) then Invalidate; -end; - -procedure TControl.CMParentShowHintChanged(var Message: TMessage); -begin - if FParentShowHint then - begin - SetShowHint(FParent.FShowHint); - FParentShowHint := True; - end; -end; - -procedure TControl.CMParentFontChanged(var Message: TMessage); -begin - if FParentFont then - begin - if Message.wParam <> 0 then - SetFont(TFont(Message.lParam)) else - SetFont(FParent.FFont); - FParentFont := True; - end; -end; - -procedure TControl.CMSysFontChanged(var Message: TMessage); -begin - if FDesktopFont then - begin - SetFont(Screen.IconFont); - FDesktopFont := True; - end; -end; - -procedure TControl.CMHitTest(var Message: TCMHitTest); -begin - Message.Result := 1; -end; - -procedure TControl.CMMouseEnter(var Message: TMessage); -begin - if FParent <> nil then - FParent.Perform(CM_MOUSEENTER, 0, Longint(Self)); -end; - -procedure TControl.CMMouseLeave(var Message: TMessage); -begin - if FParent <> nil then - FParent.Perform(CM_MOUSELEAVE, 0, Longint(Self)); -end; - -procedure TControl.CMDesignHitTest(var Message: TCMDesignHitTest); -begin - Message.Result := 0; -end; - -function TControl.CreateFloatingDockSite(Bounds: TRect): TWinControl; -begin - Result := nil; - if (FloatingDockSiteClass <> nil) and - (FloatingDockSiteClass <> TWinControlClass(ClassType)) then - begin - Result := FloatingDockSiteClass.Create(Application); - with Bounds do - begin - Result.Top := Top; - Result.Left := Left; - Result.ClientWidth := Right - Left; - Result.ClientHeight := Bottom - Top; - end; - end; -end; - -procedure TControl.CMFloat(var Message: TCMFloat); -var - FloatHost: TWinControl; - - procedure UpdateFloatingDockSitePos; - var - P: TPoint; - begin - P := Parent.ClientToScreen(Point(Left, Top)); - with Message.DockSource.DockRect do - Parent.BoundsRect := Bounds(Left + Parent.Left - P.X, - Top + Parent.Top - P.Y, - Right - Left + Parent.Width - Width, - Bottom - Top + Parent.Height - Height); - end; - -begin - if Floating and (Parent <> nil) then - UpdateFloatingDockSitePos - else - begin - FloatHost := CreateFloatingDockSite(Message.DockSource.DockRect); - if FloatHost <> nil then - begin - Message.DockSource.DragTarget := FloatHost; - Message.DockSource.DragHandle := FloatHost.Handle; - end; - end; -end; - -procedure TControl.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - if Sender is TCustomAction then - with TCustomAction(Sender) do - begin - if not CheckDefaults or (Self.Caption = '') then - Self.Caption := Caption; - if not CheckDefaults or (Self.Enabled = True) then - Self.Enabled := Enabled; - if not CheckDefaults or (Self.Hint = '') then - Self.Hint := Hint; - if not CheckDefaults or (Self.Visible = True) then - Self.Visible := Visible; - if not CheckDefaults or not Assigned(Self.OnClick) then - Self.OnClick := OnExecute; - end; -end; - -procedure TControl.DoActionChange(Sender: TObject); -begin - if Sender = Action then ActionChange(Sender, False); -end; - -function TControl.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TControlActionLink; -end; - -function TControl.IsCaptionStored: Boolean; -begin - Result := (ActionLink = nil) or not ActionLink.IsCaptionLinked; -end; - -function TControl.IsEnabledStored: Boolean; -begin - Result := (ActionLink = nil) or not ActionLink.IsEnabledLinked; -end; - -function TControl.IsHintStored: Boolean; -begin - Result := (ActionLink = nil) or not ActionLink.IsHintLinked; -end; - -function TControl.IsVisibleStored: Boolean; -begin - Result := (ActionLink = nil) or not ActionLink.IsVisibleLinked; -end; - -function TControl.IsOnClickStored: Boolean; -begin - Result := (ActionLink = nil) or not ActionLink.IsOnExecuteLinked; -end; - -procedure TControl.Loaded; -begin - inherited Loaded; - if Action <> nil then ActionChange(Action, True); -end; - -procedure TControl.AssignTo(Dest: TPersistent); -begin - if Dest is TCustomAction then - with TCustomAction(Dest) do - begin - Enabled := Self.Enabled; - Hint := Self.Hint; - Caption := Self.Caption; - Visible := Self.Visible; - OnExecute := Self.OnClick; - end - else inherited AssignTo(Dest); -end; - -function TControl.GetDockEdge(MousePos: TPoint): TAlign; - - function MinVar(const Data: array of Double): Integer; - var - I: Integer; - begin - Result := 0; - for I := Low(Data) + 1 to High(Data) do - if Data[I] < Data[Result] then Result := I; - end; - -var - T, L, B, R: Integer; -begin - Result := alNone; - R := Width; - B := Height; - // if Point is outside control, then we can determine side quickly - if MousePos.X <= 0 then Result := alLeft - else if MousePos.X >= R then Result := alRight - else if MousePos.Y <= 0 then Result := alTop - else if MousePos.Y >= B then Result := alBottom - else begin - // if MousePos is inside the control, then we need to figure out which side - // MousePos is closest to. - T := MousePos.Y; - B := B - MousePos.Y; - L := MousePos.X; - R := R - MousePos.X; - case MinVar([L, R, T, B]) of - 0: Result := alLeft; - 1: Result := alRight; - 2: Result := alTop; - 3: Result := alBottom; - end; - end; -end; - -function TControl.GetFloating: Boolean; -begin - Result := (HostDockSite <> nil) and (HostDockSite is FloatingDockSiteClass); -end; - -function TControl.GetFloatingDockSiteClass: TWinControlClass; -begin - Result := FFloatingDockSiteClass; -end; - -procedure TControl.AdjustSize; -begin - if not (csLoading in ComponentState) then SetBounds(Left, Top, Width, Height); -end; - -function TControl.DrawTextBiDiModeFlags(Flags: Longint): Longint; -begin - Result := Flags; - { do not change center alignment } - if UseRightToLeftAlignment then - if Result and DT_RIGHT = DT_RIGHT then - Result := Result and not DT_RIGHT { removing DT_RIGHT, makes it DT_LEFT } - else if not (Result and DT_CENTER = DT_CENTER) then - Result := Result or DT_RIGHT; - Result := Result or DrawTextBiDiModeFlagsReadingOnly; -end; - -function TControl.DrawTextBiDiModeFlagsReadingOnly: Longint; -begin - if UseRightToLeftReading then - Result := DT_RTLREADING - else - Result := 0; -end; - -procedure TControl.InitiateAction; -begin - if ActionLink <> nil then ActionLink.Update; -end; - -procedure TControl.CMHintShow(var Message: TMessage); -begin - if (ActionLink <> nil) and - not ActionLink.DoShowHint(TCMHintShow(Message).HintInfo^.HintStr) then - Message.Result := 1; -end; - -procedure TControl.UpdateLastResize(NewWidth, NewHeight: Integer); -begin - FLastWidth := NewWidth; - FLastHeight := NewHeight; -end; -*/ |