simplegraph.pas

很不错的绘制矢量图的控件。还有一个使用控件的例子。delphi7以上才可安装

    class procedure DrawDraft(Canvas: TCanvas; const ARect: TRect); override;
  end;

  { TTriangularNode }

  TTriangularNode = class(TPolygonalNode)
  protected
    function GetMaxTextRect: TRect; override;
    class procedure DefineVertices(const ARect: TRect; var Points: TPointArray); override;
  end;

  { TRhomboidalNode }

  TRhomboidalNode = class(TPolygonalNode)
  protected
    function GetMaxTextRect: TRect; override;
    class procedure DefineVertices(const ARect: TRect; var Points: TPointArray); override;
  end;

  { TPentagonalNode }

  TPentagonalNode = class(TPolygonalNode)
  protected
    function GetMaxTextRect: TRect; override;
    class procedure DefineVertices(const ARect: TRect; var Points: TPointArray); override;
  end;

  { TGraphObjectList }

  TGraphObjectListAction = (glAdded, glRemoved, glReordered);

  TGraphObjectListEvent = procedure(Sender: TObject; GraphObject: TGraphObject;
    Action: TGraphObjectListAction) of object;

  TGraphObjectList = class(TList)
  private
    fOnChange: TGraphObjectListEvent;
    function GetItems(Index: Integer): TGraphObject;
  protected
    procedure NotifyAction(GraphObject: TGraphObject;
      Action: TGraphObjectListAction); virtual;
    function Replace(OldItem, NewItem: TGraphObject): Integer;
    property OnChange: TGraphObjectListEvent read fOnChange write fOnChange;
  public
    procedure Clear; override;
    procedure Exchange(Index1, Index2: Integer);
    procedure Move(CurIndex, NewIndex: Integer);
    function Add(Item: TGraphObject): Integer;
    procedure Insert(Index: Integer; Item: TGraphObject);
    procedure Extract(Item: TGraphObject);
    procedure Delete(Index: Integer);
    function Remove(Item: TGraphObject): Integer;
    function First: TGraphObject;
    function Last: TGraphObject;
    property Items[Index: Integer]: TGraphObject read GetItems; default;
  end;

  { TSimpleGraph }

  TGraphNodeClass = class of TGraphNode;
  TGraphLinkClass = class of TGraphLink;

  TGridSize = 4..128;
  TMarkerSize = 3..9;
  TZoom = 10..1000;

  TGraphMouseState = (gsNone, gsMoveResizeNode, gsSelectRect, gsMoveLink);
  TGraphCommandMode = (cmViewOnly, cmEdit, cmInsertNode, cmLinkNodes);

  TGraphNotifyEvent = procedure(Graph: TSimpleGraph;
    GraphObject: TGraphObject) of object;
  TGraphContextPopupEvent = procedure(Graph: TSimpleGraph; GraphObject: TGraphObject;
    const MousePos: TPoint; var Handled: Boolean) of object;
  TCanMoveResizeNodeEvent = procedure(Graph: TSimpleGraph; Node: TGraphNode;
    var NewLeft, NewTop, NewWidth, NewHeight: Integer;
    var CanMove, CanResize: Boolean) of object;
  TCanLinkNodesEvent = procedure(Graph: TSimpleGraph;
    FromNode, ToNode: TGraphNode; var CanLink: Boolean) of object;

  {$IFNDEF DELPHI5_UP}
  TContextPopupEvent = procedure(Sender: TObject; MousePos: TPoint;
    var Handled: Boolean) of object;
  {$ENDIF}

  TSimpleGraph = class(TCustomControl)
  private
    fGridSize: TGridSize;
    fGridColor: TColor;
    fShowGrid: Boolean;
    fSnapToGrid: Boolean;
    fShowHiddenObjects: Boolean;
    fHideSelection: Boolean;
    fLockNodes: Boolean;
    fMarkerColor: TColor;
    fMarkerSize: TMarkerSize;
    fZoom: TZoom;
    fZoomMin: TZoom;
    fZoomMax: TZoom;
    fZoomStep: Byte;
    fObjects: TGraphObjectList;
    fSelectedObjects: TGraphObjectList;
    fDefaultKeyMap: Boolean;
    fObjectPopupMenu: TPopupMenu;
    fDefaultNodeClass: TGraphNodeClass;
    fDefaultLinkClass: TGraphLinkClass;
    fModified: Boolean;
    fState: TGraphMouseState;
    fCommandMode: TGraphCommandMode;
    fHorzScrollBar: TGraphScrollBar;
    fVertScrollBar: TGraphScrollBar;
    fVisibleBounds: TRect;
    fFreezeTopLeft: Boolean;
    fMinNodeSize: Word;
    fOnObjectInsert: TGraphNotifyEvent;
    fOnObjectRemove: TGraphNotifyEvent;
    fOnObjectSelect: TGraphNotifyEvent;
    fOnObjectDblClick: TGraphNotifyEvent;
    fOnObjectContextPopup: TGraphContextPopupEvent;
    fOnCanMoveResizeNode: TCanMoveResizeNodeEvent;
    fOnCanLinkNodes: TCanLinkNodesEvent;
    fOnGraphChange: TNotifyEvent;
    fOnCommandModeChange: TNotifyEvent;
    {$IFNDEF DELPHI5_UP}
    fOnContextPopup: TContextPopupEvent;
    {$ENDIF}
    UpdatingScrollBars: Boolean;
    ObjectAtCursor: TGraphObject;
    MarkerAtCursor: TMarkerType;
    Grid: TBitmap;
    StartPoint: TPoint;
    StopPoint: TPoint;
    SelectionRect: TRect;
    FirstNodeOfLink: TGraphNode;
    UpdateCount: Integer;
    GraphModified: Boolean;
    Linking: Boolean;
    IgnoreNotification: Boolean;
    WheelAccumulator: Integer;
    procedure SetGridSize(Value: TGridSize);
    procedure SetGridColor(Value: TColor);
    procedure SetShowGrid(Value: Boolean);
    procedure SetShowHiddenObjects(Value: Boolean);
    procedure SetHideSelection(Value: Boolean);
    procedure SetLockNodes(Value: Boolean);
    procedure SetMarkerColor(Value: TColor);
    procedure SetMarkerSize(Value: TMarkerSize);
    procedure SetZoom(Value: TZoom);
    procedure SetZoomMin(Value: TZoom);
    procedure SetZoomMax(Value: TZoom);
    procedure SetState(Value: TGraphMouseState);
    procedure SetCommandMode(Value: TGraphCommandMode);
    procedure SetHorzScrollBar(Value: TGraphScrollBar);
    procedure SetVertScrollBar(Value: TGraphScrollBar);
    function GetGraphBounds(Mode: Integer): TRect;
    {$IFNDEF DELPHI5_UP}
    procedure WMContextMenu(var Message: TMessage); message WM_CONTEXTMENU;
    {$ENDIF}
    procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
    procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
    procedure CNKeyDOwn(var Msg: TWMKeyDown); message CN_KEYDOWN;
    procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
    procedure CMBiDiModeChanged(var Msg: TMessage); message CM_BIDIMODECHANGED;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
    procedure WMMouseWheel(var Message: TMessage); message WM_MOUSEWHEEL;
    procedure ObjectListChanged(Sender: TObject; GraphObject: TGraphObject;
      Action: TGraphObjectListAction);
    procedure SelectionListChanged(Sender: TObject; GraphObject: TGraphObject;
      Action: TGraphObjectListAction);
    function ChangeObjectClass(GraphObject: TGraphObject;
      AnotherClass: TGraphObjectClass): Boolean;
    procedure ObjectChanged(GraphObject: TGraphObject; DataModified: Boolean);
    function VerifyNodeMoveResize(Node: TGraphNode;
      var aLeft, aTop, aWidth, aHeight: Integer;
      var CanMove, CanResize: Boolean): Boolean;
    procedure UpdateScrollBars;
    procedure CalcAutoRange;
    procedure CalcVisibleBounds;
    function ReadGraphObject(Stream: TStream): TGraphObject;
    procedure WriteGraphObject(Stream: TStream; GraphObject: TGraphObject);
  protected
    procedure CreateWnd; override;
    procedure Paint; 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 DoContextPopup(MousePos: TPoint; var Handled: Boolean); {$IFDEF DELPHI5_UP} override; {$ENDIF}
    procedure DblClick; override;
    procedure DoEnter; override;
    procedure DoExit; override;
    procedure DoGraphChange; virtual;
    procedure DoCommandModeChange; virtual;
    procedure DoObjectDblClick(GraphObject: TGraphObject); virtual;
    procedure DoObjectInsert(GraphObject: TGraphObject); virtual;
    procedure DoObjectRemove(GraphObject: TGraphObject); virtual;
    procedure DoObjectSelect(GraphObject: TGraphObject); virtual;
    procedure DoObjectContextPopup(GraphObject: TGraphObject; const MousePos: TPoint;
      var Handled: Boolean); virtual;
    procedure DoCanMoveResizeNode(Node: TGraphNode; var aLeft, aTop, aWidth, aHeight: Integer;
      var CanMove, CanResize: Boolean); virtual;
    function CanLinkNodes(FromNode, ToNode: TGraphNode): Boolean; virtual;
    function FindObjectMarkerAt(X, Y: Integer;
      var GraphObject: TGraphObject): TMarkerType; virtual;
    function FindObjectByID(ID: DWORD;
      GraphObjectClass: TGraphObjectClass): TGraphObject; virtual;
    function FindObjectByOldID(StartIndex: Integer; OldID: DWORD;
      GraphObjectClass: TGraphObjectClass): TGraphObject; virtual;
    procedure ReadObjects(Stream: TStream); virtual;
    procedure WriteObjects(Stream: TStream; SelectedOnly: Boolean); virtual;
    procedure DrawBackground(Canvas: TCanvas); virtual;
    function GetUniqueID(PreferredID: DWORD): DWORD; virtual;
    function GetAsMetafile: TMetafile; virtual;
    property State: TGraphMouseState read fState write SetState;
  public
    class procedure Register(ANodeClass: TGraphNodeClass); overload;
    class procedure Unregister(ANodeClass: TGraphNodeClass); overload;
    class function NodeClassCount: Integer;
    class function NodeClasses(Index: Integer): TGraphNodeClass;
    class procedure Register(ALinkClass: TGraphLinkClass); overload;
    class procedure Unregister(ALinkClass: TGraphLinkClass); overload;
    class function LinkClassCount: Integer;
    class function LinkClasses(Index: Integer): TGraphLinkClass;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure Invalidate; override;
    procedure Draw(Canvas: TCanvas);
    procedure Print(Canvas: TCanvas; const Rect: TRect);
    procedure ToggleNodesAt(const Rect: TRect; KeepOld: Boolean);
    function FindObjectAt(X, Y: Integer;
      GraphObjectClass: TGraphObjectClass = nil): TGraphObject;
    function InsertNode(pBounds: PRect = nil;
      ANodeClass: TGraphNodeClass = nil): TGraphNode;
    function LinkNodes(FromNode, ToNode: TGraphNode;
      ALinkClass: TGraphLinkClass = nil): TGraphLink;
    function IsValidLink(Link: TGraphLink;
      FromNode, ToNode: TGraphNode): Boolean;
    procedure ScrollInView(GraphObject: TGraphObject); overload;
    procedure ScrollInView(const Rect: TRect); overload;
    procedure ScrollInView(const Point: TPoint); overload;
    function ZoomRect(const Rect: TRect): Boolean;
    function ZoomObject(GraphObject: TGraphObject): Boolean;
    function ZoomSelection: Boolean;
    function ZoomGraph: Boolean;
    function FindNextObject(StartIndex: Integer; Inclusive, Backward,
      Wrap: Boolean; GraphObjectClass: TGraphObjectClass = nil): TGraphObject;
    function SelectNextObject(Backward: Boolean;
      GraphObjectClass: TGraphObjectClass = nil): Boolean;
    function ObjectsCount(GraphObjectClass: TGraphObjectClass = nil): Integer;
    function SelectedObjectsCount(GraphObjectClass: TGraphObjectClass = nil): Integer;
    procedure Clear;
    procedure SaveAsMetafile(const Filename: String);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromFile(const Filename: String);
    procedure SaveToFile(const Filename: String);
    procedure CopyToClipboard(Selection: Boolean = True);
    function PasteFromClipboard: Boolean;
    function ClientToGraph(X, Y: Integer): TPoint;
    function GraphToClient(X, Y: Integer): TPoint;
    property VisibleBounds: TRect read fVisibleBounds;
    property GraphBounds: TRect index 0 read GetGraphBounds;
    property SelectionBounds: TRect index 1 read GetGraphBounds;
    property Objects: TGraphObjectList read fObjects;
    property SelectedObjects: TGraphObjectList read fSelectedObjects;
    property Modified: Boolean read fModified write fModified;
    property CommandMode: TGraphCommandMode read fCommandMode write SetCommandMode;
    property DefaultNodeClass: TGraphNodeClass read fDefaultNodeClass write fDefaultNodeClass;
    property DefaultLinkClass: TGraphLinkClass read fDefaultLinkClass write fDefaultLinkClass;
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property Color;
    property Constraints;
    property DefaultKeyMap: Boolean read fDefaultKeyMap write fDefaultKeyMap default True;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property FreezeTopLeft: Boolean read fFreezeTopLeft write fFreezeTopLeft default False;
    property GridColor: TColor read fGridColor write SetGridColor default clGray;
    property GridSize: TGridSize read fGridSize write SetGridSize default 8;
    property Height;
    property HideSelection: Boolean read fHideSelection write SetHideSelection default False;
    property HorzScrollBar: TGraphScrollBar read fHorzScrollBar write SetHorzScrollBar;
    property LockNodes: Boolean read fLockNodes write SetLockNodes default False;
    property MarkerColor: TColor read fMarkerColor write SetMarkerColor default clBlack;
    property MarkerSize: TMarkerSize read fMarkerSize write SetMarkerSize default 3;
    property MinNodeSize: Word read fMinNodeSize write fMinNodeSize default 16;
    property ObjectPopupMenu: TPopupMenu read fObjectPopupMenu write fObjectPopupMenu;
    property ParentBiDiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowGrid: Boolean read fShowGrid write SetShowGrid default True;
    property ShowHiddenObjects: Boolean read fShowHiddenObjects write SetShowHiddenObjects default False;
    property ShowHint;
    property SnapToGrid: Boolean read fSnapToGrid write fSnapToGrid default True;
    property TabOrder;
    property TabStop;
    property VertScrollBar: TGraphScrollBar read fVertScrollBar write SetVertScrollBar;
    property Visible;
    property Width;
    property Zoom: TZoom read fZoom write SetZoom default 100;
    property ZoomMax: TZoom read fZoomMax write SetZoomMax default Low(TZoom);
    property ZoomMin: TZoom read fZoomMin write SetZoomMin default Low(TZoom);
    property ZoomStep: Byte read fZoomStep write fZoomStep default 25;
    property OnCanResize;
    property OnConstrainedResize;
    {$IFNDEF DELPHI5_UP}
    property OnContextPopup: TContextPopupEvent read fOnContextPopup write fOnContextPopup;
    {$ELSE}
    property OnContextPopup;
    {$ENDIF}
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDockDrop;
    property OnDockOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetSiteInfo;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
    property OnObjectInsert: TGraphNotifyEvent read fOnObjectInsert write fOnObjectInsert;
    property OnObjectRemove: TGraphNotifyEvent read fOnObjectRemove write fOnObjectRemove;
    property OnObjectSelect: TGraphNotifyEvent read fOnObjectSelect write fOnObjectSelect;
    property OnObjectDblClick: TGraphNotifyEvent read fOnObjectDblClick write fOnObjectDblClick;
    property OnObjectContextPopup: TGraphContextPopupEvent read fOnObjectContextPopup write fOnObjectContextPopup;
    property OnCanMoveResizeNode: TCanMoveResizeNodeEvent read fOnCanMoveResizeNode write fOnCanMoveResizeNode;
    property OnCanLinkNodes: TCanLinkNodesEvent read fOnCanLinkNodes write fOnCanLinkNodes;
    property OnGraphChange: TNotifyEvent read fOnGraphChange write fOnGraphChange;
    property OnCommandModeChange: TNotifyEvent read fOnCommandModeChange write fOnCommandModeChange;
  end;

