Archivado/Componentes.Terceros.jvcl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
b40ce04eb4
Componentes.Terceros.jvcl/official/3.32/run/JvDiagramShape.pas

2131 lines
61 KiB
ObjectPascal
Raw Blame History

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvDiagramShape.PAS, released on 2002-03-22.
Original Developer: Jim Cooper <jcooper att tabdee dott ltd dott uk>
Contributor(s): Michael Beck <mbeck1 att compuserve dott com>
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net
Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvDiagramShape.pas 10612 2006-05-19 19:04:09Z jfudickar $
unit JvDiagramShape;
{$I jvcl.inc}
interface
uses
{$IFDEF UNITVERSIONING}
JclUnitVersioning,
{$ENDIF UNITVERSIONING}
Windows,
{$IFDEF VisualCLX}
QTypes,
{$ENDIF VisualCLX}
Classes, Graphics, Controls, ExtCtrls, ImgList,
JvComponent;
type
TJvTextShape = class;
// All controls descend from this, to help with streaming and unique naming
TJvCustomDiagramShape = class(TJvGraphicControl)
private
FCanProcessMouseMsg: Boolean;
FCaption: TJvTextShape;
FSelected: Boolean;
FWasCovered: Boolean;
FMultiSelect: Boolean;
FRightClickSelect: Boolean;
FAlignment: TAlignment;
protected
procedure SetCaption(Value: TJvTextShape); virtual;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
function GetCustomShapeAtPos(X, Y: Integer): TJvCustomDiagramShape;
property CanProcessMouseMsg: Boolean read FCanProcessMouseMsg
write FCanProcessMouseMsg;
{$IFDEF VCL}
procedure SetParent(AParent: TWinControl); override;
{$ENDIF VCL}
{$IFDEF VisualCLX}
procedure SetParent(const AParent: TWidgetControl); override;
{$ENDIF VisualCLX}
procedure SetSelected(Value: Boolean); virtual;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
property MultiSelect: Boolean read FMultiSelect write FMultiSelect;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
procedure AlignCaption(Alignment: TAlignment);
// Class methods to save and load all TJvCustomDiagramShape components
// that are children of a given control. They are class methods so that an
// instance of TJvCustomDiagramShape is not required
class procedure SaveToFile(const FileName: string; ParentControl: TWinControl);
class procedure LoadFromFile(const FileName: string; ParentControl: TWinControl);
class procedure DeleteAllShapes(ParentControl: TWinControl);
class procedure DeleteSelectedShapes(ParentControl: TWinControl);
class procedure UnselectAllShapes(ParentControl: TWinControl);
class procedure SetMultiSelected(ParentControl: TWinControl; Value: Boolean);
property Selected: Boolean read FSelected write SetSelected;
property Caption: TJvTextShape read FCaption write SetCaption;
property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default True;
property OnDblClick;
end;
TJvMoveableShape = class(TJvCustomDiagramShape)
private
FOrigin: TPoint;
FMoving: Boolean;
protected
procedure StartMove(X, Y: Integer);
procedure Move(DeltaX, DeltaY: Integer);
procedure EndMove;
function ValidMove(DeltaX, DeltaY: Integer): Boolean;
procedure MoveShapes(DeltaX, DeltaY: Integer);
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
property Moving: Boolean read FMoving write FMoving;
public
constructor Create(AOwner: TComponent); override;
published
property Caption;
property RightClickSelect;
// Make these properties available
property OnClick;
property OnDblClick;
end;
TJvSizingMode = (smTopLeft, smTop, smTopRight, smLeft, smRight,
smBottomLeft, smBottom, smBottomRight, smNone);
TJvSizeableShape = class(TJvMoveableShape)
private
FSizingMode: TJvSizingMode;
FSizeOrigin: TPoint;
FSizeRectHeight: Integer;
FSizeRectWidth: Integer;
FMinHeight: Integer;
FMinWidth: Integer;
protected
procedure SetSelected(Value: Boolean); override;
procedure Paint; override;
procedure DrawSizingRects;
function GetSizeRect(SizeRectType: TJvSizingMode): TRect;
procedure CheckForSizeRects(X, Y: Integer);
procedure ResizeControl(X, Y: Integer);
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
property SizingMode: TJvSizingMode read FSizingMode write FSizingMode;
property SizeRectHeight: Integer read FSizeRectHeight write FSizeRectHeight;
property SizeRectWidth: Integer read FSizeRectWidth write FSizeRectWidth;
property MinHeight: Integer read FMinHeight write FMinHeight;
property MinWidth: Integer read FMinWidth write FMinWidth;
public
constructor Create(AOwner: TComponent); override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
end;
TJvTextShape = class(TJvSizeableShape)
private
FText: TCaption;
FAutoSize: Boolean;
FFont: TFont;
{$IFDEF VCL}
procedure SetText(const Value: TCaption);
{$ENDIF VCL}
procedure SetFont(Value: TFont);
procedure FontChange(Sender: TObject);
protected
procedure SetAutoSize(Value: Boolean); {$IFDEF VCL} override; {$ENDIF}
procedure RefreshText;
{$IFDEF VCL}
procedure SetParent(AParent: TWinControl); override;
{$ENDIF VCL}
{$IFDEF VisualCLX}
procedure SetParent(const AParent: TWidgetControl); override;
procedure SetText(const Value: TCaption); override;
function GetText: TCaption; override;
{$ENDIF VisualCLX}
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
property Text: TCaption read FText write SetText;
property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
property Font: TFont read FFont write SetFont;
end;
TJvBitmapShape = class(TJvMoveableShape)
private
FImages: TImageList;
FImageIndex: Integer;
procedure SetImages(Value: TImageList);
procedure SetImageIndex(Value: Integer);
protected
procedure SetSelected(Value: Boolean); override;
procedure Paint; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
constructor Create(AOwner: TComponent); override;
published
property Images: TImageList read FImages write SetImages;
property ImageIndex: Integer read FImageIndex write SetImageIndex;
// Make these properties available
property PopupMenu;
property OnMouseDown;
property OnMouseUp;
property OnMouseMove;
property OnClick;
property OnDblClick;
end;
TJvStandardShape = class(TJvSizeableShape)
private
FShapeType: TShapeType;
FLineColor: TColor;
procedure SetShapeType(Value: TShapeType);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
published
property ShapeType: TShapeType read FShapeType write SetShapeType;
// (rom) renamed from LineColour
property LineColor: TColor read FLineColor write FLineColor default clBlack;
end;
TJvConnectionSide = (csLeft, csRight, csTop, csBottom);
TJvConnection = class(TPersistent)
private
FShape: TJvCustomDiagramShape;
FSide: TJvConnectionSide; // Side to connect to
FOffset: Integer; // Distance from top or left of side
public
constructor Create;
procedure Assign(Source: TPersistent); override;
// Gets connection point in parent's coordinates
function ConnPoint(TerminatorRect: TRect): TPoint;
// Gets terminator connection point in parent's coordinates
function TermPoint(TerminatorRect: TRect): TPoint;
// Functions to get boundaries of the terminators
function LeftMost(TerminatorRect: TRect): TPoint;
function RightMost(TerminatorRect: TRect): TPoint;
function TopMost(TerminatorRect: TRect): TPoint;
function BottomMost(TerminatorRect: TRect): TPoint;
published
property Shape: TJvCustomDiagramShape read FShape write FShape;
property Side: TJvConnectionSide read FSide write FSide;
property Offset: Integer read FOffset write FOffset;
end;
TJvConnector = class(TJvCustomDiagramShape)
private
FLineWidth: Integer;
FLineColor: TColor;
// The shapes connected by this control
FStartConn: TJvConnection;
FEndConn: TJvConnection;
// Area of the terminator symbol to be drawn (in horizontal position)
FStartTermRect: TRect;
FEndTermRect: TRect;
// Used to track required movement of the caption
FMidPoint: TPoint;
procedure SetLineWidth(Value: Integer);
function GetConn(Index: Integer): TJvConnection;
procedure SetConn(Index: Integer; Value: TJvConnection);
function GetTermRect(Index: Integer): TRect;
procedure SetTermRect(Index: Integer; Value: TRect);
procedure CheckSize(var AWidth, AHeight: Integer);
function GetMidPoint: TPoint;
protected
procedure SetCaption(Value: TJvTextShape); override;
procedure Paint; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
// For drawing arrows etc. Called from Paint.
procedure DrawStartTerminator; virtual;
procedure DrawEndTerminator; virtual;
procedure MoveCaption;
// Converts point from parent's coordinates to own coordinates
function Convert(APoint: TPoint): TPoint;
function IsConnected(ConnectedShape: TJvCustomDiagramShape): Boolean;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// Restrict the minimum size
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
// Called when moving one of the connected shapes
procedure SetBoundingRect;
procedure SetConnections(TheStartConn, TheEndConn: TJvConnection);
property StartTermRect: TRect index 1 read GetTermRect write SetTermRect;
property EndTermRect: TRect index 2 read GetTermRect write SetTermRect;
published
// Publish these properties so that component streaming can be used to
// store them in a file
property LineWidth: Integer read FLineWidth write SetLineWidth default 1;
property LineColor: TColor read FLineColor write FLineColor default clBlack;
property StartConn: TJvConnection index 1 read GetConn write SetConn;
property EndConn: TJvConnection index 2 read GetConn write SetConn;
property MidPoint: TPoint read GetMidPoint;
property Caption;
property RightClickSelect;
// Make these properties available
property OnClick;
property OnDblClick;
end;
TJvSingleHeadArrow = class(TJvConnector)
protected
procedure DrawArrowHead(ConnPt, TermPt: TPoint);
procedure DrawEndTerminator; override;
public
constructor Create(AOwner: TComponent); override;
end;
TJvSingleHeadOpenDashArrow = class(TJvConnector)
protected
procedure Paint; override;
procedure DrawArrowHead(ConnPt, TermPt: TPoint);
procedure DrawEndTerminator; override;
public
constructor Create(AOwner: TComponent); override;
end;
TJvBluntSingleHeadOpenDashArrow = class(TJvSingleHeadOpenDashArrow)
protected
procedure DrawStartTerminator; override;
public
constructor Create(AOwner: TComponent); override;
end;
TJvBluntSingleHeadArrow = class(TJvSingleHeadArrow)
protected
procedure DrawStartTerminator; override;
public
constructor Create(AOwner: TComponent); override;
end;
TJvSubCaseArrow = class(TJvConnector)
protected
procedure DrawArrowHead(ConnPt, TermPt: TPoint);
procedure DrawEndTerminator; override;
procedure DrawStartTerminator; override;
public
constructor Create(AOwner: TComponent); override;
end;
TJvDoubleHeadArrow = class(TJvSingleHeadArrow)
protected
procedure DrawStartTerminator; override;
public
constructor Create(AOwner: TComponent); override;
end;
{$IFDEF UNITVERSIONING}
const
UnitVersioning: TUnitVersionInfo = (
RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvDiagramShape.pas $';
Revision: '$Revision: 10612 $';
Date: '$Date: 2006-05-19 21:04:09 +0200 (ven., 19 mai 2006) $';
LogPath: 'JVCL\run'
);
{$ENDIF UNITVERSIONING}
implementation
uses
SysUtils,
JvTypes, JvConsts;
type
// This type is solely for the acccess to the protected MouseDown method
TCrackTControl = class(TControl);
var
// Used in unique naming scheme. It is global in this unit to enable a
// 'memory' of the component names used during the lifetime of this unit.
GlobalShapeCount: Integer = 1;
procedure NoLessThan(var Value: Integer; Limit: Integer);
begin
if Value < Limit then
Value := Limit;
end;
function RectHeight(ARect: TRect): Integer;
begin
Result := ARect.Bottom - ARect.Top;
end;
function RectWidth(ARect: TRect): Integer;
begin
Result := ARect.Right - ARect.Left;
end;
function InRect(X, Y: Integer; ARect: TRect): Boolean;
begin
Result := (X >= ARect.Left) and (X <= ARect.Right) and
(Y >= ARect.Top) and (Y <= ARect.Bottom);
end;
function Min(A: array of Integer): Integer;
var
I: Integer;
begin
// (rom) the "Purely" comment is wrong
// (rom) the function explicitly handles empty arrays
Result := 0; // Purely to stop compiler warnings
for I := Low(A) to High(A) do
if I = Low(A) then
Result := A[I]
else
if A[I] < Result then
Result := A[I];
end;
function Max(A: array of Integer): Integer;
var
I: Integer;
begin
Result := 0; // Purely to stop compiler warnings
for I := Low(A) to High(A) do
if I = Low(A) then
Result := A[I]
else
if A[I] > Result then
Result := A[I];
end;
//=== { TJvCustomDiagramShape } ==============================================
constructor TJvCustomDiagramShape.Create(AOwner: TComponent);
var
AlreadyUsed: Boolean;
I: Integer;
TempName: string;
begin
inherited Create(AOwner);
FCanProcessMouseMsg := True;
FCaption := nil;
FSelected := False;
FWasCovered := False;
// (rom) this was removed, but should be handled
//if AOwner = nil then
//Exit;
// Give the component a name and ensure that it is unique
repeat
// Use a local variable to hold the name, so that don't get exceptions
// raised on duplicate names
TempName := 'Shape' + IntToStr(GlobalShapeCount);
Inc(GlobalShapeCount);
AlreadyUsed := False;
// Loop through all the components on the form to ensure that this name
// is not already in use
for I := 0 to Owner.ComponentCount - 1 do
if Owner.Components[I].Name = TempName then
begin
// Try the next component name as this one is used already
AlreadyUsed := True;
Break;
end;
until not AlreadyUsed;
Name := TempName;
end;
destructor TJvCustomDiagramShape.Destroy;
var
I: Integer;
begin
FreeAndNil(FCaption);
// First check that this control has been placed on a form
if Assigned(Parent) then
begin
// Search parent control for TJvConnector components that connect
// to this component
I := 0;
while I < Parent.ControlCount do
if (Parent.Controls[I] is TJvConnector) and
(TJvConnector(Parent.Controls[I]).IsConnected(Self)) then
Parent.Controls[I].Free
else
Inc(I);
end;
inherited Destroy;
end;
procedure TJvCustomDiagramShape.SetCaption(Value: TJvTextShape);
begin
if (Value = nil) and Assigned(FCaption) then
begin
FCaption.Free;
FCaption := nil;
end
else
if Value <> FCaption then
begin
FCaption := Value;
FCaption.Parent := Self.Parent;
// Ensure the caption gets aligned correctly. Ths only needs to happen if
// the caption has not already been set in place (it will already be in the
// right place if we are loading this from a file).
if (FCaption.Left = 0) and (FCaption.Top = 0) then
AlignCaption(taCenter);
end;
end;
{$IFDEF VisualCLX}
procedure TJvCustomDiagramShape.SetParent(const AParent: TWidgetControl);
{$ENDIF VisualCLX}
{$IFDEF VCL}
procedure TJvCustomDiagramShape.SetParent(AParent: TWinControl);
{$ENDIF VCL}
begin
inherited SetParent(AParent);
if Assigned(FCaption) then
FCaption.Parent := AParent;
end;
procedure TJvCustomDiagramShape.SetSelected(Value: Boolean);
begin
FSelected := Value;
if Assigned(FCaption) then
FCaption.SetSelected(Value);
end;
procedure TJvCustomDiagramShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
I: Integer;
begin
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
if not Assigned(Parent) then
Exit;
// Search parent control for TJvConnector components
for I := 0 to Parent.ControlCount - 1 do
if Parent.Controls[I] is TJvConnector then
if TJvConnector(Parent.Controls[I]).IsConnected(Self) then
// Resize the connector, but don't draw it yet
TJvConnector(Parent.Controls[I]).SetBoundingRect;
AlignCaption(FAlignment);
end;
procedure TJvCustomDiagramShape.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
if AComponent = FCaption then
FCaption := nil;
end;
procedure TJvCustomDiagramShape.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
TempPt: TPoint;
CoveredShape: TJvCustomDiagramShape;
begin
if CanProcessMouseMsg then
begin
BringToFront;
MouseCapture := True;
inherited MouseDown(Button, Shift, X, Y);
Exit;
end;
// Pass message on to any covered control capable of handling it
CoveredShape := GetCustomShapeAtPos(X, Y);
TempPt := Point(X, Y);
MouseCapture := False;
if CoveredShape <> nil then
begin
SendToBack;
// Convert coordinates to covered shape's coordinates
TempPt := CoveredShape.ScreenToClient(ClientToScreen(TempPt));
// Send the mouse down message to the covered shape
CoveredShape.MouseDown(Button, Shift, TempPt.X, TempPt.Y);
// Flag the control as having been covered because we lose a mouse click
CoveredShape.FWasCovered := True;
end
else
if Assigned(Parent) then
begin
// Send mouse down message to Parent. The typecast is purely to gain access
// to the Parent.MouseDown method. Need to convert coordinates to parent's
// coordinates
TempPt := Parent.ScreenToClient(ClientToScreen(TempPt));
TCrackTControl(Parent).MouseDown(Button, Shift, TempPt.X, TempPt.Y);
end;
end;
procedure TJvCustomDiagramShape.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if FWasCovered then
begin
// We will lose a mouse click, so replace it
Click;
FWasCovered := False;
end;
end;
function TJvCustomDiagramShape.GetCustomShapeAtPos(X, Y: Integer): TJvCustomDiagramShape;
var
I: Integer;
Pt: TPoint;
begin
Result := nil;
if not Assigned(Parent) then
Exit;
Pt := Parent.ScreenToClient(ClientToScreen(Point(X, Y)));
for I := 0 to Parent.ControlCount - 1 do
if (Parent.Controls[I] <> Self) and
(Parent.Controls[I] is TJvCustomDiagramShape) and
TJvCustomDiagramShape(Parent.Controls[I]).CanProcessMouseMsg and
InRect(Pt.X, Pt.Y, Parent.Controls[I].BoundsRect) then
begin
Result := TJvCustomDiagramShape(Parent.Controls[I]);
Exit;
end;
end;
procedure TJvCustomDiagramShape.AlignCaption(Alignment: TAlignment);
var
ALeft, ATop, AWidth, AHeight: Integer;
begin
FAlignment := Alignment;
if not Assigned(FCaption) then
Exit;
ALeft := Left;
ATop := Top + Height + 5;
AWidth := FCaption.Width;
AHeight := FCaption.Height;
case Alignment of
taLeftJustify:
ALeft := Left;
taRightJustify:
ALeft := Left + Width - 1;
taCenter:
ALeft := Left + ((Width - FCaption.Width) div 2);
end;
FCaption.SetBounds(ALeft, ATop, AWidth, AHeight);
end;
class procedure TJvCustomDiagramShape.SaveToFile(const FileName: string;
ParentControl: TWinControl);
var
FS: TFileStream;
Writer: TWriter;
RealName: string;
begin
FS := TFileStream.Create(FileName, fmCreate or fmShareDenyWrite);
Writer := TWriter.Create(FS, 1024);
try
Writer.Root := ParentControl.Owner;
RealName := ParentControl.Name;
ParentControl.Name := '';
Writer.WriteComponent(ParentControl);
ParentControl.Name := RealName;
finally
Writer.Free;
FS.Free;
end;
end;
class procedure TJvCustomDiagramShape.LoadFromFile(const FileName: string;
ParentControl: TWinControl);
var
FS: TFileStream;
Reader: TReader;
RealName: string;
begin
DeleteAllShapes(ParentControl);
FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
Reader := TReader.Create(FS, 1024);
try
// Save the parent's name, in case we are reading into a different
// control than we saved the diagram from
RealName := ParentControl.Name;
Reader.Root := ParentControl.Owner;
Reader.BeginReferences;
Reader.ReadComponent(ParentControl);
Reader.FixupReferences;
// Restore the parent's name
ParentControl.Name := RealName;
finally
Reader.EndReferences;
Reader.Free;
FS.Free;
end;
end;
class procedure TJvCustomDiagramShape.DeleteAllShapes(ParentControl: TWinControl);
var
I: Integer;
begin
// Delete controls from ParentControl
I := 0;
// (rom) added Assigned for security
if Assigned(ParentControl) then
while I < ParentControl.ControlCount do
if ParentControl.Controls[I] is TJvCustomDiagramShape then
ParentControl.Controls[I].Free
// Note that there is no need to increment the counter, because the
// next component (if any) will now be at the same position in Controls[]
else
Inc(I);
end;
class procedure TJvCustomDiagramShape.DeleteSelectedShapes(ParentControl: TWinControl);
var
I: Integer;
begin
// Delete controls from ParentControl if they are flagged as selected
I := 0;
// (rom) added Assigned for security
if Assigned(ParentControl) then
while I < ParentControl.ControlCount do
if (ParentControl.Controls[I] is TJvCustomDiagramShape) and
(TJvCustomDiagramShape(ParentControl.Controls[I]).Selected) then
ParentControl.Controls[I].Free
// Note that there is no need to increment the counter, because the
// next component (if any) will now be at the same position in Controls[]
else
Inc(I);
end;
class procedure TJvCustomDiagramShape.UnselectAllShapes(ParentControl: TWinControl);
var
I: Integer;
begin
// (rom) added Assigned for security
if Assigned(ParentControl) then
for I := 0 to ParentControl.ControlCount - 1 do
if ParentControl.Controls[I] is TJvCustomDiagramShape then
TJvCustomDiagramShape(ParentControl.Controls[I]).Selected := False;
end;
class procedure TJvCustomDiagramShape.SetMultiSelected(ParentControl: TWinControl;
Value: Boolean);
var
I: Integer;
begin
if Assigned(ParentControl) then
for I := 0 to ParentControl.ControlCount - 1 do
if ParentControl.Controls[I] is TJvCustomDiagramShape then
TJvCustomDiagramShape(ParentControl.Controls[I]).MultiSelect := Value;
end;
//=== { TJvMoveableShape } ===================================================
constructor TJvMoveableShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Selected := False;
Moving := False;
FOrigin := Point(0, 0);
end;
procedure TJvMoveableShape.StartMove(X, Y: Integer);
begin
Selected := True;
Moving := True;
FOrigin := Point(X, Y);
end;
procedure TJvMoveableShape.Move(DeltaX, DeltaY: Integer);
begin
SetBounds(Left + DeltaX, Top + DeltaY, Width, Height);
end;
procedure TJvMoveableShape.EndMove;
begin
Moving := False;
FOrigin := Point(0, 0);
end;
function TJvMoveableShape.ValidMove(DeltaX, DeltaY: Integer): Boolean;
begin
Result := True;
if not Assigned(Parent) then
Exit;
if Selected then
Result := (Left + DeltaX >= 0) and (Top + DeltaY >= 0) and
(Left + DeltaX + Width - 1 < Parent.ClientRect.Right - Parent.ClientRect.Left) and
(Top + DeltaY + Height - 1 < Parent.ClientRect.Bottom - Parent.ClientRect.Top);
end;
procedure TJvMoveableShape.MoveShapes(DeltaX, DeltaY: Integer);
var
I, Pass: Integer;
TempControl: TControl;
begin
if not Assigned(Parent) then
Exit;
// Do 2 passes through controls. The first one is to check that all
// movements are valid
for Pass := 1 to 2 do
begin
for I := 0 to Parent.ControlCount - 1 do
begin
TempControl := Parent.Controls[I];
if TempControl is TJvMoveableShape then
begin
if (Pass = 1) and
(not TJvMoveableShape(TempControl).ValidMove(DeltaX, DeltaY)) then
Exit
else
if (Pass = 2) and TJvMoveableShape(TempControl).Selected then
TJvMoveableShape(TempControl).Move(DeltaX, DeltaY);
end;
end;
end;
end;
procedure TJvMoveableShape.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
// Only respond to left mouse button events
if Button <> mbLeft then
Exit;
// If not holding down the shift key then not doing multiple selection
if not (ssShift in Shift) then
UnselectAllShapes(Parent);
// Start moving the component
StartMove(X, Y);
end;
procedure TJvMoveableShape.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited MouseMove(Shift, X, Y);
// Only need to move the component if the left mouse button is being held down
if not (ssLeft in Shift) then
begin
Moving := False;
Exit;
end;
if Moving then
// Move all the selected shapes
MoveShapes(X - FOrigin.X, Y - FOrigin.Y);
end;
procedure TJvMoveableShape.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
I: Integer;
TempControl: TControl;
begin
inherited MouseUp(Button, Shift, X, Y);
// Only interested in left mouse button events
if Button <> mbLeft then
Exit;
EndMove;
// If this shape is covering any smaller shapes then send it to the back,
// so that we can get at the smaller ones
if not Assigned(Parent) then
Exit;
for I := 0 to Parent.ControlCount - 1 do
begin
TempControl := Parent.Controls[I];
if (TempControl <> Self) and
(TempControl is TJvCustomDiagramShape) and
TJvCustomDiagramShape(TempControl).CanProcessMouseMsg and
InRect(TempControl.Left, TempControl.Top, BoundsRect) and
InRect(TempControl.Left + TempControl.Width,
TempControl.Top + TempControl.Height, BoundsRect) then
begin
// TempControl is not this one, it is a custom shape, that can process
// mouse messages (eg not a connector), and is completely covered by
// this control. So bring the convered control to the top of the z-order
// so that we can access it.
TempControl.BringToFront;
Exit;
end;
end;
end;
//=== { TJvSizeableShape } ===================================================
constructor TJvSizeableShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSizingMode := smNone;
FSizeOrigin := Point(0, 0);
FSizeRectHeight := 5;
FSizeRectWidth := 5;
FMinHeight := FSizeRectHeight;
FMinWidth := FSizeRectWidth;
end;
procedure TJvSizeableShape.SetSelected(Value: Boolean);
begin
if Value <> FSelected then
begin
inherited SetSelected(Value);
// Force redraw to show sizing rectangles
Invalidate;
end;
end;
procedure TJvSizeableShape.Paint;
begin
inherited Paint;
if not Assigned(Parent) then
Exit;
DrawSizingRects;
end;
function TJvSizeableShape.GetSizeRect(SizeRectType: TJvSizingMode): TRect;
begin
case SizeRectType of
smTopLeft:
Result := Bounds(0, 0, SizeRectWidth, SizeRectHeight);
smTop:
Result := Bounds(((ClientRect.Right - ClientRect.Left) div 2) -
(SizeRectWidth div 2), 0, SizeRectWidth, SizeRectHeight);
smTopRight:
Result := Bounds(ClientRect.Right - SizeRectWidth, 0,
SizeRectWidth, SizeRectHeight);
smLeft:
Result := Bounds(0, ((ClientRect.Bottom - ClientRect.Top) div 2) -
(SizeRectHeight div 2), SizeRectWidth, SizeRectHeight);
smRight:
Result := Bounds(ClientRect.Right - SizeRectWidth,
((ClientRect.Bottom - ClientRect.Top) div 2) -
(SizeRectHeight div 2), SizeRectWidth, SizeRectHeight);
smBottomLeft:
Result := Bounds(0, ClientRect.Bottom - SizeRectHeight,
SizeRectWidth, SizeRectHeight);
smBottom:
Result := Bounds(((ClientRect.Right - ClientRect.Left) div 2) -
(SizeRectWidth div 2), ClientRect.Bottom - SizeRectHeight,
SizeRectWidth, SizeRectHeight);
smBottomRight:
Result := Bounds(ClientRect.Right - SizeRectWidth,
ClientRect.Bottom - SizeRectHeight, SizeRectWidth, SizeRectHeight);
smNone:
Result := Bounds(0, 0, 0, 0);
end;
end;
procedure TJvSizeableShape.DrawSizingRects;
var
OldBrush: TBrush;
SMode: TJvSizingMode;
begin
if not FSelected or not CanProcessMouseMsg then
Exit;
with Canvas do
begin
// Draw the sizing rectangles
OldBrush := TBrush.Create;
try
OldBrush.Assign(Brush);
Brush.Style := bsSolid;
Brush.Color := clBlack;
Pen.Color := clBlack;
for SMode := smTopLeft to smBottomRight do
FillRect(GetSizeRect(SMode));
finally
Brush.Assign(OldBrush);
OldBrush.Free;
end;
end;
end;
procedure TJvSizeableShape.CheckForSizeRects(X, Y: Integer);
const
cCursors: array [TJvSizingMode] of TCursor =
(crSizeNWSE, crSizeNS, crSizeNESW, crSizeWE, crSizeWE,
crSizeNESW, crSizeNS, crSizeNWSE, crDefault);
var
SMode: TJvSizingMode;
begin
FSizingMode := smNone;
if not Selected then
Exit;
for SMode := smTopLeft to smBottomRight do
if InRect(X, Y, GetSizeRect(SMode)) then
begin
SizingMode := SMode;
Break;
end;
Cursor := cCursors[SizingMode];
end;
procedure TJvSizeableShape.ResizeControl(X, Y: Integer);
var
L, T, W, H, DeltaX, DeltaY: Integer;
begin
L := Left;
T := Top;
W := Width;
H := Height;
DeltaX := X - FSizeOrigin.X;
DeltaY := Y - FSizeOrigin.Y;
// Calculate the new boundaries on the control. Also change FSizeOrigin to
// reflect change in boundaries if necessary.
case FSizingMode of
smTopLeft:
begin
// Ensure that don't move the left edge if this would make the
// control too narrow
if (L + DeltaX >= 0) and (W - DeltaX > MinWidth) then
begin
L := L + DeltaX;
W := W - DeltaX;
end;
// Ensure that don't move the top edge if this would make the
// control too short
if (T + DeltaY >= 0) and (H - DeltaY > MinHeight) then
begin
T := T + DeltaY;
H := H - DeltaY;
end;
end;
smTop:
begin
if (T + DeltaY >= 0) and (H - DeltaY > MinHeight) then
begin
T := T + DeltaY;
H := H - DeltaY;
end;
end;
smTopRight:
begin
W := W + DeltaX;
if (T + DeltaY >= 0) and (H - DeltaY > MinHeight) then
begin
T := T + DeltaY;
H := H - DeltaY;
end;
FSizeOrigin.X := X;
end;
smLeft:
begin
if (L + DeltaX >= 0) and (W - DeltaX > MinWidth) then
begin
L := L + DeltaX;
W := W - DeltaX;
end;
end;
smRight:
begin
W := W + DeltaX;
FSizeOrigin.X := X;
end;
smBottomLeft:
begin
if (L + DeltaX >= 0) and (W - DeltaX > MinWidth) then
begin
L := L + DeltaX;
W := W - DeltaX;
end;
H := H + DeltaY;
FSizeOrigin.Y := Y;
end;
smBottom:
begin
H := H + DeltaY;
FSizeOrigin.X := X;
FSizeOrigin.Y := Y;
end;
smBottomRight:
begin
W := W + DeltaX;
H := H + DeltaY;
FSizeOrigin.X := X;
FSizeOrigin.Y := Y;
end;
smNone: ;
end;
SetBounds(L, T, W, H);
end;
procedure TJvSizeableShape.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if (FSizingMode = smNone) or (Button <> mbLeft) or (ssShift in Shift) then
begin
// Do moving instead of sizing
FSizingMode := smNone;
inherited MouseDown(Button, Shift, X, Y);
Exit;
end;
// If sizing then make this the only selected control
UnselectAllShapes(Parent);
BringToFront;
{ TODO : check on all Shapes selected }
// FSelected := True;
FSizeOrigin := Point(X, Y);
end;
procedure TJvSizeableShape.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
if Moving then
inherited MouseMove(Shift, X, Y)
else
if (FSizingMode <> smNone) and (ssLeft in Shift) then
ResizeControl(X, Y)
else
// Check if over a sizing rectangle
CheckForSizeRects(X, Y);
end;
procedure TJvSizeableShape.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if Button = mbLeft then
FSizingMode := smNone;
inherited MouseUp(Button, Shift, X, Y);
end;
procedure TJvSizeableShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
// Check that the control bounds are sensible. The control must be at least
// as large as a sizing rectangle
NoLessThan(ALeft, 0);
NoLessThan(ATop, 0);
NoLessThan(AWidth, FMinWidth);
NoLessThan(AHeight, FMinHeight);
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
//=== { TJvTextShape } =======================================================
constructor TJvTextShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAutoSize := True;
FText := '';
FFont := TFont.Create;
FFont.OnChange := FontChange;
end;
destructor TJvTextShape.Destroy;
begin
FreeAndNil(FFont);
inherited Destroy;
end;
procedure TJvTextShape.RefreshText;
var
I, Count: Integer;
TempStr: string;
begin
FMinHeight := FSizeRectHeight;
FMinWidth := FSizeRectWidth;
TempStr := '';
Count := 1;
if AutoSize and Assigned(Parent) then
begin
Canvas.Font := Font;
for I := 1 to Length(FText) do
begin
if FText[I] = Lf then
begin
// Check the width of this line
FMinWidth := Max([FMinWidth, Canvas.TextWidth(TempStr)]);
TempStr := '';
// Count the line feeds
Inc(Count);
end
else
TempStr := TempStr + FText[I];
end;
if Count = 1 then
// In case there is only one line
FMinWidth := Max([FMinWidth, Canvas.TextWidth(FText)]);
// Calculate the height of the text rectangle
FMinHeight := Max([FMinHeight, Canvas.TextHeight(FText) * Count]);
end;
SetBounds(Left, Top, FMinWidth, FMinHeight);
end;
{$IFDEF VisualCLX}
function TJvTextShape.GetText: TCaption;
begin
Result := FText;
end;
{$ENDIF VisualCLX}
procedure TJvTextShape.SetText(const Value: TCaption);
begin
if FText <> Value then
begin
FText := Value;
RefreshText;
end;
end;
procedure TJvTextShape.SetAutoSize(Value: Boolean);
begin
if FAutoSize <> Value then
begin
FAutoSize := Value;
RefreshText;
end;
end;
procedure TJvTextShape.SetFont(Value: TFont);
begin
FFont.Assign(Value);
end;
procedure TJvTextShape.FontChange(Sender: TObject);
begin
RefreshText;
end;
{$IFDEF VisualCLX}
procedure TJvTextShape.SetParent(const AParent: TWidgetControl);
{$ENDIF VisualCLX}
{$IFDEF VCL}
procedure TJvTextShape.SetParent(AParent: TWinControl);
{$ENDIF VCL}
begin
inherited SetParent(AParent);
RefreshText;
end;
procedure TJvTextShape.Paint;
var
TempRect: TRect;
begin
if not Assigned(Parent) then
Exit;
Canvas.Font := Font;
TempRect := ClientRect; // So can pass as a var parameter
{$IFDEF VCL}
DrawText(Canvas.Handle, PCaptionChar(FText), Length(FText), TempRect,
DT_CENTER or DT_NOPREFIX or DT_WORDBREAK);
{$ENDIF VCL}
{$IFDEF VisualCLX}
DrawText(Canvas, FText, Length(FText), TempRect,
DT_CENTER or DT_NOPREFIX or DT_WORDBREAK);
{$ENDIF VisualCLX}
inherited Paint;
end;
procedure TJvTextShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
// Check that the control bounds are sensible. Note that this also works
// if try to set Left, Top etc properties, as their access methods call
// SetBounds().
NoLessThan(AWidth, FMinWidth);
NoLessThan(AHeight, FMinHeight);
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
//=== { TJvBitmapShape } =====================================================
constructor TJvBitmapShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FImages := nil;
FImageIndex := 0;
end;
procedure TJvBitmapShape.SetSelected(Value: Boolean);
begin
if Value <> FSelected then
begin
inherited SetSelected(Value);
// Force redraw to show focus rectangle
Invalidate;
end;
end;
procedure TJvBitmapShape.SetImages(Value: TImageList);
begin
if Value <> FImages then
begin
FImages := Value;
if FImages <> nil then
// Set the size of the component to the image size
SetBounds(Left, Top, FImages.Width, FImages.Height);
end;
end;
procedure TJvBitmapShape.SetImageIndex(Value: Integer);
begin
if Value <> FImageIndex then
begin
FImageIndex := Value;
Invalidate;
end;
end;
procedure TJvBitmapShape.Paint;
var
OldPen: TPen;
begin
inherited Paint;
if (not Assigned(Parent)) or (not Assigned(FImages)) or
(FImageIndex < 0) or (FImageIndex >= FImages.Count) then
// The component has not been placed on a form yet, or does not have an
// associated image
Exit;
// Draw a focus rectangle
OldPen := Canvas.Pen;
Canvas.Pen.Style := psDot;
Canvas.Brush.Style := bsClear;
if Selected then
Canvas.Pen.Mode := pmNot
else
Canvas.Pen.Mode := pmNop;
// (rom) draws a rectangle
Canvas.Polyline([Point(0, 0), Point(Width - 1, 0),
Point(Width - 1, Height - 1), Point(0, Height - 1), Point(0, 0)]);
Canvas.Pen := OldPen;
// Draw the bitmap
{$IFDEF VCL}
FImages.DrawingStyle := dsTransparent;
{$ENDIF VCL}
FImages.Draw(Canvas, 0, 0, FImageIndex);
end;
procedure TJvBitmapShape.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
if AComponent = FImages then
FImages := nil;
end;
//=== { TJvStandardShape } ===================================================
constructor TJvStandardShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// Set a default shape and size and colors
FShapeType := stRectangle;
Width := 100;
Height := 60;
FLineColor := clBlack;
end;
procedure TJvStandardShape.SetShapeType(Value: TShapeType);
begin
if FShapeType <> Value then
begin
FShapeType := Value;
Invalidate;
end;
end;
procedure TJvStandardShape.Paint;
var
TempRect: TRect;
S: Integer;
begin
inherited Paint;
if not Assigned(Parent) then
Exit;
TempRect := ClientRect; // So can pass as a var parameter
InflateRect(TempRect, -SizeRectWidth, -SizeRectHeight);
// Draw shape outline
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := FLineColor;
S := Min([TempRect.Right - TempRect.Left + 1, TempRect.Bottom - TempRect.Top + 1]);
if FShapeType in [stSquare, stRoundSquare, stCircle] then
begin
TempRect.Right := TempRect.Left + S;
TempRect.Bottom := TempRect.Top + S;
end;
case FShapeType of
stRectangle, stSquare:
Canvas.Rectangle(TempRect.Left, TempRect.Top, TempRect.Right, TempRect.Bottom);
stRoundRect, stRoundSquare:
Canvas.RoundRect(TempRect.Left, TempRect.Top, TempRect.Right, TempRect.Bottom,
S div 4, S div 4);
stCircle, stEllipse:
Canvas.Ellipse(TempRect.Left, TempRect.Top, TempRect.Right, TempRect.Bottom);
end;
end;
//=== { TJvConnection } ======================================================
constructor TJvConnection.Create;
begin
inherited Create;
FShape := nil;
FSide := csRight;
FOffset := 0;
end;
procedure TJvConnection.Assign(Source: TPersistent);
begin
if Source is TJvConnection then
begin
FShape := TJvConnection(Source).FShape;
FSide := TJvConnection(Source).FSide;
FOffset := TJvConnection(Source).FOffset;
end
else
inherited Assign(Source);
end;
function TJvConnection.ConnPoint(TerminatorRect: TRect): TPoint;
var
X, Y, W: Integer;
begin
Result := Point(0, 0);
X := 0;
Y := 0;
W := TerminatorRect.Right - TerminatorRect.Left;
if FShape = nil then
Exit;
case FSide of
csLeft:
begin
X := FShape.Left - W;
Y := FShape.Top + FOffset;
end;
csRight:
begin
X := FShape.Left + FShape.Width - 1 + W;
Y := FShape.Top + FOffset;
end;
csTop:
begin
X := FShape.Left + FOffset;
Y := FShape.Top - W;
end;
csBottom:
begin
X := FShape.Left + FOffset;
Y := FShape.Top + FShape.Height - 1 + W;
end;
end;
Result := Point(X, Y);
end;
function TJvConnection.TermPoint(TerminatorRect: TRect): TPoint;
begin
Result.X := 0;
Result.Y := 0;
if Shape = nil then
Exit;
with Result do
case Side of
csLeft:
begin
X := Shape.Left;
Y := Shape.Top + Offset;
end;
csRight:
begin
X := Shape.Left + Shape.Width - 1;
Y := Shape.Top + Offset;
end;
csTop:
begin
X := Shape.Left + Offset;
Y := Shape.Top;
end;
csBottom:
begin
X := Shape.Left + Offset;
Y := Shape.Top + Shape.Height - 1;
end;
else
X := 0;
Y := 0;
end;
end;
function TJvConnection.LeftMost(TerminatorRect: TRect): TPoint;
begin
Result := TermPoint(TerminatorRect);
if Shape = nil then
Exit;
case Side of
csLeft:
Result.X := Shape.Left - RectWidth(TerminatorRect);
csRight:
Result.X := Shape.Left + Shape.Width;
csTop, csBottom:
Result.X := Shape.Left + Offset - (RectHeight(TerminatorRect) div 2);
end;
end;
function TJvConnection.RightMost(TerminatorRect: TRect): TPoint;
begin
Result := TermPoint(TerminatorRect);
if Shape = nil then
Exit;
case Side of
csLeft:
Result.X := Shape.Left - 1;
csRight:
Result.X := Shape.Left + Shape.Width - 1 + RectWidth(TerminatorRect);
csTop, csBottom:
Result.X := Shape.Left + Offset + (RectHeight(TerminatorRect) div 2);
end;
end;
function TJvConnection.TopMost(TerminatorRect: TRect): TPoint;
begin
Result := TermPoint(TerminatorRect);
if Shape = nil then
Exit;
case Side of
csLeft, csRight:
Result.Y := Shape.Top + Offset - (RectHeight(TerminatorRect) div 2);
csTop:
Result.Y := Shape.Top - RectWidth(TerminatorRect) - 1;
csBottom:
Result.Y := Shape.Top + Shape.Height;
end;
end;
function TJvConnection.BottomMost(TerminatorRect: TRect): TPoint;
begin
Result := TermPoint(TerminatorRect);
if Shape = nil then
Exit;
case Side of
csLeft, csRight:
Result.Y := Shape.Top + Offset + (RectHeight(TerminatorRect) div 2);
csTop:
Result.Y := Shape.Top - 1;
csBottom:
Result.Y := Shape.Top + Shape.Height + RectWidth(TerminatorRect);
end;
end;
//=== { TJvConnector } =======================================================
constructor TJvConnector.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanProcessMouseMsg := False;
FLineWidth := 1;
FLineColor := clBlack;
FStartTermRect := Rect(0, 0, 0, 0);
FEndTermRect := Rect(0, 0, 0, 0);
FStartConn := TJvConnection.Create;
FEndConn := TJvConnection.Create;
FMidPoint := Point(0, 0);
end;
destructor TJvConnector.Destroy;
begin
FreeAndNil(FStartConn);
FreeAndNil(FEndConn);
inherited Destroy;
end;
procedure TJvConnector.Paint;
var
EndPt: TPoint;
begin
inherited Paint;
if not Assigned(Parent) then
Exit;
if Assigned(FStartConn.Shape) and Assigned(FEndConn.Shape) then
begin
// Draw the terminators (arrows etc)
DrawStartTerminator;
DrawEndTerminator;
with Canvas do
begin
// Draw the connecting line
Brush.Style := bsClear;
Pen.Width := FLineWidth;
Pen.Color := FLineColor;
// Convert from Parent coordinates to control coordinates
PenPos := Convert(FStartConn.ConnPoint(FStartTermRect));
EndPt := Convert(FEndConn.ConnPoint(FEndTermRect));
LineTo(EndPt.X, EndPt.Y);
end;
end;
end;
procedure TJvConnector.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
// (rom) added Assigned to fix a crash
if Assigned(FStartConn) and (AComponent = FStartConn.FShape) then
FStartConn.FShape := nil;
if Assigned(FEndConn) and (AComponent = FEndConn.FShape) then
FEndConn.FShape := nil;
end;
end;
procedure TJvConnector.DrawStartTerminator;
begin
end;
procedure TJvConnector.DrawEndTerminator;
begin
end;
procedure TJvConnector.MoveCaption;
var
NewMidPoint: TPoint;
ALeft, ATop, ARight, ABottom: Integer;
begin
if Assigned(FCaption) then
begin
if (FMidPoint.X = 0) and (FMidPoint.Y = 0) then
FMidPoint := GetMidPoint;
NewMidPoint := GetMidPoint;
// Move the caption relative to the mid point of the connector
// Not resizing anything, just moving an unconnected shape, so can use
// faster update method than SetBounds
FCaption.Invalidate;
ALeft := FCaption.Left + NewMidPoint.X - FMidPoint.X;
ATop := FCaption.Top + NewMidPoint.Y - FMidPoint.Y;
ARight := ALeft + FCaption.Width;
ABottom := ATop + FCaption.Height;
FCaption.UpdateBoundsRect(Rect(ALeft, ATop, ARight, ABottom));
// Save the new mid point
FMidPoint := NewMidPoint;
end;
end;
procedure TJvConnector.CheckSize(var AWidth, AHeight: Integer);
begin
// Ensure the control is at least as big as the line width
NoLessThan(AHeight, FLineWidth);
NoLessThan(AWidth, FLineWidth);
// Ensure the control is at least as big as the start terminator rectangle
NoLessThan(AHeight, RectHeight(FStartTermRect));
NoLessThan(AWidth, RectWidth(FStartTermRect));
// Ensure the control is at least as big as the end terminator rectangle
NoLessThan(AHeight, RectHeight(FEndTermRect));
NoLessThan(AWidth, RectWidth(FEndTermRect));
end;
procedure TJvConnector.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
CheckSize(AWidth, AHeight);
// Resize the connector
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
// Move the caption
MoveCaption;
end;
procedure TJvConnector.SetBoundingRect;
var
ALeft, ATop, AWidth, AHeight: Integer;
begin
if (FStartConn.Shape = nil) or (FEndConn.Shape = nil) then
Exit;
ALeft := Min([FStartConn.LeftMost(FStartTermRect).X,
FEndConn.LeftMost(FEndTermRect).X]);
ATop := Min([FStartConn.TopMost(FStartTermRect).Y,
FEndConn.TopMost(FEndTermRect).Y]);
AWidth := Max([FStartConn.RightMost(FStartTermRect).X,
FEndConn.RightMost(FEndTermRect).X]) - ALeft + 2;
AHeight := Max([FStartConn.BottomMost(FStartTermRect).Y,
FEndConn.BottomMost(FEndTermRect).Y]) - ATop + 2;
CheckSize(AWidth, AHeight);
Invalidate;
UpdateBoundsRect(Rect(ALeft, ATop, ALeft + AWidth - 1, ATop + AHeight - 1));
MoveCaption;
end;
procedure TJvConnector.SetLineWidth(Value: Integer);
begin
// Ensure that can always see the line!
if Value >= 1 then
FLineWidth := Value;
end;
function TJvConnector.GetConn(Index: Integer): TJvConnection;
begin
case Index of
1:
Result := FStartConn;
2:
Result := FEndConn;
else
Result := nil;
end;
end;
procedure TJvConnector.SetConn(Index: Integer; Value: TJvConnection);
begin
case Index of
1:
FStartConn.Assign(Value);
2:
FEndConn.Assign(Value);
end;
SetBoundingRect;
end;
procedure TJvConnector.SetConnections(TheStartConn, TheEndConn: TJvConnection);
begin
StartConn := TheStartConn;
EndConn := TheEndConn;
end;
function TJvConnector.GetTermRect(Index: Integer): TRect;
begin
case Index of
1:
Result := FStartTermRect;
2:
Result := FEndTermRect;
end;
end;
procedure TJvConnector.SetTermRect(Index: Integer; Value: TRect);
begin
if (Value.Right - Value.Left >= 0) and (Value.Bottom - Value.Top >= 0) then
begin
case Index of
1:
FStartTermRect := Value;
2:
FEndTermRect := Value;
end;
end;
end;
procedure TJvConnector.SetCaption(Value: TJvTextShape);
begin
inherited SetCaption(Value);
MoveCaption;
end;
function TJvConnector.Convert(APoint: TPoint): TPoint;
begin
Result := ScreenToClient(Parent.ClientToScreen(APoint));
end;
function TJvConnector.IsConnected(ConnectedShape: TJvCustomDiagramShape): Boolean;
begin
Result := (FStartConn <> nil) and (FEndConn <> nil) and (ConnectedShape <> nil) and
((FStartConn.Shape = ConnectedShape) or (FEndConn.Shape = ConnectedShape));
end;
function TJvConnector.GetMidPoint: TPoint;
var
A, B: TPoint;
begin
Result := Point(0, 0);
if (not Assigned(FStartConn)) or (not Assigned(FEndConn)) then
Exit;
A := FStartConn.ConnPoint(FStartTermRect);
B := FEndConn.ConnPoint(FEndTermRect);
Result := Point(Min([A.X, B.X]) + Abs(A.X - B.X) div 2,
Min([A.Y, B.Y]) + Abs(A.Y - B.Y) div 2);
end;
//=== { TJvSingleHeadArrow } =================================================
constructor TJvSingleHeadArrow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
EndTermRect := Rect(0, 0, 25, 10);
end;
procedure TJvSingleHeadArrow.DrawArrowHead(ConnPt, TermPt: TPoint);
var
PointPt, Corner1Pt, Corner2Pt: TPoint;
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := FLineColor;
Pen.Color := FLineColor;
// Draw a line connecting the Conn and Term points
PenPos := ConnPt;
LineTo(TermPt.X, TermPt.Y);
// Set the basic points (to be modified depending on arrow head direction
PointPt := TermPt;
Corner1Pt := ConnPt;
Corner2Pt := ConnPt;
if ConnPt.X < TermPt.X then
begin
// Draw a right pointing arrow head
Inc(Corner1Pt.X, 10);
Inc(Corner2Pt.X, 10);
Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);
end
else
if ConnPt.X > TermPt.X then
begin
// Draw a left pointing arrow head
Dec(Corner1Pt.X, 10);
Dec(Corner2Pt.X, 10);
Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);
end
else
if ConnPt.Y < TermPt.Y then
begin
// Draw a down pointing arrow head
Inc(Corner1Pt.Y, 10);
Inc(Corner2Pt.Y, 10);
Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);
end
else
begin
// Draw a up pointing arrow head
Dec(Corner1Pt.Y, 10);
Dec(Corner2Pt.Y, 10);
Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);
end;
Polygon([PointPt, Corner1Pt, Corner2Pt]);
end;
end;
procedure TJvSingleHeadArrow.DrawEndTerminator;
var
ConnPt, TermPt: TPoint;
begin
inherited DrawEndTerminator;
if Assigned(FEndConn.Shape) then
begin
ConnPt := Convert(FEndConn.ConnPoint(EndTermRect));
TermPt := Convert(FEndConn.TermPoint(EndTermRect));
DrawArrowHead(ConnPt, TermPt);
end;
end;
//=== { TJvSingleHeadOpenDashArrow } =========================================
constructor TJvSingleHeadOpenDashArrow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
EndTermRect := Rect(0, 0, 25, 10);
end;
procedure TJvSingleHeadOpenDashArrow.Paint;
begin
Canvas.Pen.Style := psDash;
inherited Paint;
Canvas.Pen.Style := psSolid;
end;
procedure TJvSingleHeadOpenDashArrow.DrawArrowHead(ConnPt, TermPt: TPoint);
var
PointPt, Corner1Pt, Corner2Pt: TPoint;
begin
with Canvas do
begin
Brush.Style := bsClear;
Brush.Color := clWindow;
Pen.Color := FLineColor;
// Draw a line connecting the Conn and Term points
PenPos := ConnPt;
LineTo(TermPt.X, TermPt.Y);
// Set the basic points (to be modified depending on arrow head direction
PointPt := TermPt;
Corner1Pt := ConnPt;
Corner2Pt := ConnPt;
if ConnPt.X < TermPt.X then
begin
// Draw a right pointing arrow head
Inc(Corner1Pt.X, 10);
Inc(Corner2Pt.X, 10);
Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);
end
else
if ConnPt.X > TermPt.X then
begin
// Draw a left pointing arrow head
Dec(Corner1Pt.X, 10);
Dec(Corner2Pt.X, 10);
Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);
end
else
if ConnPt.Y < TermPt.Y then
begin
// Draw a down pointing arrow head
Inc(Corner1Pt.Y, 10);
Inc(Corner2Pt.Y, 10);
Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);
end
else
begin
// Draw a up pointing arrow head
Dec(Corner1Pt.Y, 10);
Dec(Corner2Pt.Y, 10);
Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);
end;
// Polyline([Corner1Pt,PointPt,Corner2Pt]);
MoveTo(PointPt.X, PointPt.Y);
LineTo(Corner1Pt.X, Corner1Pt.Y);
MoveTo(PointPt.X, PointPt.Y);
LineTo(Corner2Pt.X, Corner2Pt.Y);
end;
end;
procedure TJvSingleHeadOpenDashArrow.DrawEndTerminator;
var
ConnPt, TermPt: TPoint;
begin
inherited DrawEndTerminator;
if Assigned(FEndConn.Shape) then
begin
ConnPt := Convert(FEndConn.ConnPoint(EndTermRect));
TermPt := Convert(FEndConn.TermPoint(EndTermRect));
DrawArrowHead(ConnPt, TermPt);
end;
end;
//=== { TJvBluntSingleHeadOpenDashArrow } ====================================
constructor TJvBluntSingleHeadOpenDashArrow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
StartTermRect := Rect(0, 0, 10, 10);
end;
procedure TJvBluntSingleHeadOpenDashArrow.DrawStartTerminator;
var
ConnPt, TermPt: TPoint;
begin
inherited DrawStartTerminator;
if not Assigned(FStartConn.Shape) then
Exit;
ConnPt := Convert(FStartConn.ConnPoint(StartTermRect));
TermPt := Convert(FStartConn.TermPoint(StartTermRect));
with Canvas do
begin
// Draw a line connecting the Conn and Term points
Pen.Color := FLineColor;
PenPos := ConnPt;
LineTo(TermPt.X, TermPt.Y);
end;
end;
//=== { TJvBluntSingleHeadArrow } ============================================
constructor TJvBluntSingleHeadArrow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
StartTermRect := Rect(0, 0, 10, 10);
end;
procedure TJvBluntSingleHeadArrow.DrawStartTerminator;
var
ConnPt, TermPt: TPoint;
begin
inherited DrawStartTerminator;
if not Assigned(FStartConn.Shape) then
Exit;
ConnPt := Convert(FStartConn.ConnPoint(StartTermRect));
TermPt := Convert(FStartConn.TermPoint(StartTermRect));
with Canvas do
begin
// Draw a line connecting the Conn and Term points
Pen.Color := FLineColor;
PenPos := ConnPt;
LineTo(TermPt.X, TermPt.Y);
end;
end;
//=== { TJvSubCaseArrow } ====================================================
constructor TJvSubCaseArrow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
EndTermRect := Rect(0, 0, 25, 10);
StartTermRect := Rect(0, 0, 10, 10);
end;
procedure TJvSubCaseArrow.DrawArrowHead(ConnPt, TermPt: TPoint);
var
PointPt, Corner1Pt, Corner2Pt: TPoint;
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := FLineColor;
Pen.Color := FLineColor;
// Draw a line connecting the Conn and Term points
PenPos := ConnPt;
LineTo(TermPt.X, TermPt.Y);
// Set the basic points (to be modified depending on arrow head direction
PointPt := TermPt;
Corner1Pt := ConnPt;
Corner2Pt := ConnPt;
if ConnPt.X < TermPt.X then
begin
// Draw a right pointing arrow head
Inc(Corner1Pt.X, 10);
Inc(Corner2Pt.X, 10);
Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);
end
else
if ConnPt.X > TermPt.X then
begin
// Draw a left pointing arrow head
Dec(Corner1Pt.X, 10);
Dec(Corner2Pt.X, 10);
Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);
end
else
if ConnPt.Y < TermPt.Y then
begin
// Draw a down pointing arrow head
Inc(Corner1Pt.Y, 10);
Inc(Corner2Pt.Y, 10);
Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);
end
else
begin
// Draw a up pointing arrow head
Dec(Corner1Pt.Y, 10);
Dec(Corner2Pt.Y, 10);
Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);
Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);
end;
Brush.Color := clWindow;
Polygon([PointPt, Corner1Pt, Corner2Pt]);
end;
end;
procedure TJvSubCaseArrow.DrawEndTerminator;
var
ConnPt, TermPt: TPoint;
begin
inherited DrawEndTerminator;
if Assigned(FEndConn.Shape) then
begin
ConnPt := Convert(FEndConn.ConnPoint(EndTermRect));
TermPt := Convert(FEndConn.TermPoint(EndTermRect));
DrawArrowHead(ConnPt, TermPt);
end;
end;
procedure TJvSubCaseArrow.DrawStartTerminator;
var
ConnPt, TermPt: TPoint;
begin
inherited DrawStartTerminator;
if not Assigned(FStartConn.Shape) then
Exit;
ConnPt := Convert(FStartConn.ConnPoint(StartTermRect));
TermPt := Convert(FStartConn.TermPoint(StartTermRect));
with Canvas do
begin
// Draw a line connecting the Conn and Term points
Pen.Color := FLineColor;
PenPos := ConnPt;
LineTo(TermPt.X, TermPt.Y);
end;
end;
//=== { TJvDoubleHeadArrow } =================================================
constructor TJvDoubleHeadArrow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
StartTermRect := EndTermRect;
end;
procedure TJvDoubleHeadArrow.DrawStartTerminator;
var
ConnPt, TermPt: TPoint;
begin
inherited DrawStartTerminator;
if Assigned(FStartConn.Shape) then
begin
ConnPt := Convert(FStartConn.ConnPoint(StartTermRect));
TermPt := Convert(FStartConn.TermPoint(StartTermRect));
DrawArrowHead(ConnPt, TermPt);
end;
end;
//=== Initialisation and cleanup routines ====================================
procedure RegisterStorageClasses;
begin
{$IFDEF COMPILER7_UP}
GroupDescendentsWith(TJvConnection, TControl);
{$ENDIF COMPILER7_UP}
RegisterClasses([TJvCustomDiagramShape, TJvMoveableShape,
TJvSizeableShape, TJvConnection, TJvConnector, TJvSingleHeadArrow,
TJvBluntSingleHeadArrow, TJvDoubleHeadArrow, TJvBitmapShape,
TJvTextShape, TJvStandardShape, TJvSingleHeadOpenDashArrow,
TJvBluntSingleHeadOpenDashArrow, TJvSubCaseArrow]);
end;
initialization
{$IFDEF UNITVERSIONING}
RegisterUnitVersion(HInstance, UnitVersioning);
{$ENDIF UNITVERSIONING}
RegisterStorageClasses;
{$IFDEF UNITVERSIONING}
finalization
UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}
end.
Reference in New Issue View Git Blame Copy Permalink