dxflchrt.pas

业生产并行开发过程 工作流流程编辑器参考源码 采用dxflowchart编写

    procedure SetObjectSource(AObject: TdxFcObject; APoint: Byte);
    property ArrowDest: TdxFcConnectionArrow read FArrowDest write SetArrowDest;
    property ArrowSource: TdxFcConnectionArrow read FArrowSource write
            SetArrowSource;
    property Color: TColor read GetColor write SetColor;
    property ObjectDest: TdxFcObject read FObjectDest;
    property ObjectSource: TdxFcObject read FObjectSource;
    property PenStyle: TPenStyle read GetPenStyle write SetPenStyle;
    property PointCount: Integer read GetPointCount;
    property PointDest: Byte read FPointDest;
    property Points[Index: Integer]: TPoint read GetPoint write PutPoint;
    property PointSource: Byte read FPointSource;
    property Style: TdxFclStyle read FStyle write SetStyle;
    property Transparent: Boolean read FTransparent write SetTransparent;
  end;
  
  TdxFcSelection = class(TObject)
  private
    Counts: TList;
    Owner: TdxCustomFlowChart;
    Points: TList;
    procedure AddPoint(X, Y: Integer);
    procedure Clear;
    procedure Paint;
  public
    constructor Create(AOwner: TdxCustomFlowChart);
    destructor Destroy; override;
  end;
  
  TdxCustomFlowChart = class(TCustomControl)
  private
    FBorderStyle: TBorderStyle;
    FChangeLink: TChangeLink;
    FChartHeight: Integer;
    FChartLeft: Integer;
    FChartTop: Integer;
    FChartWidth: Integer;
    FConnectionAt: TdxFcConnection;
    FConnections: TList;
    FDragData: TdxFcDragData;
    FDragHandler: TdxFcDragHandler;
    FDragX: Integer;
    FDragY: Integer;
    FHitTest: TdxFcHitTest;
    FHitX: Integer;
    FHitY: Integer;
    FImages: TImageList;
    FLeftEdge: Integer;
    FLoading: Boolean;
    FLockUpdates: Integer;
    FObjectAt: TdxFcObject;
    FObjects: TList;
    FOnChange: TdxFcEvent;
    FOnCreateItem: TdxFcEvent;
    FOnDeletion: TdxFcEvent;
    FOnDrawObject: TdxFcDrawEvent;
    FOnEdited: TdxFcEditEvent;
    FOnEditing: TdxFcAllowEvent;
    FOnSelected: TdxFcEvent;
    FOnSelection: TdxFcAllowEvent;
    FOptions: TdxFcOptions;
    FRealZoom: Word;
    FRepaint: Boolean;
    FSelConnections: TList;
    FSelection: TdxFcSelection;
    FSelObjects: TList;
    FTopEdge: Integer;
    FZoom: Word;
    //daqS
    FObjS,FObjD:TDxFcObject;
    FPosS,FPosD:Byte;
    //daqE
    procedure AbortDrag;
    procedure AddSelectedConnection(AConnection: TdxFcConnection);
    procedure AddSelectedObject(AObject: TdxFcObject);
    procedure CalculateRealPos;
    procedure CallDragHandler(X, Y: Integer; State: TDragState);
    function CanPaint: Boolean;
    procedure ChkDrag(Shift: TShiftState; X, Y: Integer);
    procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;
    procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
    procedure DragConnect(X, Y: Integer; State: TDragState);
    procedure DragMove(X, Y: Integer; State: TDragState);
    procedure DragPoint(X, Y: Integer; State: TDragState);
    procedure DragResize(X, Y: Integer; State: TDragState);
    function GetConnection(Index: Integer): TdxFcConnection;
    function GetConnectionCount: Integer;
    function GetObject(Index: Integer): TdxFcObject; virtual;
    function GetObjectCount: Integer;
    function GetSelConnect: TdxFcConnection;
    function GetSelectedConnection(Index: Integer): TdxFcConnection;
    function GetSelectedConnectionCount: Integer;
    function GetSelectedObject(Index: Integer): TdxFcObject;
    function GetSelectedObjectCount: Integer;
    function GetSelObj: TdxFcObject;
    function HasSelection: Boolean;
    procedure HitTest(X, Y: Integer);
    procedure InitDrag(X, Y: Integer; Handler: TdxFcDragHandler);
    procedure InvalidateSel;
    procedure MoveObjects(DX, DY: Integer);
    procedure OnChangeLink(Sender: TObject);
    procedure RestoreSel(Value: Integer);
    procedure ScalePoint(var P: TPoint);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetChartSizes;
    procedure SetConnection(Index: Integer; Value: TdxFcConnection);
    procedure SetImages(Value: TImageList);
    procedure SetLeftEdge(Value: Integer);
    procedure SetObject(Index: Integer; Value: TdxFcObject);
    procedure SetOptions(Value: TdxFcOptions);
    procedure SetSelConnect(Value: TdxFcConnection);
    procedure SetSelObj(Value: TdxFcObject);
    procedure SetTopEdge(Value: Integer);
    procedure SetZoom(Value: Word);
    function TmpSel: Integer;
    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 WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
    procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
    procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
  protected
    procedure ScrollChart(Bar, Code, Pos: Cardinal; Value, Page: Integer);
    function CanSelect(Item: TdxFcItem): Boolean; virtual;
    procedure Changed(Item: TdxFcItem); virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DefaultDrawObject(AObject: TdxFcObject; R: TRect); virtual;
    procedure DefaultDrawObject_(AObject: TdxFcObject; R: TRect; cvs:TCanvas); virtual;
    procedure DefineProperties(Filer: TFiler); override;
    procedure Delete(Item: TdxFcItem); virtual;
    function InternalCreateConnection: TdxFcConnection; virtual;
    function InternalCreateObject: TdxFcObject; virtual;
    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 NeedRepaint;
    procedure NeedRepaintObject(AObject: TdxFcObject);
    procedure Paint; override;
    procedure Select(Item: TdxFcItem); virtual;
    procedure WndProc(var Message: TMessage); override;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle
            default bsSingle;
    property ChartHeight: Integer read FChartHeight write FChartHeight;
    property ChartWidth: Integer read FChartWidth write FChartWidth;
    property Images: TImageList read FImages write SetImages;
    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;
    property Options: TdxFcOptions read FOptions write SetOptions;
    property Zoom: Word read FZoom write SetZoom default 100;
  public
    procedure Paint_(cvs:TCanvas);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure BeginUpdate;
    procedure CancelUpdate;
    function ChartPoint(X, Y: Integer): TPoint;
    procedure Clear;
    procedure ClearSelection;
    function CreateConnection(OSrc, ODst: TdxFcObject; PSrc, PDst: Byte):
            TdxFcConnection;
    function CreateObject(L, T, W, H: Integer; AShape: TdxFcShapeType):
            TdxFcObject;
    procedure DeleteConnection(AConnection: TdxFcConnection);
    procedure DeleteObject(AObject: TdxFcObject);
    procedure DeleteSelection;
    procedure EndUpdate;
    function GetConnectionAt(X, Y: Integer): TdxFcConnection;
    function GetHitTestAt(X, Y: Integer): TdxFcHitTest;
    function GetObjectAt(X, Y: Integer): TdxFcObject;
    procedure Invalidate; override;
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStream(Stream: TStream);
    procedure Notification(AComponent: TComponent; Operation: TOperation);
            override;
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream);
    function SelCount: Integer;
    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 ObjectCount: Integer read GetObjectCount;
    property Objects[Index: Integer]: TdxFcObject read GetObject write
            SetObject;
    property RealZoom: Word read FRealZoom;
    property SelectedConnection: TdxFcConnection read GetSelConnect write
            SetSelConnect;
    property SelectedConnectionCount: Integer read GetSelectedConnectionCount;
    property SelectedConnections[Index: Integer]: TdxFcConnection read
            GetSelectedConnection;
    property SelectedObject: TdxFcObject read GetSelObj write SetSelObj;
    property SelectedObjectCount: Integer read GetSelectedObjectCount;
    property SelectedObjects[Index: Integer]: TdxFcObject read
            GetSelectedObject;
    property TopEdge: Integer read FTopEdge write SetTopEdge;
  end;
  
  TdxFlowChart = class(TdxCustomFlowChart)
  published
    property Align;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property Enabled;
    property Font;
    property Images;
    property OnChange;
    property OnClick;
    property OnCreateItem;
    property OnDblClick;
    property OnDeletion;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawObject;
    property OnEdited;
    property OnEditing;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnSelected;
    property OnSelection;
    property OnStartDrag;
    property Options;
    property ParentColor default False;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property TabStop default True;
    property Visible;
    property Zoom;
  end;
  
implementation

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): string;
var
  L: Word;
begin
  Stream.ReadBuffer(L, SizeOf(Word));
  SetString(Result, PChar(nil), L);
  if L > 0 then Stream.ReadBuffer(Result[1], L);
end;

procedure WriteStr(Stream: TStream; const S: string);
var
  L: Integer;
begin
  L := Length(S);
  if L > $FFFF then L := $FFFF;
  Stream.WriteBuffer(L, SizeOf(Word));
  if L > 0 then Stream.WriteBuffer(S[1], L);
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 }

{
******************************** 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 }

{
********************************** 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.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.Changed;
begin
  if not Owner.FLoading then Owner.Changed(Self);
end;

procedure TdxFcItem.FontChanged;
begin
  Invalidate;
end;

procedure TdxFcItem.LoadFont(Stream: TStream);
var
  Data: TdxFcFntData;
  FtName: string;
begin
  if ParentFont then Exit;
  Stream.ReadBuffer(Data, SizeOf(Data));
  FtName := ReadStr(Stream);
  with Font do