{*******************************************************************} { } { Developer Express Visual Component Library } { ExpressFlowChart } { } { Copyright (c) 1998-2009 Developer Express Inc. } { ALL RIGHTS RESERVED } { } { The entire contents of this file is protected by U.S. and } { International Copyright Laws. Unauthorized reproduction, } { reverse-engineering, and distribution of all or any portion of } { the code contained in this file is strictly prohibited and may } { result in severe civil and criminal penalties and will be } { prosecuted to the maximum extent possible under the law. } { } { RESTRICTIONS } { } { THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES } { (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE } { SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS } { LICENSED TO DISTRIBUTE THE EXPRESSFLOWCHART AND ALL ACCOMPANYING} { VCL CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY. } { } { THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED } { FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE } { COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE } { AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT } { AND PERMISSION FROM DEVELOPER EXPRESS INC. } { } { CONSULT THE end USER LICENSE AGREEMENT FOR INFORMATION ON } { ADDITIONAL RESTRICTIONS. } { } {*******************************************************************} unit dxflchrt; {$I cxVer.inc} interface uses SysUtils, Classes, Windows, Graphics, Messages, StdCtrls, Forms, dxLines{$IFDEF DELPHI4}, ImgList{$ENDIF}, Controls; const TO_HOME = $8000000; TO_END = $7FFFFFF; type TdxCustomFlowChart = class; TdxFcItem = class; TdxFcObject = class; TdxFcConnection = class; TdxFcShapeType = (fcsNone, fcsRectangle, fcsEllipse, fcsRoundRect, fcsDiamond, fcsNorthTriangle, fcsSouthTriangle, fcsEastTriangle, fcsWestTriangle, fcsHexagon, fcsUser); TdxFclStyle = (fclStraight, fclCurved, fclRectH, fclRectV); TdxFcaType = (fcaNone, fcaArrow, fcaEllipse, fcaRectangle); TdxFcHorzPos = (fchpLeft, fchpCenter, fchpRight); TdxFcVertPos = (fcvpUp, fcvpCenter, fcvpDown); TdxFcHitTest = set of (htNowhere, htByObject, htOnObject, htOnConnection, htOnConLabel, htOnArrowSrc, htOnArrowDst, htOnSelPoint); TdxFcOptions = set of (fcoCanDelete, fcoCanDrag, fcoCanSelect, fcoMultiSelect, fcoHideSelection, fcoDelOnClick); TdxFcDragHandler = procedure(X, Y: Integer; State: TDragState) of object; TdxFcEvent = procedure(Sender: TdxCustomFlowChart; Item: TdxFcItem) of object; TdxFcAllowEvent = procedure(Sender: TdxCustomFlowChart; Item: TdxFcItem; var Allow: Boolean) of object; TdxFcEditEvent = procedure(Sender: TdxCustomFlowChart; AObject: TdxFcObject; var S: string) of object; TdxFcDrawEvent = procedure(Sender: TdxCustomFlowChart; AObject: TdxFcObject; R: TRect) of object; TdxFcObjData = packed record Left: Integer; Top: Integer; Width: Word; Height: Word; Edge: Word; Border: Word; HTPos: TdxFcHorzPos; VTPos: TdxFcVertPos; HIPos: TdxFcHorzPos; VIPos: TdxFcVertPos; BkColor: TColor; ShColor: TColor; Tag: Integer; ObjCnt: Word; Image: Smallint; Shape: TdxFcShapeType; ShWidth: Byte; ParFont: Boolean; Transparent: Boolean; end; TdxFcArwData = packed record AType: TdxFcaType; Width: Byte; Height: Byte; Color: TColor; end; TdxFcConData = packed record ObjSrc: Smallint; ObjDst: Smallint; PtCount: Word; Color: TColor; PtSrc: Byte; PtDst: Byte; Style: TdxFclStyle; ParFont: Boolean; ArwSrc: TdxFcArwData; ArwDst: TdxFcArwData; end; TdxFcFntData = packed record Height: Smallint; Color: TColor; Pitch: TFontPitch; Style: TFontStyles; Charset: TFontCharset; end; TdxFcDragData = packed record Index: Word; Base: TPoint; Mobile: TPoint; case Integer of 0: (Rgn: HRgn); 1: (Connect: TdxFcConnection); end; TdxFcItem = class(TPersistent) private FOwner: TdxCustomFlowChart; FText: string; FFont: TFont; FRealFont: TFont; FParentFont: Boolean; FDestroying: Boolean; FSelected: Boolean; FRepainted: Boolean; procedure OnFontChange(Sender: TObject); procedure SetRealFont; procedure SetFont(Value: TFont); procedure SetParentFont(Value: Boolean); procedure SetSelected(Value: Boolean); protected function SelList: TList; virtual; abstract; procedure Changed; procedure FontChanged; virtual; procedure Invalidate; virtual; abstract; procedure LoadFont(Stream: TStream; AIsUnicode: Boolean); procedure SaveFont(Stream: TStream); procedure SetText(Value: string); virtual; abstract; procedure ScaleFont; property RealFont: TFont read FRealFont; public constructor Create(AOwner: TdxCustomFlowChart); destructor Destroy; override; procedure Assign(Source: TPersistent); override; property Destroying: Boolean read FDestroying; property Font: TFont read FFont write SetFont; property Owner: TdxCustomFlowChart read FOwner; property ParentFont: Boolean read FParentFont write SetParentFont; property Selected: Boolean read FSelected write SetSelected; property Text: string read FText write SetText; end; TdxFcObject = class(TdxFcItem) private FConnections: TList; FLinkedObjects: TList; FObjects: TList; FLeft: Integer; FTop: Integer; FWidth: Word; FHeight: Word; FEdge: Word; FBorder: Word; FIntRgn: HRgn; FExtRgn: HRgn; FPaintRgn: HRgn; FRealLeft: Integer; FRealTop: Integer; FRealWidth: Integer; FRealHeight: Integer; FHorzTextPos: TdxFcHorzPos; FVertTextPos: TdxFcVertPos; FImageIndex: Smallint; FHorzImagePos: TdxFcHorzPos; FVertImagePos: TdxFcVertPos; FTransparent: Boolean; FVisible: Boolean; FBkColor: TColor; FShapeColor: TColor; FRealSW: Word; FShapeType: TdxFcShapeType; FShapeWidth: Byte; FShapeStyle: TPenStyle; FData: Pointer; FCustomData: string; FTag: Integer; FBkBrush: TBrush; FShapeBrush: TBrush; function Create1Rgn(Offset: Integer): HRgn; function ClientRect: TRect; function DisplayRect: TRect; function GetLinkedObject(Index: Integer): TdxFcObject; function GetConnection(Index: Integer): TdxFcConnection; function GetObjectValue(Index: Integer): TdxFcObject; // renamed because of C++Builder function GetIsUnion: Boolean; function GetConnectionCount: Integer; function GetLinkedObjectCount: Integer; function GetObjectCount: Integer; function GetPoint(const P: array of TPoint; X, Y, Cnt: Integer): Integer; function GetZOrder: Word; function HasEdge: Boolean; function HasImage: Boolean; function Opaque: Boolean; function Quadrant(X, Y: Integer): Integer; procedure CalculateLinkedPoints; procedure CreateRgn; procedure DeleteRgn; procedure IsRepainted(Rgn: HRgn); procedure Paint; procedure PaintFrame; procedure ResolveObjRefs; procedure SelPoints(var Pts: array of TPoint); procedure SetBkColor(Value: TColor); procedure SetBorder(Value: Word); procedure SetEdge(Value: Word); procedure SetHeight(Value: Word); procedure SetHorzImagePos(Value: TdxFcHorzPos); procedure SetHorzTextPos(Value: TdxFcHorzPos); procedure SetImageIndex(Value: Smallint); procedure SetLeft(Value: Integer); procedure SetRealBounds; procedure SetRealSW; procedure SetShapeColor(Value: TColor); procedure SetShapeType(Value: TdxFcShapeType); procedure SetShapeStyle(Value: TPenStyle); procedure SetShapeWidth(Value: Byte); procedure SetTransparent(Value: Boolean); procedure SetTop(Value: Integer); procedure SetVertImagePos(Value: TdxFcVertPos); procedure SetVertTextPos(Value: TdxFcVertPos); procedure SetVisible(Value: Boolean); procedure SetWidth(Value: Word); procedure SetZOrder(Value: Word); procedure UpdateConnections; procedure ZoomChanged; protected LinkedPoints: array[0..15] of TPoint; function SelList: TList; override; function UserRegion(R: TRect): HRgn; virtual; procedure Load(Stream: TStream; AIsUnicode: Boolean); virtual; procedure Save(Stream: TStream); virtual; procedure Invalidate; override; procedure SetText(Value: string); override; procedure UserLinkedPoints; virtual; property RealSW: Word read FRealSW; public constructor Create(AOwner: TdxCustomFlowChart); destructor Destroy; override; function GetSelPoint(X, Y: Integer): Integer; function GetLinkedPoint(X, Y: Integer): Integer; function HasInUnion(AObject: TdxFcObject): Boolean; function InRect(const R: TRect): Boolean; procedure Assign(Source: TPersistent); override; procedure AddToUnion(AObject: TdxFcObject); procedure RemoveFromUnion(AObject: TdxFcObject); procedure BringToFront; procedure ClearUnion; procedure MakeVisible; procedure PaintImage(R: TRect); procedure PaintText(R: TRect); procedure PutInFrontOf(Value: TdxFcObject); procedure SelectUnion; procedure SendToBack; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); property BkColor: TColor read FBkColor write SetBkColor; property BorderStyle: Word read FBorder write SetBorder; property CustomData: string read FCustomData write FCustomData; property Data: Pointer read FData write FData; property EdgeStyle: Word read FEdge write SetEdge; property Height: Word read FHeight write SetHeight; property HorzImagePos: TdxFcHorzPos read FHorzImagePos write SetHorzImagePos; property HorzTextPos: TdxFcHorzPos read FHorzTextPos write SetHorzTextPos; property ImageIndex: Smallint read FImageIndex write SetImageIndex; property IsUnion: Boolean read GetIsUnion; property Left: Integer read FLeft write SetLeft; property ConnectionCount: Integer read GetConnectionCount; property LinkedObjectCount: Integer read GetLinkedObjectCount; property LinkedObjects[Index: Integer]: TdxFcObject read GetLinkedObject; property Connections[Index: Integer]: TdxFcConnection read GetConnection; property ObjectCount: Integer read GetObjectCount; property Objects[Index: Integer]: TdxFcObject read GetObjectValue; property RealLeft: Integer read FRealLeft; property RealTop: Integer read FRealTop; property RealWidth: Integer read FRealWidth; property RealHeight: Integer read FRealHeight; property ShapeColor: TColor read FShapeColor write SetShapeColor; property ShapeStyle: TPenStyle read FShapeStyle write SetShapeStyle; property ShapeType: TdxFcShapeType read FShapeType write SetShapeType; property ShapeWidth: Byte read FShapeWidth write SetShapeWidth; property Tag: Integer read FTag write FTag; property Top: Integer read FTop write SetTop; property Transparent: Boolean read FTransparent write SetTransparent; property VertImagePos: TdxFcVertPos read FVertImagePos write SetVertImagePos; property VertTextPos: TdxFcVertPos read FVertTextPos write SetVertTextPos; property Visible: Boolean read FVisible write SetVisible; property Width: Word read FWidth write SetWidth; property ZOrder: Word read GetZOrder write SetZOrder; end; TdxFcConnectionArrow = class(TPersistent) private FOwner: TdxFcConnection; FArrowType: TdxFcaType; FHeight: Byte; FWidth: Byte; FRealHeight: Word; FRealWidth: Word; FColor: TColor; FBrush: TBrush; FPoints: array[0..3] of TPoint; function Active: Boolean; function DisplayRect(Ext: Boolean): TRect; procedure ClearPoints; procedure OffsetPoints(DX, DY: Integer); procedure Paint; procedure Reset; procedure SetPoints(Index: Integer); procedure SetRealBounds; procedure SetArrowType(Value: TdxFcaType); procedure SetHeight(Value: Byte); procedure SetWidth(Value: Byte); procedure SetColor(Value: TColor); public constructor Create(AOwner: TdxFcConnection); destructor Destroy; override; procedure Assign(Source: TPersistent); override; property Owner: TdxFcConnection read FOwner; property ArrowType: TdxFcaType read FArrowType write SetArrowType; property Height: Byte read FHeight write SetHeight; property Width: Byte read FWidth write SetWidth; property Color: TColor read FColor write SetColor; end; (* Point1 and Point2 properties is the linked point type. It may have value from 0..15. 0 1 2 3 4 15 5 14 6 13 7 12 11 10 9 8 *) TdxFcConnection = class(TdxFcItem) private FPoints: TList; FRealPoints: TList; FStyle: TdxFclStyle; FObjectSource: TdxFcObject; FObjectDest: TdxFcObject; FDisplayRect: TRect; FTextRect: TRect; FMassCenter: TPoint; FPointSource: Byte; FPointDest: Byte; FArrowSource: TdxFcConnectionArrow; FArrowDest: TdxFcConnectionArrow; FTransparent: Boolean; FPen: TPen; function DisplayRect: TRect; function GetColor: TColor; function GetPenStyle: TPenStyle; function GetPenWidth: Integer; function GetPointCount: Integer; function GetPoint(Index: Integer): TPoint; function GetRealPoint(Index: Integer): TPoint; function HasPoint(X, Y: Integer): Boolean; function IndexValid(var Index: Integer; AMax: Integer): Boolean; function InternalGetPoint(List: TList; Index: Integer): TPoint; function RealCount: Integer; function RealStyle: TdxFclStyle; function ScreenPoint(Index: Integer): TPoint; procedure DelObj(AObj, Partneur: TdxFcObject; Index: Integer); procedure InsObj(AObj, Partneur: TdxFcObject; Index: Integer); procedure InternalInsertPoint(List: TList; Index: Integer; Value: TPoint); procedure InternalPutPoint(List: TList; Index: Integer; Value: TPoint); procedure InternalRemovePoint(List: TList; Index: Integer); procedure InvalidateText; procedure InvertColor; procedure IsRepainted; procedure NewPoint(X, Y: Integer; Handler: TdxFcDragHandler); procedure OffsetPoints(List: TList; DX, DY: Integer); procedure Paint(Upper: Boolean); procedure PaintLine(DC: HDC); procedure PlaceText; procedure PutPoint(Index: Integer; Value: TPoint); procedure SetArrowSource(Value: TdxFcConnectionArrow); procedure SetArrowDest(Value: TdxFcConnectionArrow); procedure SetColor(Value: TColor); procedure SetDisplayRect; procedure SetObjectPoints; procedure SetPenStyle(Value: TPenStyle); procedure SetPenWidth(Value: Integer); procedure SetStyle(Value: TdxFclStyle); procedure SetTextRect; procedure SetTransparent(Value: Boolean); procedure ZoomChanged; protected function SelList: TList; override; procedure Load(Stream: TStream; AIsUnicode: Boolean); virtual; procedure Save(Stream: TStream); virtual; procedure FontChanged; override; procedure Invalidate; override; procedure SetText(Value: string); override; procedure ArrowChanged(Value: TdxFcConnectionArrow); procedure ConnectionChanged; property RealPoints[Index: Integer]: TPoint read GetRealPoint; public constructor Create(AOwner: TdxCustomFlowChart); destructor Destroy; override; function GetNearestPoint(X, Y: Integer): Integer; function InRect(const R: TRect): Boolean; procedure Assign(Source: TPersistent); override; procedure AddPoint(Pt: TPoint); procedure InsertPoint(Index: Integer; Pt: TPoint); procedure RemovePoint(Index: Integer); procedure SetObjectSource(AObject: TdxFcObject; APoint: Byte); procedure SetObjectDest(AObject: TdxFcObject; APoint: Byte); property ArrowSource: TdxFcConnectionArrow read FArrowSource write SetArrowSource; property ArrowDest: TdxFcConnectionArrow read FArrowDest write SetArrowDest; property Color: TColor read GetColor write SetColor; property ObjectSource: TdxFcObject read FObjectSource; property ObjectDest: TdxFcObject read FObjectDest; property PenStyle: TPenStyle read GetPenStyle write SetPenStyle; property PenWidth: Integer read GetPenWidth write SetPenWidth; // is not saved in the stream/file property PointCount: Integer read GetPointCount; property Points[Index: Integer]: TPoint read GetPoint write PutPoint; property PointSource: Byte read FPointSource; property PointDest: Byte read FPointDest; property Style: TdxFclStyle read FStyle write SetStyle; property Transparent: Boolean read FTransparent write SetTransparent; end; TdxFcSelection = class private Owner: TdxCustomFlowChart; Counts: TList; Points: TList; procedure AddPoint(X, Y: Integer); procedure Clear; procedure Paint; public constructor Create(AOwner: TdxCustomFlowChart); destructor Destroy; override; end; TdxCustomFlowChart = class(TCustomControl) private FObjects: TList; FConnections: TList; FSelObjects: TList; FSelConnections: TList; FSelection: TdxFcSelection; FLeftEdge: Integer; FTopEdge: Integer; FChartLeft: Integer; FChartTop: Integer; FChartWidth: Integer; FChartHeight: Integer; FLockUpdates: Integer; FImages: TImageList; FChangeLink: TChangeLink; FZoom: Word; FRealZoom: Word; FObjectAt: TdxFcObject; FConnectionAt: TdxFcConnection; FHitX: Integer; FHitY: Integer; FDragX: Integer; FDragY: Integer; FDragHandler: TdxFcDragHandler; FDragData: TdxFcDragData; FHitTest: TdxFcHitTest; FBorderStyle: TBorderStyle; FOptions: TdxFcOptions; FRepaint: Boolean; FLoading: Boolean; FOnChange: TdxFcEvent; FOnCreateItem: TdxFcEvent; FOnDeletion: TdxFcEvent; FOnDrawObject: TdxFcDrawEvent; FOnEdited: TdxFcEditEvent; FOnEditing: TdxFcAllowEvent; FOnSelected: TdxFcEvent; FOnSelection: TdxFcAllowEvent; function CanPaint: Boolean; function GetConnection(Index: Integer): TdxFcConnection; function GetObjectValue(Index: Integer): TdxFcObject; // renamed because of C++Builder function GetConnectionCount: Integer; function GetObjectCount: Integer; function GetSelConnect: TdxFcConnection; function GetSelObj: TdxFcObject; function GetSelectedObject(Index: Integer): TdxFcObject; function GetSelectedObjectCount: Integer; function GetSelectedConnection(Index: Integer): TdxFcConnection; function GetSelectedConnectionCount: Integer; function HasSelection: Boolean; function TmpSel: Integer; procedure AbortDrag; procedure AddSelectedObject(AObject: TdxFcObject); procedure AddSelectedConnection(AConnection: TdxFcConnection); procedure CallDragHandler(X, Y: Integer; State: TDragState); procedure ChkDrag(Shift: TShiftState; X, Y: Integer); procedure DragMove(X, Y: Integer; State: TDragState); procedure DragResize(X, Y: Integer; State: TDragState); procedure DragPoint(X, Y: Integer; State: TDragState); procedure DragConnect(X, Y: Integer; State: TDragState); procedure HitTest(X, Y: Integer); procedure InitDrag(X, Y: Integer; Handler: TdxFcDragHandler); procedure InvalidateSel; procedure MoveObjects(DX, DY: Integer); procedure RestoreSel(Value: Integer); procedure ScalePoint(var P: TPoint); procedure SetChartSizes; procedure SetConnection(Index: Integer; Value: TdxFcConnection); procedure SetObjectValue(Index: Integer; Value: TdxFcObject); procedure SetBorderStyle(Value: TBorderStyle); procedure SetImages(Value: TImageList); procedure SetLeftEdge(Value: Integer); procedure SetOptions(Value: TdxFcOptions); procedure SetSelConnect(Value: TdxFcConnection); procedure SetSelObj(Value: TdxFcObject); procedure SetTopEdge(Value: Integer); procedure SetZoom(Value: Word); procedure ScrollChart(Bar, Code, Pos: Cardinal; Value, Page: Integer); procedure OnChangeLink(Sender: TObject); procedure CalculateRealPos; procedure UpdateScrollRange; procedure WMErase(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND; procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE; procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL; procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL; procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST; procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; procedure WMSize(var Msg: TWMSize); message WM_SIZE; procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR; procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED; procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED; protected function CanSelect(Item: TdxFcItem): Boolean; virtual; function InternalCreateObject: TdxFcObject; virtual; function InternalCreateConnection: TdxFcConnection; virtual; procedure Changed(Item: TdxFcItem); virtual; procedure DefaultDrawObject(AObject: TdxFcObject; R: TRect); virtual; procedure Delete(Item: TdxFcItem); virtual; procedure Select(Item: TdxFcItem); virtual; procedure CreateParams(var Params: TCreateParams); override; procedure DefineProperties(Filer: TFiler); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; 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; procedure Paint; override; procedure NeedRepaint; procedure NeedRepaintObject(AObject: TdxFcObject); procedure WndProc(var Message: TMessage); override; property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; property ChartHeight: Integer read FChartHeight; property ChartWidth: Integer read FChartWidth; property Images: TImageList read FImages write SetImages; property Options: TdxFcOptions read FOptions write SetOptions; property Zoom: Word read FZoom write SetZoom default 100; property OnChange: TdxFcEvent read FOnChange write FOnChange; property OnCreateItem: TdxFcEvent read FOnCreateItem write FOnCreateItem; property OnDeletion: TdxFcEvent read FOnDeletion write FOnDeletion; property OnDrawObject: TdxFcDrawEvent read FOnDrawObject write FOnDrawObject; property OnEdited: TdxFcEditEvent read FOnEdited write FOnEdited; property OnEditing: TdxFcAllowEvent read FOnEditing write FOnEditing; property OnSelected: TdxFcEvent read FOnSelected write FOnSelected; property OnSelection: TdxFcAllowEvent read FOnSelection write FOnSelection; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; function ChartPoint(X, Y: Integer): TPoint; function CreateObject(L, T, W, H: Integer; AShape: TdxFcShapeType): TdxFcObject; function CreateConnection(OSrc, ODst: TdxFcObject; PSrc, PDst: Byte): TdxFcConnection; function GetConnectionAt(X, Y: Integer): TdxFcConnection; function GetObjectAt(X, Y: Integer): TdxFcObject; function GetHitTestAt(X, Y: Integer): TdxFcHitTest; function SelCount: Integer; procedure BeginUpdate; procedure CancelUpdate; procedure EndUpdate; procedure Clear; procedure ClearSelection; procedure DeleteSelection; procedure DeleteConnection(AConnection: TdxFcConnection); procedure DeleteObject(AObject: TdxFcObject); procedure Invalidate; override; procedure LoadFromFile(const FileName: string); procedure LoadFromStream(Stream: TStream); virtual; procedure SaveToFile(const FileName: string); procedure SaveToStream(Stream: TStream); virtual; procedure SelectAll; procedure SetLeftTop(ALeft, ATop: Integer); property ConnectionCount: Integer read GetConnectionCount; property Connections[Index: Integer]: TdxFcConnection read GetConnection write SetConnection; property LeftEdge: Integer read FLeftEdge write SetLeftEdge; property TopEdge: Integer read FTopEdge write SetTopEdge; property ObjectCount: Integer read GetObjectCount; property Objects[Index: Integer]: TdxFcObject read GetObjectValue write SetObjectValue; property RealZoom: Word read FRealZoom; property SelectedObject: TdxFcObject read GetSelObj write SetSelObj; property SelectedConnection: TdxFcConnection read GetSelConnect write SetSelConnect; property SelectedObjects[Index: Integer]: TdxFcObject read GetSelectedObject; property SelectedObjectCount: Integer read GetSelectedObjectCount; property SelectedConnections[Index: Integer]: TdxFcConnection read GetSelectedConnection; property SelectedConnectionCount: Integer read GetSelectedConnectionCount; end; TdxFlowChart = class(TdxCustomFlowChart) published property BorderStyle; property Images; property Options; property Zoom; property OnChange; property OnCreateItem; property OnDeletion; property OnDrawObject; property OnEdited; property OnEditing; property OnSelected; property OnSelection; property Align; property Ctl3D; property Color; property Enabled; property Font; property ParentColor default False; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property TabStop default True; property Visible; property OnClick; property OnDblClick; property OnEnter; property OnExit; property OnDragDrop; property OnDragOver; property OnStartDrag; property OnEndDrag; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; end; implementation const StreamDescriptionANSI: AnsiString = 'VER1.0A'; StreamDescriptionUNICODE: AnsiString = 'VER1.0U'; procedure Swap(var A, B: Integer); var C: Integer; begin C := A; A := B; B := C; end; procedure NormRect(var R: TRect); begin if R.Left > R.Right then Swap(R.Left, R.Right); if R.Top > R.Bottom then Swap(R.Top, R.Bottom); end; procedure ExtSelRect(var R: TRect; Sel: Boolean); begin if Sel then InflateRect(R, 3, 3); end; function GetListItem(List: TList; Index: Integer): Pointer; begin Result := nil; if (Index >= 0) and (Index < List.Count) then Result := List[Index]; end; procedure InitBrush(var ABrush: TBrush; AColor: TColor); begin if ABrush = nil then begin ABrush := TBrush.Create; ABrush.Color := AColor; end; end; function ReadStr(Stream: TStream; AIsUnicode: Boolean): string; var L: Word; SA: AnsiString; SW: WideString; begin Stream.ReadBuffer(L, SizeOf(Word)); if AIsUnicode then begin SetLength(SW, L); if L > 0 then Stream.ReadBuffer(SW[1], L * 2); Result := SW; end else begin SetLength(SA, L); if L > 0 then Stream.ReadBuffer(SA[1], L); {$IFDEF DELPHI12} Result := UTF8ToWideString(SA); {$ELSE} Result := SA; {$ENDIF} end; end; procedure WriteStr(Stream: TStream; const S: string); var L: Integer; {$IFDEF STREAMANSIFORMAT} SA: AnsiString; {$ENDIF} begin L := Length(S); if L > $FFFF then L := $FFFF; Stream.WriteBuffer(L, SizeOf(Word)); if L > 0 then begin {$IFDEF STREAMANSIFORMAT} {$IFDEF DELPHI12} SA := UTF8Encode(S); {$ELSE} SA := S; {$ENDIF} Stream.WriteBuffer(SA[1], L); {$ELSE} Stream.WriteBuffer(S[1], L * SizeOf(Char)); {$ENDIF} end; end; function QDistance(X, Y: Integer; const P: TPoint): Integer; var DX, DY: Integer; begin DX := X - P.X; DY := Y - P.Y; Result := DX * DX + DY * DY; end; function AdjustRect(var R: TRect; const Bounds: TRect; HPos: TdxFcHorzPos; VPos: TdxFcVertPos): Boolean; var DX, DY: Integer; begin DX := Bounds.Right - Bounds.Left + R.Left - R.Right; DY := Bounds.Bottom - Bounds.Top + R.Top - R.Bottom; Result := (DX >= 0) and (DY >= 0); if DX < 0 then Inc(R.Right, DX); if DY < 0 then Inc(R.Bottom, DY); if (DX < 0) or (HPos = fchpLeft) then DX := 0; if (DY < 0) or (VPos = fcvpUp) then DY := 0; if HPos = fchpCenter then DX := DX shr 1; if VPos = fcvpCenter then DY := DY shr 1; DX := DX + Bounds.Left - R.Left; DY := DY + Bounds.Top - R.Top; Inc(R.Left, DX); Inc(R.Right, DX); Inc(R.Top, DY); Inc(R.Bottom, DY); end; { TdxFcSelection } constructor TdxFcSelection.Create(AOwner: TdxCustomFlowChart); begin Owner := AOwner; Counts := TList.Create; Points := TList.Create; end; destructor TdxFcSelection.Destroy; begin Counts.Free; Points.Free; end; procedure TdxFcSelection.AddPoint(X, Y: Integer); procedure AddOnePoint(X, Y: Integer); begin Points.Add(Pointer(X)); Points.Add(Pointer(Y)); end; begin Dec(X, Owner.LeftEdge); Dec(Y, Owner.TopEdge); Counts.Add(Pointer(5)); AddOnePoint(X - 2, Y - 2); AddOnePoint(X + 2, Y - 2); AddOnePoint(X + 2, Y + 2); AddOnePoint(X - 2, Y + 2); AddOnePoint(X - 2, Y - 2); end; procedure TdxFcSelection.Clear; begin Counts.Clear; Points.Clear; end; procedure TdxFcSelection.Paint; var DC: HDC; begin DC := Owner.Canvas.Handle; SelectObject(DC, GetStockObject(BLACK_PEN)); SelectObject(DC, GetStockObject(BLACK_BRUSH)); PolyPolygon(DC, Points.List^, Counts.List^, Counts.Count); end; { TdxFcItem } constructor TdxFcItem.Create(AOwner: TdxCustomFlowChart); begin FOwner := AOwner; FFont := TFont.Create; FRealFont := TFont.Create; FFont.Assign(AOwner.Font); SetRealFont; FFont.OnChange := OnFontChange; FParentFont := True; end; destructor TdxFcItem.Destroy; begin FFont.Free; FRealFont.Free; inherited Destroy; end; procedure TdxFcItem.Changed; begin if not Owner.FLoading then Owner.Changed(Self); end; procedure TdxFcItem.OnFontChange(Sender: TObject); begin FParentFont := False; SetRealFont; if Text <> '' then FontChanged; Changed; end; procedure TdxFcItem.ScaleFont; begin RealFont.Size := MulDiv(Font.Size, Owner.RealZoom, 100); end; procedure TdxFcItem.SetRealFont; begin RealFont.Assign(Font); ScaleFont; end; procedure TdxFcItem.SetFont(Value: TFont); begin Font.Assign(Value); end; procedure TdxFcItem.FontChanged; begin Invalidate; end; procedure TdxFcItem.SetParentFont(Value: Boolean); begin if Value <> ParentFont then begin if Value then Font.Assign(Owner.Font); FParentFont := Value; Changed; end; end; procedure TdxFcItem.SetSelected(Value: Boolean); begin if Selected <> Value then begin if Value and not Owner.CanSelect(Self) then Exit; if Selected then begin Invalidate; SelList.Remove(Self); end; FSelected := Value; if Selected then begin with Owner do if not (fcoMultiSelect in Options) then ClearSelection; SelList.Add(Self); Invalidate; end; Owner.Select(Self); end; end; procedure TdxFcItem.Assign(Source: TPersistent); begin if Source is TdxFcItem then begin Text := TdxFcItem(Source).Text; ParentFont := TdxFcItem(Source).ParentFont; if not ParentFont then Font := TdxFcItem(Source).Font; end else inherited Assign(Source); end; procedure TdxFcItem.LoadFont(Stream: TStream; AIsUnicode: Boolean); var Data: TdxFcFntData; FtName: string; begin if ParentFont then Exit; Stream.ReadBuffer(Data, SizeOf(Data)); FtName := ReadStr(Stream, AIsUnicode); with Font do begin OnChange := nil; Height := Data.Height; Color := Data.Color; Pitch := Data.Pitch; Style := Data.Style; Charset := Data.Charset; if FtName <> '' then Name := FtName; OnChange := OnFontChange; end; SetRealFont; end; procedure TdxFcItem.SaveFont(Stream: TStream); var Data: TdxFcFntData; FtName: string; begin if ParentFont then Exit; if Font.Name = Owner.Font.Name then FtName := '' else FtName := Font.Name; with Data do begin Height := Font.Height; Color := Font.Color; Pitch := Font.Pitch; Style := Font.Style; Charset := Font.Charset; end; Stream.WriteBuffer(Data, SizeOf(Data)); WriteStr(Stream, FtName); end; {TdxFcObject} constructor TdxFcObject.Create(AOwner: TdxCustomFlowChart); begin inherited Create(AOwner); FConnections := TList.Create; FLinkedObjects := TList.Create; FObjects := TList.Create; FBkColor := AOwner.Color; FVisible := True; FImageIndex := -1; FShapeWidth := 1; FBorder := BF_RECT; SetRealSW; AOwner.FObjects.Add(Self); end; destructor TdxFcObject.Destroy; var I: Integer; begin Owner.Delete(Self); DeleteRgn; if FPaintRgn <> 0 then DeleteObject(FPaintRgn); while ConnectionCount > 0 do Connections[0].Free; FConnections.Free; FConnections := nil; FLinkedObjects.Free; FLinkedObjects := nil; FObjects.Free; FObjects := nil; FShapeBrush.Free; FBkBrush.Free; Owner.FObjects.Remove(Self); with Owner do for I := 0 to ObjectCount - 1 do Objects[I].FObjects.Remove(Self); Owner.SetChartSizes; inherited Destroy; end; procedure TdxFcObject.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin if (ALeft = Left) and (ATop = Top) and (AWidth = Width) and (AHeight = Height) then Exit; FLeft := ALeft; FTop := ATop; FWidth := Word(AWidth); FHeight := Word(AHeight); with Owner do begin NeedRepaintObject(Self); SetRealBounds; UpdateConnections; NeedRepaintObject(Self); SetChartSizes; end; end; function TdxFcObject.GetLinkedObject(Index: Integer): TdxFcObject; begin Result := TdxFcObject(GetListItem(FLinkedObjects, Index)); end; function TdxFcObject.GetConnection(Index: Integer): TdxFcConnection; begin Result := TdxFcConnection(GetListItem(FConnections, Index)); end; function TdxFcObject.GetObjectValue(Index: Integer): TdxFcObject; begin Result := TdxFcObject(GetListItem(FObjects, Index)); end; function TdxFcObject.GetIsUnion: Boolean; begin Result := FObjects.Count > 0; end; function TdxFcObject.GetConnectionCount: Integer; begin Result := FConnections.Count; end; function TdxFcObject.GetLinkedObjectCount: Integer; begin Result := FLinkedObjects.Count; end; function TdxFcObject.GetObjectCount: Integer; begin Result := FObjects.Count; end; function TdxFcObject.SelList: TList; begin Result := Owner.FSelObjects; end; function TdxFcObject.HasEdge: Boolean; begin Result := (ShapeType = fcsRectangle) and (EdgeStyle <> 0); end; function TdxFcObject.HasImage: Boolean; begin Result := (Owner.Images <> nil) and (ImageIndex >= 0) and (ImageIndex < Owner.Images.Count); end; procedure TdxFcObject.SetBkColor(Value: TColor); begin if FBkColor <> Value then begin FBkColor := Value; if FBkBrush <> nil then FBkBrush.Color := Value; if not Transparent and (ShapeType <> fcsNone) then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetHeight(Value: Word); begin SetBounds(Left, Top, Width, Value); end; procedure TdxFcObject.SetHorzImagePos(Value: TdxFcHorzPos); begin if (FHorzImagePos <> Value) then begin FHorzImagePos := Value; if HasImage then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetHorzTextPos(Value: TdxFcHorzPos); begin if (FHorzTextPos <> Value) then begin FHorzTextPos := Value; if Text <> '' then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetImageIndex(Value: Smallint); begin if (FImageIndex <> Value) then begin FImageIndex := Value; if Owner.Images <> nil then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetLeft(Value: Integer); begin SetBounds(Value, Top, Width, Height); end; procedure TdxFcObject.SetShapeColor(Value: TColor); begin if FShapeColor <> Value then begin FShapeColor := Value; if FShapeBrush <> nil then FShapeBrush.Color := Value; if ShapeType <> fcsNone then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetShapeType(Value: TdxFcShapeType); begin if FShapeType <> Value then begin FShapeType := Value; CalculateLinkedPoints; UpdateConnections; Owner.NeedRepaintObject(Self); end; end; procedure TdxFcObject.SetShapeStyle(Value: TPenStyle); begin if FShapeStyle <> Value then begin FShapeStyle := Value; Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetShapeWidth(Value: Byte); begin if FShapeWidth <> Value then begin DeleteRgn; FShapeWidth := Value; SetRealSW; if ShapeType <> fcsNone then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetText(Value: string); begin if FText <> Value then begin FText := Value; Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetTransparent(Value: Boolean); begin if FTransparent <> Value then begin FTransparent := Value; if ShapeType <> fcsNone then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetTop(Value: Integer); begin SetBounds(Left, Value, Width, Height); end; procedure TdxFcObject.SetVertImagePos(Value: TdxFcVertPos); begin if FVertImagePos <> Value then begin FVertImagePos := Value; if HasImage then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetVertTextPos(Value: TdxFcVertPos); begin if FVertTextPos <> Value then begin FVertTextPos := Value; if Text <> '' then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetVisible(Value: Boolean); begin if FVisible <> Value then begin FVisible := Value; Owner.FHitTest := []; Owner.NeedRepaintObject(Self); end; end; procedure TdxFcObject.SetWidth(Value: Word); begin SetBounds(Left, Top, Value, Height); end; procedure TdxFcObject.SetBorder(Value: Word); begin if Value <> FBorder then begin FBorder := Value; if (ShapeType = fcsRectangle) and (FEdge <> 0) then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetEdge(Value: Word); begin if Value <> FEdge then begin FEdge := Value; if ShapeType = fcsRectangle then Owner.NeedRepaintObject(Self); Changed; end; end; procedure TdxFcObject.SetZOrder(Value: Word); begin if Value >= Owner.ObjectCount then Value := Owner.ObjectCount - 1; if Value <> ZOrder then with Owner do begin FHitTest := []; FObjects.Remove(Self); FObjects.Insert(Value, Self); NeedRepaintObject(Self); Changed(Self); end; end; procedure TdxFcObject.BringToFront; begin SetZOrder(Owner.ObjectCount - 1); end; procedure TdxFcObject.SendToBack; begin SetZOrder(0); end; procedure TdxFcObject.PutInFrontOf(Value: TdxFcObject); var Z: Integer; begin Z := Value.ZOrder; if Z < ZOrder then Inc(Z); SetZOrder(Z); end; (* 0 1 2 3 4 15 5 14 6 13 7 12 11 10 9 8 *) procedure TdxFcObject.SetRealBounds; begin FRealLeft := MulDiv(Left, Owner.RealZoom, 100); FRealTop := MulDiv(Top, Owner.RealZoom, 100); FRealWidth := MulDiv(Width, Owner.RealZoom, 100); FRealHeight := MulDiv(Height, Owner.RealZoom, 100); CalculateLinkedPoints; end; procedure TdxFcObject.SetRealSW; begin FRealSW := (ShapeWidth * Owner.RealZoom + 50) div 100; if (RealSW = 0) and (ShapeWidth <> 0) then FRealSW := 1; end; procedure TdxFcObject.ZoomChanged; begin SetRealBounds; SetRealSW; ScaleFont; end; procedure TdxFcObject.CalculateLinkedPoints; var qWidth, qHeight, ARight, ABottom: Integer; DX, DY: Integer; procedure IncP(Index, IX, IY: Integer); begin Inc(LinkedPoints[Index].X, IX); Inc(LinkedPoints[Index].Y, IY); end; procedure Trio(I1, I2, I3: Integer); begin LinkedPoints[I1].X := LinkedPoints[I2].X; LinkedPoints[I1].Y := LinkedPoints[I3].Y; LinkedPoints[I2].Y := LinkedPoints[I1].Y; LinkedPoints[I3].X := LinkedPoints[I1].X; end; procedure TrioX(I1, I2, I3, I4: Integer); begin LinkedPoints[I1].X := LinkedPoints[I2].X + DX; LinkedPoints[I3].X := LinkedPoints[I4].X - DX; end; procedure TrioY(I1, I2, I3, I4: Integer); begin LinkedPoints[I1].Y := LinkedPoints[I2].Y + DY; LinkedPoints[I3].Y := LinkedPoints[I4].Y - DY; end; function Scale(Value, Coef: Integer): Integer; begin Result := (Value * Coef + 512) shr 10; end; begin DeleteRgn; Owner.FHitTest := []; qWidth := RealWidth div 4; qHeight := RealHeight div 4; ARight := RealLeft + RealWidth; ABottom := RealTop + RealHeight; for DX := 4 to 8 do LinkedPoints[DX].X := ARight; for DX := 12 to 16 do LinkedPoints[DX and 15].X := RealLeft; for DX := 0 to 4 do LinkedPoints[DX].Y := RealTop; for DX := 8 to 12 do LinkedPoints[DX].Y := ABottom; LinkedPoints[1].X := RealLeft + qWidth; LinkedPoints[2].X := RealLeft + RealWidth shr 1; LinkedPoints[3].X := ARight - qWidth; LinkedPoints[5].Y := RealTop + qHeight; LinkedPoints[6].Y := RealTop + RealHeight shr 1; LinkedPoints[7].Y := ABottom - qHeight; LinkedPoints[9].X := LinkedPoints[3].X; LinkedPoints[10].X := LinkedPoints[2].X; LinkedPoints[11].X := LinkedPoints[1].X; LinkedPoints[13].Y := LinkedPoints[7].Y; LinkedPoints[14].Y := LinkedPoints[6].Y; LinkedPoints[15].Y := LinkedPoints[5].Y; for DX := 4 to 8 do Dec(LinkedPoints[DX].X); for DX := 8 to 12 do Dec(LinkedPoints[DX].Y); DX := qWidth shr 1; DY := qHeight shr 1; case ShapeType of fcsUser: UserLinkedPoints; fcsNorthTriangle: begin Trio(0, 1, 14); TrioX(13, 13, 15, 2); Trio(4, 3, 6); TrioX(5, 2, 7, 7); end; fcsSouthTriangle: begin Trio(12, 11, 14); TrioX(15, 15, 13, 10); Trio(8, 9, 6); TrioX(7, 10, 5, 5); end; fcsEastTriangle: begin Trio(4, 2, 5); TrioY(1, 1, 3, 6); Trio(8, 10, 7); TrioY(9, 6, 11, 11); end; fcsWestTriangle: begin Trio(0, 2, 15); TrioY(3, 3, 1, 14); Trio(12, 10, 13); TrioY(11, 14, 9, 9); end; fcsHexagon: begin IncP(0, DX, qHeight); IncP(4, -DX, qHeight); IncP(8, -DX, -qHeight); IncP(12, DX, -qHeight); IncP(13, DX, 0); IncP(15, DX, 0); IncP(5, -DX, 0); IncP(7, -DX, 0); end; fcsDiamond: begin IncP(0, qWidth, qHeight); IncP(4, -qWidth, qHeight); IncP(8, -qWidth, -qHeight); IncP(12, qWidth, -qHeight); IncP(1, DX, DY); IncP(3, -DX, DY); IncP(5, -DX, DY); IncP(7, -DX, -DY); IncP(9, -DX, -DY); IncP(11, DX, -DY); IncP(13, DX, -DY); IncP(15, DX, DY); end; fcsRoundRect: begin DX := Scale(RealWidth, 75); DY := Scale(RealHeight, 75); IncP(0, DX, DY); IncP(4, -DX, DY); IncP(8, -DX, -DY); IncP(12, DX, -DY); end; fcsEllipse: begin DX := Scale(RealWidth, 150); DY := Scale(RealHeight, 150); IncP(0, DX, DY); IncP(4, -DX, DY); IncP(8, -DX, -DY); IncP(12, DX, -DY); DX := Scale(RealWidth, 68); DY := Scale(RealHeight, 68); IncP(13, DX, 0); IncP(15, DX, 0); IncP(5, -DX, 0); IncP(7, -DX, 0); IncP(1, 0, DY); IncP(3, 0, DY); IncP(9, 0, -DY); IncP(11, 0, -DY); end; end; end; procedure TdxFcObject.UpdateConnections; var I: Integer; begin Changed; for I := 0 to ConnectionCount - 1 do with Connections[I] do begin ConnectionChanged; SetObjectPoints; SetDisplayRect; Changed; end; end; procedure TdxFcObject.Invalidate; begin Owner.NeedRepaintObject(Self); end; function TdxFcObject.DisplayRect: TRect; begin with Result do begin Left := RealLeft - Owner.LeftEdge; Top := RealTop - Owner.TopEdge; Right := Left + RealWidth; Bottom := Top + RealHeight; end; end; function TdxFcObject.Opaque: Boolean; begin Result := not Transparent and (ShapeType <> fcsNone); end; procedure TdxFcObject.IsRepainted(Rgn: HRgn); var R: TRect; begin FRepainted := Visible; if not Visible then Exit; R := DisplayRect; ExtSelRect(R, Selected); FRepainted := RectVisible(Owner.Canvas.Handle, R) or (csPaintCopy in Owner.ControlState); {paul} if FRepainted and Opaque then begin CreateRgn; if FPaintRgn = 0 then FPaintRgn := CreateRectRgn(0, 0, 0, 0); CombineRgn(FPaintRgn, FExtRgn, FIntRgn, RGN_OR); FRepainted := CombineRgn(FPaintRgn, FPaintRgn, Rgn, RGN_DIFF) <> NULLREGION; if FRepainted then CombineRgn(Rgn, Rgn, FPaintRgn, RGN_OR); FRepainted := FRepainted or Selected; end; end; function TdxFcObject.ClientRect: TRect; begin Result.TopLeft := LinkedPoints[0]; Result.BottomRight := LinkedPoints[8]; case ShapeType of fcsNorthTriangle: Result.Right := LinkedPoints[4].X; fcsSouthTriangle: Result.Left := LinkedPoints[1].X; fcsEastTriangle: Result.Top := LinkedPoints[15].Y; fcsWestTriangle: Result.Bottom := LinkedPoints[7].Y; end; InflateRect(Result, -RealSW, -RealSW); OffsetRect(Result, -Owner.LeftEdge, -Owner.TopEdge); end; function TdxFcObject.GetZOrder: Word; begin Result := Word(Owner.FObjects.IndexOf(Self)); end; procedure TdxFcObject.CreateRgn; procedure AndRgn(DX, DY: Integer); begin OffsetRgn(FExtRgn, DX, DY); CombineRgn(FIntRgn, FIntRgn, FExtRgn, RGN_AND); OffsetRgn(FExtRgn, -DX, -DY); end; var W: Integer; begin if FIntRgn <> 0 then Exit; if (ShapeType = fcsNone) or HasEdge then W := 1 else W := RealSW; FExtRgn := Create1Rgn(0); if ShapeType in [fcsEllipse, fcsRoundRect, fcsUser] then FIntRgn := Create1Rgn(-W) else begin FIntRgn := CreateRectRgn(0, 0, 0, 0); CombineRgn(FIntRgn, FExtRgn, FExtRgn, RGN_COPY); AndRgn(W, 0); AndRgn(0, W); AndRgn(-W, 0); AndRgn(0, -W); end; CombineRgn(FExtRgn, FExtRgn, FIntRgn, RGN_DIFF); end; function TdxFcObject.Create1Rgn(Offset: Integer): HRgn; var NPoints: Integer; R: TRect; Pts: array[0..5] of TPoint; procedure SetPolygon(const Indexes: array of Integer); var I: Integer; begin NPoints := High(Indexes) + 1; for I := 0 to High(Indexes) do begin Pts[I] := LinkedPoints[Indexes[I]]; Dec(Pts[I].X, Owner.LeftEdge); Dec(Pts[I].Y, Owner.TopEdge); end; end; begin NPoints := 0; R := DisplayRect; case ShapeType of fcsDiamond: SetPolygon([2, 6, 10, 14]); fcsHexagon: SetPolygon([1, 3, 6, 9, 11, 14]); fcsNorthTriangle: SetPolygon([2, 8, 12]); fcsSouthTriangle: SetPolygon([0, 4, 10]); fcsEastTriangle: SetPolygon([0, 6, 12]); fcsWestTriangle: SetPolygon([4, 8, 14]); end; if NPoints <> 0 then Result := CreatePolygonRgn(Pts, NPoints, WINDING) else begin InflateRect(R, Offset, Offset); case ShapeType of fcsUser: Result := UserRegion(R); fcsNone, fcsRectangle: Result := CreateRectRgnIndirect(R); fcsEllipse: Result := CreateEllipticRgnIndirect(R); fcsRoundRect: Result := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, RealWidth shr 1, RealHeight shr 1); else Result := 0; end; end; end; procedure TdxFcObject.DeleteRgn; begin if FExtRgn <> 0 then DeleteObject(FExtRgn); if FIntRgn <> 0 then DeleteObject(FIntRgn); FExtRgn := 0; FIntRgn := 0; end; procedure TdxFcObject.SelPoints(var Pts: array of TPoint); var I: Integer; begin for I := 2 to 4 do Pts[I].X := RealLeft + RealWidth - 1; for I := 6 to 8 do Pts[I and 7].X := RealLeft; for I := 0 to 2 do Pts[I].Y := RealTop; for I := 4 to 6 do Pts[I].Y := RealTop + RealHeight - 1; Pts[1].X := RealLeft + RealWidth shr 1; Pts[5].X := Pts[1].X; Pts[3].Y := RealTop + RealHeight shr 1; Pts[7].Y := Pts[3].Y; end; function TdxFcObject.Quadrant(X, Y: Integer): Integer; begin Result := Ord(X < RealLeft + RealWidth shr 1) shl 1 + Ord(Y >= RealTop + RealHeight shr 1); if Result > 1 then Result := Result xor 1; end; function TdxFcObject.GetPoint(const P: array of TPoint; X, Y, Cnt: Integer): Integer; var I, Cur, Min, Mask, Start: Integer; begin Result := 0; Min := $7FFFFFFF; I := Cnt shr 1; if Cnt = 2 then Mask := 7 else Mask := 15; Inc(X, Owner.LeftEdge); Inc(Y, Owner.TopEdge); Start := Quadrant(X, Y) shl I + I; for I := Start to Start + Cnt do begin Cur := QDistance(X, Y, P[I and Mask]); if Cur < Min then begin Min := Cur; Result := I and Mask; end; end; end; function TdxFcObject.GetSelPoint(X, Y: Integer): Integer; var P: array[0..7] of TPoint; begin SelPoints(P); Result := GetPoint(P, X, Y, 2); end; function TdxFcObject.InRect(const R: TRect): Boolean; begin Result := Visible; if Result then begin CreateRgn; Result := RectInRegion(FIntRgn, R); end; end; function TdxFcObject.GetLinkedPoint(X, Y: Integer): Integer; begin Result := GetPoint(LinkedPoints, X, Y, 4); end; function TdxFcObject.HasInUnion(AObject: TdxFcObject): Boolean; var I: Integer; begin Result := (AObject = nil) or (AObject = Self); if Result then Exit; for I := 0 to ObjectCount - 1 do begin Result := Objects[I].HasInUnion(AObject); if Result then Exit; end; end; procedure TdxFcObject.AddToUnion(AObject: TdxFcObject); begin if not HasInUnion(AObject) then FObjects.Add(AObject); end; procedure TdxFcObject.RemoveFromUnion(AObject: TdxFcObject); begin FObjects.Remove(AObject); end; procedure TdxFcObject.ClearUnion; begin FObjects.Clear; end; procedure TdxFcObject.SelectUnion; var I: Integer; begin Selected := True; with Owner do if not (fcoMultiSelect in Options) then Exit; for I := 0 to ObjectCount - 1 do Objects[I].SelectUnion; end; procedure TdxFcObject.MakeVisible; var R: TRect; LeftX, TopY: Integer; begin Visible := True; if (RealWidth > Owner.ClientWidth) or (RealHeight > Owner.ClientHeight) then R := ClientRect else R := DisplayRect; LeftX := R.Left; TopY := R.Top; with Owner do begin if R.Right > ClientWidth then LeftX := LeftX + ClientWidth - R.Right; if LeftX < 0 then LeftX := 0; if R.Bottom > ClientHeight then TopY := TopY + ClientHeight - R.Bottom; if TopY < 0 then TopY := 0; if (LeftX = R.Left) and (TopY = R.Top) then Exit; SetLeftTop(LeftEdge + R.Left - LeftX, TopEdge + R.Top - TopY); end; end; procedure TdxFcObject.Paint; var R: TRect; begin if FRepainted then begin if Opaque and not (csPaintCopy in Owner.ControlState) then // Fix: by Paulthen ExtSelectClipRgn(Owner.Canvas.Handle, FPaintRgn, RGN_OR); if ShapeType <> fcsNone then PaintFrame; R := ClientRect; if RectVisible(Owner.Canvas.Handle, R) or (csPaintCopy in Owner.ControlState) then {paul} if Assigned(Owner.OnDrawObject) then Owner.OnDrawObject(Owner, Self, R) else Owner.DefaultDrawObject(Self, R); end; end; procedure TdxFcObject.PaintFrame; var Pt: TPoint; // by Paul DC: HDC; Rgn: HRgn; R: TRect; begin CreateRgn; DC := Owner.Canvas.Handle; if not Transparent then begin if HasEdge then Rgn := FPaintRgn else Rgn := FIntRgn; InitBrush(FBkBrush, BkColor); Pt := Point(0, 0); // by Paul if HasEdge then GetWindowOrgEx(DC, Pt); // by Paul if (Pt.X <> 0) or (Pt.Y <> 0) then // by Paul OffsetRgn(Rgn, Pt.X, Pt.Y); // by Paul FillRgn(DC, Rgn, FBkBrush.Handle); if (Pt.X <> 0) or (Pt.Y <> 0) then // by Paul OffsetRgn(Rgn, -Pt.X, -Pt.Y); // by Paul end; // by Paul if HasEdge then begin R := DisplayRect; DrawEdge(DC, R, EdgeStyle, BorderStyle); end else begin InitBrush(FShapeBrush, ShapeColor); FillRgn(DC, FExtRgn, FShapeBrush.Handle); end; end; procedure TdxFcObject.PaintImage(R: TRect); var IR: TRect; begin if Owner.Images = nil then Exit; IR := Rect(0, 0, Owner.Images.Width, Owner.Images.Height); if AdjustRect(IR, R, HorzImagePos, VertImagePos) then Owner.Images.Draw(Owner.Canvas, IR.Left, IR.Top, ImageIndex); end; procedure TdxFcObject.PaintText(R: TRect); const Aligns: array[TdxFcHorzPos] of Word = (DT_LEFT, DT_CENTER, DT_RIGHT); var DC: HDC; Flags: Word; TR: TRect; begin DC := Owner.Canvas.Handle; TR := R; Flags := DT_EXPANDTABS or DT_WORDBREAK or Aligns[HorzTextPos]; SelectObject(DC, RealFont.Handle); SetTextColor(DC, ColorToRGB(RealFont.Color)); if VertTextPos <> fcvpUp then begin DrawText(DC, PChar(Text), -1, TR, Flags or DT_CALCRECT); AdjustRect(TR, R, HorzTextPos, VertTextPos); end; DrawText(DC, PChar(Text), -1, TR, Flags); end; procedure TdxFcObject.ResolveObjRefs; var I: Integer; begin for I := 0 to ObjectCount - 1 do FObjects[I] := Owner.Objects[Integer(FObjects[I])]; end; procedure TdxFcObject.Assign(Source: TPersistent); begin if Source is TdxFcObject then with TdxFcObject(Source) do begin Self.Data := Data; Self.Tag := Tag; Self.CustomData := CustomData; Self.SetBounds(Left, Top, Width, Height); Self.EdgeStyle := EdgeStyle; Self.BorderStyle := BorderStyle; Self.HorzTextPos := HorzTextPos; Self.VertTextPos := VertTextPos; Self.HorzImagePos := HorzImagePos; Self.VertImagePos := VertImagePos; Self.BkColor := BkColor; Self.ShapeColor := ShapeColor; Self.ImageIndex := ImageIndex; Self.Transparent := Transparent; Self.ShapeType := ShapeType; Self.ShapeWidth := ShapeWidth; end; inherited Assign(Source); end; procedure TdxFcObject.Load(Stream: TStream; AIsUnicode: Boolean); var I: Integer; ObjData: TdxFcObjData; begin Stream.ReadBuffer(ObjData, SizeOf(ObjData)); with ObjData do begin SetBounds(Left, Top, Width, Height); EdgeStyle := Edge; BorderStyle := Border; HorzTextPos := HTPos; VertTextPos := VTPos; HorzImagePos := HIPos; VertImagePos := VIPos; Self.BkColor := BkColor; ShapeColor := ShColor; Self.Tag := Tag; ImageIndex := Image; ShapeType := Shape; ShapeWidth := ShWidth; ParentFont := ParFont; Self.Transparent := Transparent; while ObjCnt > 0 do begin I := 0; Dec(ObjCnt); Stream.ReadBuffer(I, SizeOf(Word)); FObjects.Add(Pointer(I)); end; end; LoadFont(Stream, AIsUnicode); Text := ReadStr(Stream, AIsUnicode); CustomData := ReadStr(Stream, AIsUnicode); end; procedure TdxFcObject.Save(Stream: TStream); var I: Integer; W: Word; ObjData: TdxFcObjData; begin with ObjData do begin Left := Self.Left; Top := Self.Top; Width := Self.Width; Height := Self.Height; Edge := EdgeStyle; Border := BorderStyle; HTPos := HorzTextPos; VTPos := VertTextPos; HIPos := HorzImagePos; VIPos := VertImagePos; BkColor := Self.BkColor; ShColor := ShapeColor; Tag := Self.Tag; Image := ImageIndex; Shape := ShapeType; ShWidth := ShapeWidth; ParFont := ParentFont; Transparent := Self.Transparent; ObjCnt := Word(ObjectCount); end; Stream.WriteBuffer(ObjData, SizeOf(ObjData)); for I := 0 to ObjectCount - 1 do begin W := Objects[I].ZOrder; Stream.WriteBuffer(W, SizeOf(W)); end; SaveFont(Stream); WriteStr(Stream, Text); WriteStr(Stream, CustomData); end; function TdxFcObject.UserRegion(R: TRect): HRgn; begin Result := 0; end; procedure TdxFcObject.UserLinkedPoints; begin end; {TdxFcConnectionArrow} constructor TdxFcConnectionArrow.Create(AOwner: TdxFcConnection); begin FOwner := AOwner; FColor := AOwner.Owner.Color; end; destructor TdxFcConnectionArrow.Destroy; begin FBrush.Free; end; procedure TdxFcConnectionArrow.ClearPoints; begin if ArrowType = fcaArrow then begin FPoints[1] := Point(0, 0); FPoints[3] := Point(0, 0); end; end; procedure TdxFcConnectionArrow.Reset; begin ClearPoints; Owner.ArrowChanged(Self); Owner.Changed; end; procedure TdxFcConnectionArrow.SetRealBounds; begin FRealWidth := MulDiv(Width, Owner.Owner.RealZoom, 100); FRealHeight := MulDiv(Height, Owner.Owner.RealZoom, 100); end; procedure TdxFcConnectionArrow.SetArrowType(Value: TdxFcaType); begin if (FArrowType <> Value) then begin Owner.ArrowChanged(Self); FArrowType := Value; Reset; end; end; procedure TdxFcConnectionArrow.SetHeight(Value: Byte); begin if (FHeight <> Value) then begin Owner.ArrowChanged(Self); FHeight := Value; SetRealBounds; Reset; end; end; procedure TdxFcConnectionArrow.SetWidth(Value: Byte); begin if (FWidth <> Value) then begin Owner.ArrowChanged(Self); FWidth := Value; SetRealBounds; Reset; end; end; procedure TdxFcConnectionArrow.SetColor(Value: TColor); begin if (FColor <> Value) then begin FColor := Value; if FBrush <> nil then FBrush.Color := Value; if ArrowType in [fcaRectangle, fcaEllipse] then Owner.ArrowChanged(Self); Owner.Changed; end; end; function TdxFcConnectionArrow.Active: Boolean; begin Result := (ArrowType <> fcaNone) and (Owner.RealCount > 1); end; function TdxFcConnectionArrow.DisplayRect(Ext: Boolean): TRect; begin if ArrowType = fcaArrow then begin Result.TopLeft := FPoints[1]; Result.BottomRight := FPoints[1]; ExtendRect(Result, FPoints[0]); ExtendRect(Result, FPoints[2]); end else with Result do begin Left := FPoints[1].X - FRealWidth shr 1; Top := FPoints[1].Y - FRealHeight shr 1; Right := Left + FRealWidth; Bottom := Top + FRealHeight; end; ExtSelRect(Result, Ext); end; procedure TdxFcConnectionArrow.SetPoints(Index: Integer); var DX, DY, DXY, IsRect: Integer; P1, P3: TPoint; procedure Rotate(var P: TPoint); var X, Y: Integer; begin X := (P.X * DX - P.Y * DY) div DXY; Y := (P.X * DY + P.Y * DX) div DXY; P.X := X + FPoints[1].X; P.Y := Y + FPoints[1].Y; end; begin if not Active then Exit; IsRect := Ord(Owner.Style) xor Ord(Index <> 0); P1 := Owner.InternalGetPoint(Owner.FRealPoints, Index); if Index = 0 then Inc(Index) else Dec(Index); P3 := Owner.InternalGetPoint(Owner.FRealPoints, Index); if (P1.X = FPoints[1].X) and (P1.Y = FPoints[1].Y) and (P3.X = FPoints[3].X) and (P3.Y = FPoints[3].Y) then Exit; FPoints[1] := P1; FPoints[3] := P3; if ArrowType = fcaArrow then begin DX := P3.X - P1.X; DY := P3.Y - P1.Y; if (IsRect = 2) and (DX <> 0) then DY := 0; if (IsRect = 3) and (DY <> 0) then DX := 0; if (DX = 0) or (DY = 0) then DXY := Abs(DX + DY) else DXY := Round(Sqrt(DX * DX + DY * DY)); if DXY = 0 then DXY := 1; FPoints[0].X := FRealWidth; FPoints[0].Y := (FRealHeight + 1) shr 1; FPoints[2].X := FRealWidth; FPoints[2].Y := -FPoints[0].Y; Rotate(FPoints[0]); Rotate(FPoints[2]); end; end; procedure TdxFcConnectionArrow.OffsetPoints(DX, DY: Integer); var I: Integer; begin if not Active then Exit; for I := 0 to 3 do begin Inc(FPoints[I].X, DX); Inc(FPoints[I].Y, DY); end; end; procedure TdxFcConnectionArrow.Assign(Source: TPersistent); begin if Source is TdxFcConnectionArrow then with TdxFcConnectionArrow(Source) do begin Self.Width := Width; Self.Height := Height; Self.Color := Color; Self.ArrowType := ArrowType; end else inherited Assign(Source); end; procedure TdxFcConnectionArrow.Paint; var DC: HDC; R: TRect; begin if not Active then Exit; DC := Owner.Owner.Canvas.Handle; if ArrowType = fcaArrow then Polyline(DC, FPoints, 3) else begin R := DisplayRect(False); InitBrush(FBrush, Color); SelectObject(DC, FBrush.Handle); if ArrowType = fcaRectangle then Rectangle(DC, R.Left, R.Top, R.Right, R.Bottom) else Ellipse(DC, R.Left, R.Top, R.Right, R.Bottom); end; end; {TdxFcConnection} constructor TdxFcConnection.Create(AOwner: TdxCustomFlowChart); begin inherited Create(AOwner); FPoints := TList.Create; FRealPoints := TList.Create; FPen := TPen.Create; FArrowSource := TdxFcConnectionArrow.Create(Self); FArrowDest := TdxFcConnectionArrow.Create(Self); AOwner.FConnections.Add(Self); end; destructor TdxFcConnection.Destroy; var Resize: Boolean; begin Owner.Delete(Self); //Update linked objects for dest and source object. Resize := not ((ObjectSource <> nil) and ObjectSource.Destroying or (ObjectDest <> nil) and ObjectDest.Destroying); SetObjectSource(nil, 0); SetObjectDest(nil, 0); FPoints.Free; FRealPoints.Free; FPen.Free; FArrowSource.Free; FArrowDest.Free; Owner.FConnections.Remove(Self); if Resize then Owner.SetChartSizes; inherited Destroy; end; function TdxFcConnection.IndexValid(var Index: Integer; AMax: Integer): Boolean; begin Result := (Index >= 0) and (Index <= PointCount - AMax); if ObjectSource <> nil then Inc(Index); end; function TdxFcConnection.GetPoint(Index: Integer): TPoint; begin if not IndexValid(Index, 1) then Result := Point(0, 0) else Result := InternalGetPoint(FPoints, Index); end; function TdxFcConnection.GetRealPoint(Index: Integer): TPoint; begin if not IndexValid(Index, 1) then Result := Point(0, 0) else Result := InternalGetPoint(FRealPoints, Index); end; function TdxFcConnection.InternalGetPoint(List: TList; Index: Integer): TPoint; begin Index := Index shl 1; Result.X := Integer(List[Index]); Result.Y := Integer(List[Index + 1]); end; procedure TdxFcConnection.InternalInsertPoint(List: TList; Index: Integer; Value: TPoint); begin Index := Index shl 1; List.Insert(Index, Pointer(Value.X)); List.Insert(Index + 1, Pointer(Value.Y)); end; procedure TdxFcConnection.InternalPutPoint(List: TList; Index: Integer; Value: TPoint); begin Index := Index shl 1; List[Index] := Pointer(Value.X); List[Index + 1] := Pointer(Value.Y); end; procedure TdxFcConnection.InternalRemovePoint(List: TList; Index: Integer); begin Index := Index shl 1; List.Delete(Index); List.Delete(Index); end; procedure TdxFcConnection.PutPoint(Index: Integer; Value: TPoint); begin if IndexValid(Index, 1) then begin ConnectionChanged; InternalPutPoint(FPoints, Index, Value); Owner.ScalePoint(Value); InternalPutPoint(FRealPoints, Index, Value); SetDisplayRect; Changed; Owner.SetChartSizes; end; end; function TdxFcConnection.RealCount: Integer; begin Result := FRealPoints.Count shr 1; end; function TdxFcConnection.GetPointCount: Integer; begin Result := RealCount; if ObjectSource <> nil then Dec(Result); if ObjectDest <> nil then Dec(Result); end; function TdxFcConnection.SelList: TList; begin Result := Owner.FSelConnections; end; procedure TdxFcConnection.AddPoint(Pt: TPoint); begin InsertPoint(PointCount, Pt); end; procedure TdxFcConnection.InsertPoint(Index: Integer; Pt: TPoint); begin if IndexValid(Index, 0) then begin ConnectionChanged; InternalInsertPoint(FPoints, Index, Pt); Owner.ScalePoint(Pt); InternalInsertPoint(FRealPoints, Index, Pt); SetDisplayRect; Changed; Owner.SetChartSizes; end; end; procedure TdxFcConnection.RemovePoint(Index: Integer); begin if IndexValid(Index, 1) then begin ConnectionChanged; InternalRemovePoint(FPoints, Index); InternalRemovePoint(FRealPoints, Index); SetDisplayRect; Changed; Owner.SetChartSizes; end; end; function TdxFcConnection.GetColor: TColor; begin Result := FPen.Color; end; function TdxFcConnection.GetPenStyle: TPenStyle; begin Result := FPen.Style; end; function TdxFcConnection.GetPenWidth: Integer; begin Result := FPen.Width; end; procedure TdxFcConnection.SetPenStyle(Value: TPenStyle); begin if (FPen.Style <> Value) then begin FPen.Style := Value; ConnectionChanged; Changed; end; end; procedure TdxFcConnection.SetPenWidth(Value: Integer); begin if PenWidth <> Value then begin FPen.Width := Value; ConnectionChanged; Changed; end; end; procedure TdxFcConnection.SetStyle(Value: TdxFclStyle); begin if (FStyle <> Value) then begin if (ArrowSource.ArrowType = fcaArrow) or (ArrowDest.ArrowType = fcaArrow) then ConnectionChanged; FStyle := Value; ArrowSource.ClearPoints; ArrowDest.ClearPoints; SetDisplayRect; Changed; end; end; procedure TdxFcConnection.SetText(Value: string); begin if (FText <> Value) then begin if Text <> '' then InvalidateText; FText := Value; if Text <> '' then begin SetTextRect; PlaceText; InvalidateText; end; Changed; Owner.SetChartSizes; end; end; procedure TdxFcConnection.SetColor(Value: TColor); begin if (Color <> Value) then begin FPen.Color := Value; ConnectionChanged; Changed; end; end; procedure TdxFcConnection.SetTransparent(Value: Boolean); begin if (FTransparent <> Value) then begin FTransparent := Value; ConnectionChanged; Changed; end; end; procedure TdxFcConnection.SetArrowSource(Value: TdxFcConnectionArrow); begin ArrowSource.Assign(Value); end; procedure TdxFcConnection.SetArrowDest(Value: TdxFcConnectionArrow); begin ArrowDest.Assign(Value); end; function TdxFcConnection.DisplayRect: TRect; begin Result := FDisplayRect; if Text <> '' then UnionRect(Result, Result, FTextRect); if ArrowSource.Active then UnionRect(Result, Result, ArrowSource.DisplayRect(True)); if ArrowDest.Active then UnionRect(Result, Result, ArrowDest.DisplayRect(True)); OffsetRect(Result, -Owner.LeftEdge, -Owner.TopEdge); end; procedure TdxFcConnection.IsRepainted; var R: TRect; begin FRepainted := FPoints.Count > 2; if not FRepainted then Exit; R := DisplayRect; ExtSelRect(R, Selected); FRepainted := RectVisible(Owner.Canvas.Handle, R) or (csPaintCopy in Owner.ControlState); {paul} end; procedure TdxFcConnection.InvalidateText; var R: TRect; begin if FPoints.Count <= 2 then Exit; Owner.FRepaint := True; if Owner.CanPaint then begin R := FTextRect; OffsetRect(R, -Owner.LeftEdge, -Owner.TopEdge); InvalidateRect(Owner.Handle, @R, True); end; end; procedure TdxFcConnection.ConnectionChanged; var R: TRect; begin if FPoints.Count <= 2 then Exit; Owner.FRepaint := True; ArrowSource.SetPoints(0); ArrowDest.SetPoints(RealCount - 1); if Owner.CanPaint then begin R := DisplayRect; ExtSelRect(R, Selected); InvalidateRect(Owner.Handle, @R, True); end; end; procedure TdxFcConnection.Invalidate; begin ConnectionChanged; end; procedure TdxFcConnection.PlaceText; var DX, DY: Integer; begin with FTextRect do begin DX := FMassCenter.X - (Right + Left) div 2; DY := FMassCenter.Y - (Bottom + Top) div 2; end; OffsetRect(FTextRect, DX, DY); end; procedure TdxFcConnection.SetDisplayRect; var I: Integer; begin Owner.FHitTest := []; if Destroying or (FPoints.Count < 2) then Exit; FDisplayRect.TopLeft := InternalGetPoint(FRealPoints, 0); FDisplayRect.BottomRight := FDisplayRect.TopLeft; for I := 1 to RealCount - 1 do ExtendRect(FDisplayRect, InternalGetPoint(FRealPoints, I)); FMassCenter := LineCenter(TLineType(Style), FRealPoints.List^, RealCount); Inc(FDisplayRect.Right); Inc(FDisplayRect.Bottom); if Text <> '' then PlaceText; ConnectionChanged; end; procedure TdxFcConnection.SetTextRect; var DC: HDC; begin Owner.FHitTest := []; FTextRect := Rect(0, 0, 0, 0); DC := GetDC(0); SelectObject(DC, RealFont.Handle); DrawText(DC, PChar(Text), -1, FTextRect, DT_CALCRECT); ReleaseDC(0, DC); end; procedure TdxFcConnection.FontChanged; begin InvalidateText; SetTextRect; PlaceText; InvalidateText; Owner.SetChartSizes; end; procedure TdxFcConnection.ZoomChanged; var J: Integer; P: TPoint; begin for J := 0 to RealCount - 1 do begin P := InternalGetPoint(FPoints, J); Owner.ScalePoint(P); InternalPutPoint(FRealPoints, J, P); end; ArrowSource.SetRealBounds; ArrowDest.SetRealBounds; SetObjectPoints; ScaleFont; if Text <> '' then SetTextRect; SetDisplayRect; end; procedure TdxFcConnection.SetObjectPoints; procedure SetPoint(AObj: TdxFcObject; Arrow: TdxFcConnectionArrow; PtIndex, ListIndex: Integer); var P: TPoint; begin P := AObj.LinkedPoints[PtIndex]; InternalPutPoint(FRealPoints, ListIndex, P); Arrow.SetPoints(ListIndex); end; begin if Destroying or (FPoints.Count < 2) then Exit; if ObjectSource <> nil then SetPoint(ObjectSource, ArrowSource, FPointSource, 0); if ObjectDest <> nil then SetPoint(ObjectDest, ArrowDest, FPointDest, RealCount - 1); end; procedure TdxFcConnection.DelObj(AObj, Partneur: TdxFcObject; Index: Integer); begin if Partneur <> nil then begin AObj.FLinkedObjects.Remove(Partneur); Partneur.FLinkedObjects.Remove(AObj); end; AObj.FConnections.Remove(Self); InternalRemovePoint(FPoints, Index); InternalRemovePoint(FRealPoints, Index); end; procedure TdxFcConnection.InsObj(AObj, Partneur: TdxFcObject; Index: Integer); begin if Partneur <> nil then begin AObj.FLinkedObjects.Add(Partneur); Partneur.FLinkedObjects.Add(AObj); end; AObj.FConnections.Add(Self); InternalInsertPoint(FPoints, Index, Point(0, 0)); InternalInsertPoint(FRealPoints, Index, Point(0, 0)); end; procedure TdxFcConnection.SetObjectSource(AObject: TdxFcObject; APoint: Byte); begin if (AObject = ObjectSource) and (APoint = FPointSource) then Exit; ConnectionChanged; if AObject <> ObjectSource then begin if ObjectSource <> nil then DelObj(ObjectSource, ObjectDest, 0); if AObject <> nil then InsObj(AObject, ObjectDest, 0); FObjectSource := AObject; end; FPointSource := APoint; SetObjectPoints; SetDisplayRect; Changed; end; procedure TdxFcConnection.SetObjectDest(AObject: TdxFcObject; APoint: Byte); begin if (AObject = ObjectDest) and (APoint = FPointDest) then Exit; ConnectionChanged; if AObject <> ObjectDest then begin if ObjectDest <> nil then DelObj(ObjectDest, ObjectSource, RealCount - 1); if AObject <> nil then InsObj(AObject, ObjectSource, RealCount); FObjectDest := AObject; end; FPointDest := APoint; SetObjectPoints; SetDisplayRect; Changed; end; function TdxFcConnection.ScreenPoint(Index: Integer): TPoint; begin Result := InternalGetPoint(FRealPoints, Index); Dec(Result.X, Owner.LeftEdge); Dec(Result.Y, Owner.TopEdge); end; function TdxFcConnection.HasPoint(X, Y: Integer): Boolean; begin Result := PtOnLine(TLineType(Style), FRealPoints.List^, RealCount, Screen.Width shr 8, X, Y); end; function TdxFcConnection.InRect(const R: TRect): Boolean; var R1: TRect; begin R1 := R; OffsetRect(R1, Owner.LeftEdge, Owner.TopEdge); Result := RectOnLine(TLineType(Style), FRealPoints.List^, RealCount, R1); end; function TdxFcConnection.GetNearestPoint(X, Y: Integer): Integer; var I, Cur, Min: Integer; begin Result := 0; Min := $7FFFFFFF; Inc(X, Owner.LeftEdge); Inc(Y, Owner.TopEdge); for I := 0 to RealCount - 1 do begin Cur := QDistance(X, Y, InternalGetPoint(FRealPoints, I)); if Cur < Min then begin Min := Cur; Result := I; end; end; if ObjectSource <> nil then Dec(Result); end; procedure TdxFcConnection.ArrowChanged(Value: TdxFcConnectionArrow); begin //TODO optimized the drawing if Value = ArrowSource then Value.SetPoints(0); if Value = ArrowDest then Value.SetPoints(RealCount - 1); ConnectionChanged; end; procedure TdxFcConnection.OffsetPoints(List: TList; DX, DY: Integer); var I, X, Y: Integer; begin for I := 0 to RealCount - 1 do begin X := Integer(List[I shl 1]) + DX; Y := Integer(List[I shl 1 + 1]) + DY; List[I shl 1] := Pointer(X); List[I shl 1 + 1] := Pointer(Y); end; if List = FRealPoints then begin ArrowSource.OffsetPoints(DX, DY); ArrowDest.OffsetPoints(DX, DY); end; end; procedure TdxFcConnection.NewPoint(X, Y: Integer; Handler: TdxFcDragHandler); var I: Integer; P0, P1, P2: TPoint; begin I := PointIndex + 1; if (I <= 0) or (I >= RealCount) then begin I := GetNearestPoint(X, Y); if ObjectSource <> nil then Inc(I); if I = 0 then Inc(I) else if I < RealCount - 1 then begin P0 := ScreenPoint(I); P1 := ScreenPoint(I - 1); P2 := ScreenPoint(I + 1); Dec(P0.X, X); Dec(P0.Y, Y); Dec(P1.X, X); Dec(P1.Y, Y); Dec(P2.X, X); Dec(P2.Y, Y); if (P0.X * P2.X) + (P0.Y * P2.Y) < (P0.X * P1.X) + (P0.Y * P1.Y) then Inc(I); end; end; P0 := Owner.ChartPoint(X, Y); InternalInsertPoint(FPoints, I, P0); Owner.ScalePoint(P0); InternalInsertPoint(FRealPoints, I, P0); Owner.FDragData.Index := I; Owner.FDragData.Connect := Self; ConnectionChanged; Owner.InitDrag(X, Y, Handler); end; function TdxFcConnection.RealStyle: TdxFclStyle; begin Result := Style; if (Result = fclCurved) and (RealCount < 3) then Result := fclStraight; end; procedure TdxFcConnection.InvertColor; begin FPen.Color := (ColorToRGB(Color) xor not ColorToRGB(Owner.Color)) and $FFFFFF; end; procedure TdxFcConnection.PaintLine(DC: HDC); begin case RealStyle of fclStraight: Polyline(DC, FRealPoints.List^, RealCount); fclCurved: QSpline(DC, FRealPoints.List^, RealCount); fclRectH: RectHLine(DC, FRealPoints.List^, RealCount); fclRectV: RectVLine(DC, FRealPoints.List^, RealCount); end; end; procedure TdxFcConnection.Paint(Upper: Boolean); var DC: HDC; R: TRect; begin if FRepainted and (Transparent xor Upper) then begin OffsetPoints(FRealPoints, -Owner.LeftEdge, -Owner.TopEdge); DC := Owner.Canvas.Handle; SelectObject(DC, FPen.Handle); PaintLine(DC); ArrowSource.Paint; ArrowDest.Paint; OffsetPoints(FRealPoints, Owner.LeftEdge, Owner.TopEdge); if Text <> '' then begin R := FTextRect; OffsetRect(R, -Owner.LeftEdge, -Owner.TopEdge); SelectObject(DC, RealFont.Handle); SetTextColor(DC, ColorToRGB(RealFont.Color)); DrawText(DC, PChar(Text), -1, R, DT_CENTER); end; end; end; procedure TdxFcConnection.Assign(Source: TPersistent); var I: Integer; begin if Source is TdxFcConnection then with TdxFcConnection(Source) do begin if Self.PointCount > 0 then Self.RemovePoint(0); Self.FPoints.Clear; Self.FRealPoints.Clear; Self.SetObjectSource(ObjectSource, PointSource); Self.SetObjectDest(ObjectDest, PointDest); Self.ArrowSource := ArrowSource; Self.ArrowDest := ArrowDest; Self.Color := Color; Self.Transparent := Transparent; for I := 0 to PointCount - 1 do Self.AddPoint(Points[I]); Self.PenStyle := PenStyle; Self.PenWidth := PenWidth; Self.Style := Style; end; inherited Assign(Source); end; procedure TdxFcConnection.Load(Stream: TStream; AIsUnicode: Boolean); procedure SetArrow(Arrow: TdxFcConnectionArrow; const AData: TdxFcArwData); begin with Arrow do begin Width := AData.Width; Height := AData.Height; Color := AData.Color; ArrowType := AData.AType; end; end; var P: TPoint; ConData: TdxFcConData; begin Stream.ReadBuffer(ConData, SizeOf(ConData)); with ConData do begin Self.Style := Style; Self.Color := Color; ParentFont := ParFont; Transparent := PtDst and $80 <> 0; PenStyle := TPenStyle(PtSrc shr 4); PtDst := PtDst and $7F; PtSrc := PtSrc and $0F; SetObjectSource(Owner.Objects[ObjSrc], PtSrc); SetObjectDest(Owner.Objects[ObjDst], PtDst); while PtCount > 0 do begin Stream.ReadBuffer(P, SizeOf(P)); InternalInsertPoint(FPoints, PointCount + Ord(ObjectSource <> nil), P); Owner.ScalePoint(P); InternalInsertPoint(FRealPoints, PointCount + Ord(ObjectSource <> nil), P); Dec(PtCount); end; SetArrow(ArrowSource, ArwSrc); SetArrow(ArrowDest, ArwDst); end; SetDisplayRect; LoadFont(Stream, AIsUnicode); Text := ReadStr(Stream, AIsUnicode); end; procedure TdxFcConnection.Save(Stream: TStream); procedure ReadArrow(Arrow: TdxFcConnectionArrow; var AData: TdxFcArwData); begin with Arrow do begin AData.AType := ArrowType; AData.Width := Width; AData.Height := Height; AData.Color := Color; end; end; var I: Integer; P: TPoint; ConData: TdxFcConData; begin with ConData do begin if ObjectSource = nil then ObjSrc := -1 else ObjSrc := ObjectSource.ZOrder; if ObjectDest = nil then ObjDst := -1 else ObjDst := ObjectDest.ZOrder; PtCount := Word(PointCount); Color := Self.Color; PtSrc := FPointSource; PtDst := FPointDest; Style := Self.Style; ParFont := ParentFont; PtSrc := PtSrc or Ord(PenStyle) shl 4; if Transparent then PtDst := PtDst or $80; ReadArrow(ArrowSource, ArwSrc); ReadArrow(ArrowDest, ArwDst); end; Stream.WriteBuffer(ConData, SizeOf(ConData)); for I := 0 to PointCount - 1 do begin P := Points[I]; Stream.WriteBuffer(P, SizeOf(P)); end; SaveFont(Stream); WriteStr(Stream, Text); end; {TdxCustomFlowChart} constructor TdxCustomFlowChart.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle - [csCaptureMouse]; Width := 320; Height := 200; ParentColor := False; TabStop := True; FObjects := TList.Create; FConnections := TList.Create; FSelObjects := TList.Create; FSelConnections := TList.Create; FSelection := TdxFcSelection.Create(Self); FZoom := 100; FRealZoom := 100; FOptions := [fcoCanDelete, fcoCanDrag, fcoCanSelect, fcoMultiSelect, fcoHideSelection, fcoDelOnClick]; FBorderStyle := bsSingle; FChangeLink := TChangeLink.Create; FChangeLink.OnChange := OnChangeLink; end; destructor TdxCustomFlowChart.Destroy; begin OnDeletion := nil; OnSelected := nil; Clear; FObjects.Free; FConnections.Free; FSelObjects.Free; FSelConnections.Free; FSelection.Free; FChangeLink.Free; inherited Destroy; end; procedure TdxCustomFlowChart.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.WindowClass.Style := Params.WindowClass.Style and not (CS_HREDRAW or CS_VREDRAW); Params.Style := Params.Style or WS_TABSTOP or WS_HSCROLL or WS_VSCROLL; if BorderStyle = bsSingle then if Ctl3D then Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE else Params.Style := Params.Style or WS_BORDER; end; procedure TdxCustomFlowChart.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) and (AComponent = FImages) then Images := nil; end; function TdxCustomFlowChart.GetConnection(Index: Integer): TdxFcConnection; begin Result := TdxFcConnection(GetListItem(FConnections, Index)); end; function TdxCustomFlowChart.GetObjectValue(Index: Integer): TdxFcObject; begin Result := TdxFcObject(GetListItem(FObjects, Index)); end; function TdxCustomFlowChart.GetConnectionCount: Integer; begin Result := FConnections.Count; end; function TdxCustomFlowChart.GetObjectCount: Integer; begin Result := FObjects.Count; end; function TdxCustomFlowChart.GetSelectedObject(Index: Integer): TdxFcObject; begin Result := TdxFcObject(GetListItem(FSelObjects, Index)); end; function TdxCustomFlowChart.GetSelectedObjectCount: Integer; begin Result := FSelObjects.Count; end; function TdxCustomFlowChart.GetSelectedConnection(Index: Integer): TdxFcConnection; begin Result := TdxFcConnection(GetListItem(FSelConnections, Index)); end; function TdxCustomFlowChart.GetSelectedConnectionCount: Integer; begin Result := FSelConnections.Count; end; function TdxCustomFlowChart.SelCount: Integer; begin Result := FSelObjects.Count + FSelConnections.Count; end; procedure TdxCustomFlowChart.SetBorderStyle(Value: TBorderStyle); begin if Value <> BorderStyle then begin FBorderStyle := Value; RecreateWnd; end; end; procedure TdxCustomFlowChart.SetImages(Value: TImageList); begin if (FImages <> Value) then begin if (FImages <> nil) and not (csDestroying in FImages.ComponentState) then FImages.UnRegisterChanges(FChangeLink); FImages := Value; if (FImages <> nil) then begin FImages.RegisterChanges(FChangeLink); FImages.FreeNotification(Self); end; if not (csDestroying in ComponentState) then NeedRepaint; end; end; procedure TdxCustomFlowChart.SetOptions(Value: TdxFcOptions); const Sel: TdxFcOptions = [fcoCanSelect, fcoMultiSelect]; var NewOpts: TdxFcOptions; begin if (Options <> Value) then begin NewOpts := (Options + Value) - (Options * Value); FOptions := Value; if (NewOpts * Sel <> []) and (Options * Sel <> Sel) then ClearSelection; if (fcoHideSelection in NewOpts) and not Focused then InvalidateSel; end; end; procedure TdxCustomFlowChart.SetConnection(Index: Integer; Value: TdxFcConnection); begin Connections[Index].Assign(Value); end; procedure TdxCustomFlowChart.SetObjectValue(Index: Integer; Value: TdxFcObject); begin Objects[Index].Assign(Value); end; procedure TdxCustomFlowChart.SetZoom(Value: Word); var W, H: Integer; begin if Value = Zoom then Exit; FZoom := Value; if Value <> 0 then FRealZoom := Value else begin FZoom := $FFFF; W := MulDiv(FChartWidth, 100, RealZoom); H := MulDiv(FChartHeight, 100, RealZoom); if ClientWidth * H <= ClientHeight * W then FRealZoom := MulDiv(ClientWidth, 95, W) else FRealZoom := MulDiv(ClientHeight, 95, H); if RealZoom > 100 then FRealZoom := 100; if FRealZoom = 0 then FRealZoom := 1; end; CalculateRealPos; end; procedure TdxCustomFlowChart.ScalePoint(var P: TPoint); begin P.X := MulDiv(P.X, RealZoom, 100); P.Y := MulDiv(P.Y, RealZoom, 100); end; function TdxCustomFlowChart.ChartPoint(X, Y: Integer): TPoint; begin Result.X := MulDiv(X + LeftEdge, 100, RealZoom); Result.Y := MulDiv(Y + TopEdge, 100, RealZoom); end; procedure TdxCustomFlowChart.CalculateRealPos; var I: Integer; begin BeginUpdate; for I := 0 to ObjectCount - 1 do Objects[I].ZoomChanged; for I := 0 to ConnectionCount - 1 do Connections[I].ZoomChanged; FRepaint := True; EndUpdate; end; procedure TdxCustomFlowChart.OnChangeLink(Sender: TObject); begin NeedRepaint; end; function TdxCustomFlowChart.InternalCreateObject: TdxFcObject; begin Result := TdxFcObject.Create(Self); end; function TdxCustomFlowChart.InternalCreateConnection: TdxFcConnection; begin Result := TdxFcConnection.Create(Self); end; function TdxCustomFlowChart.CreateObject(L, T, W, H: Integer; AShape: TdxFcShapeType): TdxFcObject; begin Result := InternalCreateObject; if Assigned(OnCreateItem) then OnCreateItem(Self, Result); with Result do begin FShapeType := AShape; SetBounds(L, T, W, H); end; end; function TdxCustomFlowChart.CreateConnection(OSrc, ODst: TdxFcObject; PSrc, PDst: Byte): TdxFcConnection; begin Result := InternalCreateConnection; if Assigned(OnCreateItem) then OnCreateItem(Self, Result); with Result do begin SetObjectSource(OSrc, PSrc); SetObjectDest(ODst, PDst); end; end; procedure TdxCustomFlowChart.DeleteObject(AObject: TdxFcObject); begin AObject.Free; end; procedure TdxCustomFlowChart.DeleteConnection(AConnection: TdxFcConnection); begin AConnection.Free; end; procedure TdxCustomFlowChart.Clear; begin if ObjectCount + ConnectionCount = 0 then Exit; BeginUpdate; FSelConnections.Clear; FSelObjects.Clear; while ConnectionCount > 0 do Connections[0].Free; while ObjectCount > 0 do Objects[0].Free; EndUpdate; end; procedure TdxCustomFlowChart.ClearSelection; begin while SelectedConnectionCount > 0 do SelectedConnections[0].Selected := False; while SelectedObjectCount > 0 do SelectedObjects[0].Selected := False; end; procedure TdxCustomFlowChart.DeleteSelection; begin while SelectedConnectionCount > 0 do SelectedConnections[0].Free; while SelectedObjectCount > 0 do SelectedObjects[0].Free; end; procedure TdxCustomFlowChart.SelectAll; var I: Integer; begin for I := 0 to ObjectCount - 1 do Objects[I].Selected := True; for I := 0 to ConnectionCount - 1 do Connections[I].Selected := True; end; function TdxCustomFlowChart.GetSelConnect: TdxFcConnection; begin if (SelectedObjectCount = 0) and (SelectedConnectionCount = 1) then Result := SelectedConnections[0] else Result := nil; end; function TdxCustomFlowChart.GetSelObj: TdxFcObject; begin if (SelectedObjectCount = 1) and (SelectedConnectionCount = 0) then Result := SelectedObjects[0] else Result := nil; end; procedure TdxCustomFlowChart.SetSelConnect(Value: TdxFcConnection); begin if Value <> SelectedConnection then begin ClearSelection; if Value <> nil then Value.Selected := True; end; end; procedure TdxCustomFlowChart.SetSelObj(Value: TdxFcObject); begin if Value <> SelectedObject then begin ClearSelection; if Value <> nil then Value.Selected := True; end; end; function TdxCustomFlowChart.CanPaint: Boolean; begin Result := (FLockUpdates = 0) and HandleAllocated; end; procedure TdxCustomFlowChart.NeedRepaint; begin FRepaint := True; if CanPaint then Invalidate; end; procedure TdxCustomFlowChart.NeedRepaintObject(AObject: TdxFcObject); var R: TRect; begin FRepaint := True; if CanPaint then begin R := AObject.DisplayRect; ExtSelRect(R, AObject.Selected); InvalidateRect(Handle, @R, True); end; end; procedure TdxCustomFlowChart.BeginUpdate; begin if FLockUpdates = 0 then FRepaint := False; Inc(FLockUpdates); end; procedure TdxCustomFlowChart.CancelUpdate; begin if FLockUpdates <> 0 then Dec(FLockUpdates); end; procedure TdxCustomFlowChart.EndUpdate; begin if FLockUpdates > 0 then begin Dec(FLockUpdates); if FLockUpdates = 0 then begin if FRepaint then NeedRepaint; SetChartSizes; end; end; end; procedure TdxCustomFlowChart.Invalidate; begin if FLockUpdates > 0 then FRepaint := True else inherited Invalidate; end; procedure TdxCustomFlowChart.InvalidateSel; var I: Integer; begin for I := 0 to SelectedObjectCount - 1 do NeedRepaintObject(SelectedObjects[I]); for I := 0 to SelectedConnectionCount - 1 do SelectedConnections[I].ConnectionChanged; end; function TdxCustomFlowChart.HasSelection: Boolean; begin Result := Focused or not (fcoHideSelection in Options); end; procedure TdxCustomFlowChart.AddSelectedObject(AObject: TdxFcObject); var I: Integer; P: array[0..7] of TPoint; begin if not AObject.FRepainted then Exit; AObject.SelPoints(P); for I := 0 to 7 do FSelection.AddPoint(P[I].X, P[I].Y); end; procedure TdxCustomFlowChart.AddSelectedConnection(AConnection: TdxFcConnection); var I: Integer; P: TPoint; begin with AConnection do begin if not FRepainted then Exit; for I := 0 to RealCount - 1 do begin P := InternalGetPoint(FRealPoints, I); FSelection.AddPoint(P.X, P.Y); end; end; end; procedure TdxCustomFlowChart.Paint; var I: Integer; ClipRgn: HRgn; DC: hDC; // Fix: by Paul Pt: TPoint; // Fix: by Paul R: TRect; // Fix: by Paul begin FSelection.Clear; ClipRgn := CreateRectRgn(0, 0, 0, 0); for I := ObjectCount - 1 downto 0 do Objects[I].IsRepainted(ClipRgn); for I := 0 to ConnectionCount - 1 do Connections[I].IsRepainted; if HasSelection then begin for I := 0 to SelectedObjectCount - 1 do AddSelectedObject(SelectedObjects[I]); for I := 0 to SelectedConnectionCount - 1 do AddSelectedConnection(SelectedConnections[I]); end; DC := Canvas.Handle; // Fix: by Paul GetWindowOrgEx(DC, Pt); // Fix: by Paul if (Pt.X <> 0) or (Pt.Y <> 0) then OffsetRgn(ClipRgn, -Pt.X, -Pt.Y); // Fix: by Paul if not (csPaintCopy in ControlState) then // Fix: by Paul ExtSelectClipRgn(DC, ClipRgn, RGN_DIFF); Windows.GetClientRect(Handle, R); // Fix: by Paul if (Pt.X <> 0) or (Pt.Y <> 0) then OffsetRect(R, Pt.X, Pt.Y); // Fix: by Paul if not (csPaintCopy in ControlState) then // Fix: by Paul FillRect(DC, R, Brush.Handle); SetBkMode(DC, TRANSPARENT); for I := 0 to ConnectionCount - 1 do Connections[I].Paint(False); for I := 0 to ObjectCount - 1 do with Objects[I] do begin if (FPaintRgn <> 0) and (Pt.X <> 0) or (Pt.Y <> 0) then // Fix: by Paul OffsetRgn(FPaintRgn, -Pt.X, -Pt.Y); // Fix: by Paul Paint; // Fix: by Paul if (FPaintRgn <> 0) and (Pt.X <> 0) or (Pt.Y <> 0) then // Fix: by Paul OffsetRgn(FPaintRgn, Pt.X, Pt.Y); // Fix: by Paul end; // Fix: by Paul for I := 0 to ConnectionCount - 1 do Connections[I].Paint(True); if FSelection.Counts.Count > 0 then FSelection.Paint; Windows.DeleteObject(ClipRgn); end; procedure TdxCustomFlowChart.DefaultDrawObject(AObject: TdxFcObject; R: TRect); begin with AObject do begin if HasImage then PaintImage(R); if Text <> '' then PaintText(R); end; end; procedure TdxCustomFlowChart.UpdateScrollRange; var NewX, NewY: Integer; Info: TScrollInfo; function SetScr(Code, Page, Min, Max: Integer): Integer; begin with Info do begin cbSize := SizeOf(Info); fMask := SIF_ALL; GetScrollInfo(Handle, Code, Info); Result := nPos; fMask := SIF_PAGE or SIF_RANGE; nMin := Min; nMax := Min + Max; nPage := Page; if (Zoom = 0) or (Zoom = $FFFF) then nPage := Max + 1; end; SetScrollInfo(Handle, Code, Info, True); end; begin if not HandleAllocated then Exit; NewX := SetScr(SB_HORZ, ClientWidth, FChartLeft, FChartWidth); NewY := SetScr(SB_VERT, ClientHeight, FChartTop, FChartHeight); SetLeftTop(NewX, NewY); end; procedure TdxCustomFlowChart.SetLeftTop(ALeft, ATop: Integer); procedure Adjust(Min, Max: Integer; var Value: Integer); begin if Value > Max then Value := Max; if Value < Min then Value := Min; end; var I, DX, DY: Integer; begin Adjust(FChartLeft, FChartLeft + FChartWidth - ClientWidth, ALeft); Adjust(FChartTop, FChartTop + FChartHeight - ClientHeight, ATop); if (ALeft = LeftEdge) and (ATop = TopEdge) then Exit; DX := LeftEdge - ALeft; DY := TopEdge - ATop; FLeftEdge := ALeft; FTopEdge := ATop; if not HandleAllocated then Exit; ScrollWindow(Handle, DX, DY, nil, nil); if DX <> 0 then SetScrollPos(Handle, SB_HORZ, ALeft, True); if DY <> 0 then SetScrollPos(Handle, SB_VERT, ATop, True); for I := 0 to ObjectCount - 1 do if Objects[I].FIntRgn <> 0 then begin OffsetRgn(Objects[I].FExtRgn, DX, DY); OffsetRgn(Objects[I].FIntRgn, DX, DY); end; end; procedure TdxCustomFlowChart.SetChartSizes; var I: Integer; OldR, NewR: TRect; procedure SetXY(R: TRect); begin OffsetRect(R, LeftEdge, TopEdge); ExtendRect(NewR, R.TopLeft); ExtendRect(NewR, R.BottomRight); end; begin if (FLockUpdates > 0) or (csDestroying in ComponentState) then Exit; OldR := Bounds(FChartLeft, FChartTop, FChartWidth, FChartHeight); NewR := Rect(0, 0, 0, 0); for I := 0 to ObjectCount - 1 do SetXY(Objects[I].DisplayRect); for I := 0 to ConnectionCount - 1 do SetXY(Connections[I].DisplayRect); if not EqualRect(OldR, NewR) then with NewR do begin FChartLeft := Left; FChartTop := Top; FChartWidth := Right - Left; FChartHeight := Bottom - Top; if Zoom = 0 then begin FZoom := RealZoom; SetZoom(0); end; UpdateScrollRange; end; if Zoom = $FFFF then FZoom := 0; end; procedure TdxCustomFlowChart.SetLeftEdge(Value: Integer); begin if Value <> LeftEdge then SetLeftTop(Value, TopEdge); end; procedure TdxCustomFlowChart.SetTopEdge(Value: Integer); begin if Value <> TopEdge then SetLeftTop(LeftEdge, Value); end; procedure TdxCustomFlowChart.HitTest(X, Y: Integer); const Con: TdxFcHitTest = [htOnConnection, htOnConLabel, htOnArrowSrc, htOnArrowDst]; var I, Q: Integer; R: TRect; P: array[0..7] of TPoint; function OnSelPoint(Idx: Integer): Boolean; begin if (X >= P[Idx].X - 2) and (X <= P[Idx].X + 2) and (Y >= P[Idx].Y - 2) and (Y <= P[Idx].Y + 2) then Include(FHitTest, htOnSelPoint); Result := htOnSelPoint in FHitTest; end; function OnArrow(Arrow: TdxFcConnectionArrow): Boolean; begin if Arrow.ArrowType = fcaNone then Result := False else Result := PtInRect(Arrow.DisplayRect(False), Point(X + LeftEdge, Y + TopEdge)); end; function BySel(Item: TdxFcItem): Boolean; begin Result := Item <> nil; if not Result then Exit; if Item is TdxFcObject then R := TdxFcObject(Item).DisplayRect else R := TdxFcConnection(Item).DisplayRect; ExtSelRect(R, True); Result := PtInRect(R, Point(X - LeftEdge, Y - TopEdge)); end; begin if (FHitTest <> []) and (X = FHitX) and (Y = FHitY) then Exit; FHitX := X; FHitY := Y; FHitTest := [htNowhere]; FObjectAt := nil; FConnectionAt := nil; for I := ObjectCount - 1 downto 0 do begin R := Objects[I].DisplayRect; ExtSelRect(R, True); if Objects[I].Visible and PtInRect(R, Point(X, Y)) then begin if FHitTest = [htNowhere] then begin FHitTest := [htByObject]; FObjectAt := Objects[I]; end; Objects[I].CreateRgn; if PtInRegion(Objects[I].FIntRgn, X, Y) then begin FHitTest := [htByObject, htOnObject]; FObjectAt := Objects[I]; Break; end; end; end; for I := ConnectionCount - 1 downto 0 do begin R := Connections[I].DisplayRect; ExtSelRect(R, True); if PtInRect(R, Point(X, Y)) then begin FConnectionAt := Connections[I]; if FHitTest = [htNowhere] then FHitTest := []; if FConnectionAt.HasPoint(X + LeftEdge, Y + TopEdge) then Include(FHitTest, htOnConnection); if OnArrow(FConnectionAt.ArrowSource) then Include(FHitTest, htOnArrowSrc); if OnArrow(FConnectionAt.ArrowDest) then Include(FHitTest, htOnArrowDst); if FConnectionAt.Text <> '' then begin R := FConnectionAt.FTextRect; OffsetRect(R, -LeftEdge, -TopEdge); if PtInRect(R, Point(X, Y)) then Include(FHitTest, htOnConLabel); end; if (FHitTest * Con <> []) then Break; end; end; if (htOnObject in FHitTest) and (FHitTest * Con <> []) then begin if not FConnectionAt.Transparent then Exclude(FHitTest, htOnObject) else FHitTest := FHitTest - Con; end; Inc(X, LeftEdge); Inc(Y, TopEdge); if BySel(SelectedObject) then begin SelectedObject.SelPoints(P); Q := SelectedObject.Quadrant(X, Y) shl 1 + 1; for I := Q to Q + 2 do if OnSelPoint(I and 7) then begin if FObjectAt <> SelectedObject then Exclude(FHitTest, htOnObject); FObjectAt := SelectedObject; Exit; end; end; if BySel(SelectedConnection) then for I := 0 to SelectedConnection.RealCount - 1 do begin with SelectedConnection do P[0] := InternalGetPoint(FRealPoints, I); if OnSelPoint(0) then begin if FConnectionAt <> SelectedConnection then FHitTest := FHitTest - Con; Include(FHitTest, htOnConnection); FConnectionAt := SelectedConnection; end; end; if FHitTest = [] then begin FHitTest := [htNowhere]; FConnectionAt := nil; end; end; function TdxCustomFlowChart.GetConnectionAt(X, Y: Integer): TdxFcConnection; begin HitTest(X, Y); Result := FConnectionAt; end; function TdxCustomFlowChart.GetObjectAt(X, Y: Integer): TdxFcObject; begin HitTest(X, Y); Result := FObjectAt; end; function TdxCustomFlowChart.GetHitTestAt(X, Y: Integer): TdxFcHitTest; begin HitTest(X, Y); Result := FHitTest; end; procedure TdxCustomFlowChart.ScrollChart(Bar, Code, Pos: Cardinal; Value, Page: Integer); begin case Code of SB_LINEDOWN: Value := Value + 16; SB_LINEUP: Value := Value - 16; SB_PAGEDOWN: Value := Value + Page - 16; SB_PAGEUP: Value := Value - Page + 16; SB_TOP: Value := TO_HOME; SB_BOTTOM: Value := TO_END; SB_THUMBTRACK, SB_THUMBPOSITION: Value := Pos; end; if Bar = SB_HORZ then SetLeftEdge(Value) else SetTopEdge(Value); end; function TdxCustomFlowChart.TmpSel: Integer; var I: Integer; Opt: TdxFcOptions; Sel1: TdxFcEvent; Sel2: TdxFcAllowEvent; begin Result := SelectedObjectCount; if Result = 0 then Exit; Opt := Options; FOptions := Opt + [fcoCanSelect, fcoMultiSelect]; Sel1 := OnSelected; OnSelected := nil; Sel2 := OnSelection; OnSelection := nil; Inc(FLockUpdates); for I := 0 to Result - 1 do SelectedObjects[I].SelectUnion; Dec(FLockUpdates); FOptions := Opt; OnSelected := Sel1; OnSelection := Sel2; end; procedure TdxCustomFlowChart.RestoreSel(Value: Integer); var I: Integer; begin for I := Value to SelectedObjectCount - 1 do SelectedObjects[I].FSelected := False; FSelObjects.Count := Value; end; procedure TdxCustomFlowChart.MoveObjects(DX, DY: Integer); function IsSel(AObject: TdxFcObject): Boolean; begin Result := (AObject <> nil) and AObject.Selected; end; var I, EndSel: Integer; P: TPoint; begin if (DX or DY = 0) or (SelectedObjectCount = 0) then Exit; P.X := DX; P.Y := DY; ScalePoint(P); EndSel := TmpSel; for I := 0 to SelectedObjectCount - 1 do begin NeedRepaintObject(SelectedObjects[I]); with SelectedObjects[I] do begin Inc(FLeft, DX); Inc(FTop, DY); SetRealBounds; Changed; end; NeedRepaintObject(SelectedObjects[I]); end; for I := 0 to ConnectionCount - 1 do with Connections[I] do if IsSel(ObjectSource) or IsSel(ObjectDest) then begin ConnectionChanged; if IsSel(ObjectSource) and IsSel(ObjectDest) then begin OffsetPoints(FPoints, DX, DY); OffsetPoints(FRealPoints, P.X, P.Y); end; SetObjectPoints; SetDisplayRect; Changed; end; RestoreSel(EndSel); SetChartSizes; end; procedure TdxCustomFlowChart.KeyDown(var Key: Word; Shift: TShiftState); procedure Resize(DX, DY: Integer); var W, H: Integer; begin if SelectedObject = nil then Exit; if RealZoom < 100 then begin DX := MulDiv(DX, 100, RealZoom); DY := MulDiv(DY, 100, RealZoom); end; with SelectedObject do begin W := Width + DX; H := Height + DY; if (W > 0) and (H > 0) then SetBounds(Left, Top, W, H); MakeVisible; end; end; procedure SelNext(Mode: Integer); var I, DX, DY, Rate, Min: Integer; Obj: TdxFcObject; begin if SelectedObject = nil then Exit; Obj := nil; Min := $20000000; for I := 0 to ObjectCount - 1 do begin if Objects[I].Selected or not Objects[I].Visible then Continue; DX := Objects[I].Left - SelectedObject.Left; DY := Objects[I].Top - SelectedObject.Top; if Mode > 1 then Swap(DX, DY); if Mode and 1 <> 0 then DX := -DX; Rate := Abs(DX) + Abs(DY) shl 3 + DX shr 2; if Rate < Min then begin Min := Rate; Obj := Objects[I]; end; end; if Obj <> nil then begin ClearSelection; Obj.Selected := True; if Obj.Selected then Obj.MakeVisible; end; end; begin if Assigned(FDragHandler) then Exit; inherited KeyDown(Key, Shift); if (Shift = [ssShift]) and (fcoCanDrag in Options) then case Key of VK_RIGHT: Resize(1, 0); VK_LEFT: Resize(-1, 0); VK_DOWN: Resize(0, 1); VK_UP: Resize(0, -1); VK_NEXT: Resize(1, 1); VK_PRIOR: Resize(1, -1); VK_HOME: Resize(-1, -1); VK_END: Resize(-1, 1); end; if (Shift = [ssAlt]) and (fcoCanDrag in Options) then case Key of VK_RIGHT: MoveObjects(1, 0); VK_LEFT: MoveObjects(-1, 0); VK_DOWN: MoveObjects(0, 1); VK_UP: MoveObjects(0, -1); VK_NEXT: MoveObjects(1, 1); VK_PRIOR: MoveObjects(1, -1); VK_HOME: MoveObjects(-1, -1); VK_END: MoveObjects(-1, 1); end; if Shift = [ssCtrl] then case Key of VK_RIGHT: LeftEdge := LeftEdge + ClientWidth - 16; VK_LEFT: LeftEdge := LeftEdge - ClientWidth + 16; VK_PRIOR: TopEdge := TO_HOME; VK_NEXT: TopEdge := TO_END; VK_HOME: SetLeftTop(TO_HOME, TO_HOME); VK_END: SetLeftTop(TO_END, TO_END); end; if Shift = [] then case Key of VK_DELETE: if fcoCanDelete in Options then DeleteSelection; VK_NEXT: TopEdge := TopEdge + ClientHeight - 16; VK_PRIOR: TopEdge := TopEdge - ClientHeight + 16; VK_HOME: LeftEdge := TO_HOME; VK_END: LeftEdge := TO_END; VK_RIGHT: SelNext(0); VK_LEFT: SelNext(1); VK_DOWN: SelNext(2); VK_UP: SelNext(3); end; end; procedure TdxCustomFlowChart.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin SetFocus; if not (ssDouble in Shift) then SetCapture(Handle); if (Button = mbLeft) and (Shift * [ssCtrl, ssAlt] = []) then begin FDragX := X; FDragY := Y; HitTest(X, Y); if htOnSelPoint in FHitTest then ChkDrag(Shift, X, Y); if Assigned(FDragHandler) then Exit; if (htOnObject in FHitTest) and FObjectAt.Selected and not (ssShift in Shift) then begin FObjectAt.SelectUnion; end else begin if FHitTest * [htOnObject, htOnConnection, htOnConLabel, htOnArrowSrc, htOnArrowDst] <> [] then begin if not (ssShift in Shift) then ClearSelection; if htOnObject in FHitTest then FObjectAt.Selected := not FObjectAt.Selected else FConnectionAt.Selected := not FConnectionAt.Selected; end; end; end; inherited MouseDown(Button, Shift, X, Y); end; procedure TdxCustomFlowChart.MouseMove(Shift: TShiftState; X, Y: Integer); begin if GetCapture = Handle then begin if Assigned(FDragHandler) then CallDragHandler(X, Y, dsDragMove) else begin if Focused and (ssLeft in Shift) and (Abs(X - FDragX) + Abs(Y - FDragY) > 4) then ChkDrag(Shift, X, Y); end; end; inherited MouseMove(Shift, X, Y); end; procedure TdxCustomFlowChart.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if GetCapture = Handle then ReleaseCapture; if Assigned(FDragHandler) then begin CallDragHandler(X, Y, dsDragLeave); FDragHandler := nil; ClipCursor(nil); end; inherited MouseUp(Button, Shift, X, Y); end; procedure TdxCustomFlowChart.ChkDrag(Shift: TShiftState; X, Y: Integer); var P: Byte; begin if not (fcoCanDrag in Options) or (Shift <> [ssLeft]) then Exit; if (FObjectAt <> nil) and FObjectAt.Selected and (FHitTest * [htOnObject, htOnSelPoint] = []) then begin P := FObjectAt.GetLinkedPoint(X, Y); FDragData.Connect := CreateConnection(FObjectAt, FObjectAt, P, P); FDragData.Index := 1; InitDrag(X, Y, DragConnect); Exit; end; if htOnSelPoint in FHitTest then begin if SelectedObjectCount = 1 then InitDrag(X, Y, DragResize) else with FDragData do begin Connect := FConnectionAt; Index := Connect.GetNearestPoint(X, Y); if Connect.ObjectSource <> nil then Inc(Index); if (Index = 0) or (Index = Connect.RealCount - 1) then InitDrag(X, Y, DragConnect) else InitDrag(X, Y, DragPoint); end; end else begin if (htOnObject in FHitTest) and FObjectAt.Selected then InitDrag(X, Y, DragMove) else if (htOnConnection in FHitTest) and (FConnectionAt = SelectedConnection) then FConnectionAt.NewPoint(X, Y, DragPoint); end; end; procedure TdxCustomFlowChart.InitDrag(X, Y: Integer; Handler: TdxFcDragHandler); var R: TRect; begin Update; R := ClientRect; Windows.ClientToScreen(Handle, R.TopLeft); Windows.ClientToScreen(Handle, R.BottomRight); ClipCursor(@R); FDragHandler := Handler; CallDragHandler(X, Y, dsDragEnter); end; procedure TdxCustomFlowChart.CallDragHandler(X, Y: Integer; State: TDragState); begin ShowCursor(False); SetROP2(Canvas.Handle, R2_NOTXORPEN); FDragHandler(X, Y, State); ShowCursor(True); end; procedure TdxCustomFlowChart.DragMove(X, Y: Integer; State: TDragState); var I, EndSel: Integer; DC: HDC; SBrush: HBrush; procedure DrawRgn; begin FillRgn(DC, FDragData.Rgn, SBrush); end; begin DC := Canvas.Handle; SBrush := GetStockObject(BLACK_BRUSH); with FDragData do case State of dsDragEnter: begin EndSel := TmpSel; Rgn := CreateRectRgn(0, 0, 0, 0); for I := 0 to SelectedObjectCount - 1 do begin SelectedObjects[I].CreateRgn; CombineRgn(Rgn, Rgn, SelectedObjects[I].FExtRgn, RGN_OR); end; RestoreSel(EndSel); Base := Point(X, Y); Mobile := Base; DrawRgn; end; dsDragMove: begin Dec(X, Mobile.X); Dec(Y, Mobile.Y); Inc(Mobile.X, X); Inc(Mobile.Y, Y); DrawRgn; OffsetRgn(Rgn, X, Y); DrawRgn; end; dsDragLeave: begin DrawRgn; Windows.DeleteObject(Rgn); Base := ChartPoint(Base.X, Base.Y); Mobile := ChartPoint(X, Y); MoveObjects(Mobile.X - Base.X, Mobile.Y - Base.Y); end; end; end; procedure TdxCustomFlowChart.DragResize(X, Y: Integer; State: TDragState); var DC: HDC; R: TRect; procedure DrawRect(Init: Boolean); begin if Init then begin SelectObject(DC, GetStockObject(BLACK_PEN)); SelectObject(DC, GetStockObject(HOLLOW_BRUSH)); end; R.TopLeft := FDragData.Base; R.BottomRight := FDragData.Mobile; NormRect(R); with R do Rectangle(DC, Left, Top, Right, Bottom); end; begin DC := Canvas.Handle; with FDragData do case State of dsDragEnter: begin with SelectedObject do begin R := DisplayRect; Index := Word(GetSelPoint(X, Y)); end; Base := R.TopLeft; Mobile := R.BottomRight; if (Index < 2) or (Index > 5) then Swap(Base.X, Mobile.X); if Index < 4 then Swap(Base.Y, Mobile.Y); Index := Index and 3; DrawRect(True); end; dsDragMove: begin DrawRect(True); if Index <> 1 then Mobile.X := X; if Index <> 3 then Mobile.Y := Y; DrawRect(False); end; dsDragLeave: begin DrawRect(True); if SelectedObject = nil then Exit; R.TopLeft := ChartPoint(Base.X, Base.Y); R.BottomRight := ChartPoint(Mobile.X, Mobile.Y); NormRect(R); with R do SelectedObject.SetBounds(Left, Top, Right - Left, Bottom - Top); end; end; end; procedure TdxCustomFlowChart.DragPoint(X, Y: Integer; State: TDragState); var DC: HDC; I: Integer; Flg: Boolean; begin DC := Canvas.Handle; if State = dsDragEnter then FDragData.Connect.InvertColor; SelectObject(DC, FDragData.Connect.FPen.Handle); with FDragData do case State of dsDragEnter: with Connect do begin Mobile := InternalGetPoint(FRealPoints, Index); OffsetPoints(FRealPoints, -LeftEdge, -TopEdge); Base.X := 0; end; dsDragMove: with Connect do begin Base.X := 1; PaintLine(DC); InternalPutPoint(FRealPoints, Index, Point(X, Y)); PaintLine(DC); end; dsDragLeave: with Connect do begin PaintLine(DC); InvertColor; OffsetPoints(FRealPoints, LeftEdge, TopEdge); InternalPutPoint(FRealPoints, Index, Mobile); I := Index; if ObjectSource <> nil then Dec(I); Flg := (fcoDelOnClick in Options) and (Base.X = 0); if not Flg then begin Base := ChartPoint(X, Y); X := Base.X; Y := Base.Y; Base := InternalGetPoint(FRealPoints, Index - 1); Mobile := InternalGetPoint(FRealPoints, Index + 1); case Style of fclStraight: Flg := PtOnLine(liStraight, Base, 2, Screen.Width shr 9, X, Y); fclRectH: Flg := (X = Mobile.X) or (Y = Base.Y); fclRectV: Flg := (X = Base.X) or (Y = Mobile.Y); end; end; if Flg then RemovePoint(I) else Points[I] := Point(X, Y); end; end; end; procedure TdxCustomFlowChart.DragConnect(X, Y: Integer; State: TDragState); var DC: HDC; I: Integer; begin DC := Canvas.Handle; if State = dsDragEnter then FDragData.Connect.InvertColor; SelectObject(DC, FDragData.Connect.FPen.Handle); with FDragData do case State of dsDragEnter: with Connect do begin if (Index = 0) and (ObjectSource <> nil) or (Index <> 0) and (ObjectDest <> nil) then begin Base := InternalGetPoint(FRealPoints, Index); if Index = 0 then SetObjectSource(nil, 0) else SetObjectDest(nil, 0); InternalInsertPoint(FPoints, Index, Base); InternalInsertPoint(FRealPoints, Index, Base); end else ConnectionChanged; OffsetPoints(FRealPoints, -LeftEdge, -TopEdge); end; dsDragMove: with Connect do begin PaintLine(DC); InternalPutPoint(FRealPoints, Index, Point(X, Y)); PaintLine(DC); end; dsDragLeave: with Connect do begin PaintLine(DC); InvertColor; OffsetPoints(FRealPoints, LeftEdge, TopEdge); HitTest(X, Y); if FObjectAt <> nil then begin I := FObjectAt.GetLinkedPoint(X, Y); InternalRemovePoint(FPoints, Index); InternalRemovePoint(FRealPoints, Index); if Index = 0 then SetObjectSource(FObjectAt, I) else SetObjectDest(FObjectAt, I); end else begin if ObjectSource <> nil then Dec(Index); Points[Index] := ChartPoint(X, Y); end; FHitTest := []; end; end; end; procedure TdxCustomFlowChart.AbortDrag; var P: TPoint; begin if Assigned(FDragHandler) then begin Windows.GetCursorPos(P); Windows.ScreenToClient(Handle, P); MouseUp(mbLeft, [], P.X, P.Y); end; end; procedure TdxCustomFlowChart.LoadFromStream(Stream: TStream); var I: Integer; AIsUnicode: Boolean; B: array[0..6] of AnsiChar; begin BeginUpdate; AIsUnicode := False; if (Stream.Size - Stream.Position) > SizeOf(B) then begin Stream.ReadBuffer(B, SizeOf(B)); AIsUnicode := B = StreamDescriptionUNICODE; if not AIsUnicode and (B <> StreamDescriptionANSI) then Stream.Position := Stream.Position - SizeOf(B); end; FLoading := True; try Clear; I := 0; Stream.ReadBuffer(I, SizeOf(Word)); while I > 0 do begin InternalCreateObject.Load(Stream, AIsUnicode); Dec(I); end; for I := 0 to ObjectCount - 1 do Objects[I].ResolveObjRefs; I := 0; Stream.ReadBuffer(I, SizeOf(Word)); while I > 0 do begin InternalCreateConnection.Load(Stream, AIsUnicode); Dec(I); end; finally FLoading := False; EndUpdate; end; end; procedure TdxCustomFlowChart.SaveToStream(Stream: TStream); var I: Integer; begin I := ObjectCount; {$IFNDEF STREAMANSIFORMAT} {$IFDEF DELPHI12} Stream.WriteBuffer(StreamDescriptionUNICODE[1], StrLen(PAnsiChar(StreamDescriptionUNICODE))); {$ELSE} Stream.WriteBuffer(StreamDescriptionANSI[1], Length(StreamDescriptionANSI)); {$ENDIF} {$ENDIF} Stream.WriteBuffer(I, SizeOf(Word)); for I := 0 to ObjectCount - 1 do Objects[I].Save(Stream); I := ConnectionCount; Stream.WriteBuffer(I, SizeOf(Word)); for I := 0 to ConnectionCount - 1 do Connections[I].Save(Stream); end; procedure TdxCustomFlowChart.LoadFromFile(const FileName: string); var S: TStream; begin S := TFileStream.Create(FileName, fmOpenRead); try LoadFromStream(S); finally S.Free; end; end; procedure TdxCustomFlowChart.SaveToFile(const FileName: string); var S: TStream; begin S := TFileStream.Create(FileName, fmCreate); try SaveToStream(S); finally S.Free; end; end; procedure TdxCustomFlowChart.DefineProperties(Filer: TFiler); begin inherited DefineProperties(Filer); Filer.DefineBinaryProperty('Items', LoadFromStream, SaveToStream, ObjectCount > 0); end; function TdxCustomFlowChart.CanSelect(Item: TdxFcItem): Boolean; begin Result := fcoCanSelect in Options; if Assigned(OnSelection) then OnSelection(Self, Item, Result); end; procedure TdxCustomFlowChart.Changed(Item: TdxFcItem); begin if Assigned(OnChange) then OnChange(Self, Item); end; procedure TdxCustomFlowChart.Delete(Item: TdxFcItem); begin AbortDrag; Item.Invalidate; if Item.Selected then begin Item.SelList.Remove(Item); Item.FSelected := False; Select(Item); end; if Assigned(OnDeletion) then OnDeletion(Self, Item); Item.FDestroying := True; FHitTest := []; end; procedure TdxCustomFlowChart.Select(Item: TdxFcItem); begin if Assigned(OnSelected) then OnSelected(Self, Item); end; procedure TdxCustomFlowChart.WndProc(var Message: TMessage); begin if Assigned(FDragHandler) and (Message.Msg >= WM_KEYFIRST) and (Message.Msg <= WM_KEYLAST) then Exit; inherited WndProc(Message); end; procedure TdxCustomFlowChart.WMHScroll(var Msg: TWMHScroll); begin ScrollChart(SB_HORZ, Msg.ScrollCode, Msg.Pos, LeftEdge, ClientWidth); end; procedure TdxCustomFlowChart.WMVScroll(var Msg: TWMVScroll); begin ScrollChart(SB_VERT, Msg.ScrollCode, Msg.Pos, TopEdge, ClientHeight); end; procedure TdxCustomFlowChart.WMSetFocus(var Msg: TWMSetFocus); begin inherited; if fcoHideSelection in Options then InvalidateSel; end; procedure TdxCustomFlowChart.WMKillFocus(var Msg: TWMKillFocus); begin if GetCapture = Handle then ReleaseCapture; // Fix: by Kirill AbortDrag; WMSetFocus(TWMSetFocus(Msg)); end; procedure TdxCustomFlowChart.WMSize(var Msg: TWMSize); begin inherited; if Msg.SizeType in [SIZE_MAXIMIZED, SIZE_RESTORED] then begin if (Zoom <> 0) and (Zoom <> $FFFF) then UpdateScrollRange; if Zoom = 0 then begin FZoom := 100; SetZoom(0); end; end; end; procedure TdxCustomFlowChart.WMSetCursor(var Message: TWMSetCursor); const Cursors: array[0..3] of TCursor = (crSizeNWSE, crSizeNS, crSizeNESW, crSizeWE); var pt: TPoint; begin GetCursorPos(pt); pt := ScreenToClient(pt); HitTest(pt.X, pt.Y); if (htOnSelPoint in FHitTest) then begin if(FObjectAt <> nil) and (FObjectAt = SelectedObject) then Windows.SetCursor(Screen.Cursors[Cursors[FObjectAt.GetSelPoint(pt.X, pt.Y) and 3]]) else Windows.SetCursor(Screen.Cursors[crSize]); end else inherited; end; procedure TdxCustomFlowChart.WMErase(var Msg: TWMEraseBkgnd); begin Msg.Result := 1; end; procedure TdxCustomFlowChart.WMGetDlgCode(var Msg: TWMGetDlgCode); begin inherited; Msg.Result := Msg.Result or DLGC_WANTARROWS; end; procedure TdxCustomFlowChart.WMPaint(var Msg: TWMPaint); begin if not Assigned(FDragHandler) then inherited; end; procedure TdxCustomFlowChart.WMNCHitTest(var Msg: TWMNCHitTest); begin DefaultHandler(Msg); if (csDesigning in ComponentState) and not (Msg.Result in [HTHSCROLL, HTVSCROLL]) then Msg.Result := HTCLIENT; end; procedure TdxCustomFlowChart.CMCtl3DChanged(var Msg: TMessage); begin inherited; if BorderStyle = bsSingle then RecreateWnd; end; procedure TdxCustomFlowChart.CMFontChanged(var Msg: TMessage); procedure ResetFont(Item: TdxFcItem); begin if Item.ParentFont then with Item do begin Font.Assign(Self.Font); FParentFont := True; end; end; var I: Integer; begin BeginUpdate; for I := 0 to ObjectCount - 1 do ResetFont(Objects[I]); for I := 0 to ConnectionCount - 1 do ResetFont(Connections[I]); EndUpdate; end; end.