function IsBetween(Value: Integer; Bound1, Bound2: Integer): Boolean;

function TransformRgn(Rgn: HRGN; const XForm: TXForm): HRGN;

procedure TransformPoints(var Points: array of TPoint; const XForm: TXForm);
procedure RotatePoints(var Points: array of TPoint; const Angle: Extended; const Org: TPoint);
procedure OffsetPoints(var Points: array of TPoint; dX, dY: Integer);
function CenterOfPoints(const Points: array of TPoint): TPoint;
function BoundsRectOfPoints(const Points: array of TPoint): TRect;

function MakeRect(const Corner1, Corner2: TPoint): TRect;
function CenterOfRect(const Rect: TRect): TPoint;

function LineSlopeAngle(const LinePt1, LinePt2: TPoint): Extended;
function DistanceToLine(const LinePt1, LinePt2, QueryPt: TPoint): Integer;
function NextPointOfLine(const LineAngle: Extended; const ThisPoint: TPoint; Distance: Integer): TPoint;

function IntersectLines(const Line1Pt: TPoint;
  const Line1Angle: Extended; const Line2Pt: TPoint;
  const Line2Angle: Extended; out Intersect: TPoint): Boolean;

// In the following functions, the line passes through the center of shape
function IntersectLineRect(const LineAngle: Extended;
  const Rect: TRect; Backward: Boolean): TPoint;
function IntersectLineEllipse(const LineAngle: Extended;
  const Bounds: TRect; Backward: Boolean): TPoint;
function IntersectLineRoundRect(const LineAngle: Extended;
  const Bounds: TRect; Backward: Boolean; Rgn: HRgn): TPoint;
function IntersectLinePolygon(const LineAngle: Extended;
  const Vertices: array of TPoint; Backward: Boolean): TPoint;

var
  CF_SIMPLEGRAPH: Integer = 0;

procedure Register;

implementation

{$R *.RES}

uses
  Math, SysUtils, CommCtrl, Clipbrd;

const
  StreamSignature: DWORD =