simplegraph.pas

矢量绘图组件（开源版）

    property VertScrollBar: TGraphScrollBar read fVertScrollBar write SetVertScrollBar;
    property Visible;
    property Width;
    property Zoom: TZoom read fZoom write SetZoom default 100;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    {$IFNDEF COMPILER5_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 OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
    property OnObjectInitInstance: TGraphNotifyEvent read fOnObjectInitInstance write fOnObjectInitInstance;
    property OnObjectInsert: TGraphNotifyEvent read fOnObjectInsert write fOnObjectInsert;
    property OnObjectRemove: TGraphNotifyEvent read fOnObjectRemove write fOnObjectRemove;
    property OnObjectChange: TGraphNotifyEvent read fOnObjectChange write fOnObjectChange;
    property OnObjectSelect: TGraphNotifyEvent read fOnObjectSelect write fOnObjectSelect;
    property OnObjectClick: TGraphNotifyEvent read fOnObjectClick write fOnObjectClick;
    property OnObjectDblClick: TGraphNotifyEvent read fOnObjectDblClick write fOnObjectDblClick;
    property OnObjectContextPopup: TGraphContextPopupEvent read fOnObjectContextPopup write fOnObjectContextPopup;
    property OnObjectBeforeDraw: TGraphObjectDrawEvent read fOnObjectBeforeDraw write fOnObjectBeforeDraw;
    property OnObjectAfterDraw: TGraphObjectDrawEvent read fOnObjectAfterDraw write fOnObjectAfterDraw;
    property OnObjectBeginDrag: TGraphBeginDragEvent read fOnObjectBeginDrag write fOnObjectBeginDrag;
    property OnObjectEndDrag: TGraphEndDragEvent read fOnObjectEndDrag write fOnObjectEndDrag;
    property OnObjectMouseEnter: TGraphNotifyEvent read fOnObjectMouseEnter write fOnObjectMouseEnter;
    property OnObjectMouseLeave: TGraphNotifyEvent read fOnObjectMouseLeave write fOnObjectMouseLeave;
    property OnObjectRead: TGraphStreamEvent read fOnObjectRead write fOnObjectRead;
    property OnObjectWrite: TGraphStreamEvent read fOnObjectWrite write fOnObjectWrite;
    property OnObjectHook: TGraphHookEvent read fOnObjectHook write fOnObjectHook;
    property OnObjectUnhook: TGraphHookEvent read fOnObjectUnhook write fOnObjectUnhook;
    property OnCanHookLink: TGraphCanHookEvent read fOnCanHookLink write fOnCanHookLink;
    property OnCanLinkObjects: TGraphCanLinkEvent read fOnCanLinkObjects write fOnCanLinkObjects;
    property OnCanMoveResizeNode: TCanMoveResizeNodeEvent read fOnCanMoveResizeNode write fOnCanMoveResizeNode;
    property OnCanRemoveObject: TGraphCanRemoveEvent read fOnCanRemoveObject write fOnCanRemoveObject;
    property OnNodeMoveResize: TGraphNodeResizeEvent read fOnNodeMoveResize write fOnNodeMoveResize;
    property OnGraphChange: TNotifyEvent read fOnGraphChange write fOnGraphChange;
    property OnCommandModeChange: TNotifyEvent read fOnCommandModeChange write fOnCommandModeChange;
    property OnBeforeDraw: TGraphDrawEvent read fOnBeforeDraw write fOnBeforeDraw;
    property OnAfterDraw: TGraphDrawEvent read fOnAfterDraw write fOnAfterDraw;
    property OnInfoTip: TGraphInfoTipEvent read fOnInfoTip write fOnInfoTip;
    property OnZoomChange: TNotifyEvent read fOnZoomChange write fOnZoomChange;
  end;

function WrapText(Canvas: TCanvas; const Text: String; MaxWidth: Integer): String;
function MinimizeText(Canvas: TCanvas; const Text: String; const Rect: TRect): String;

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

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

function NormalizeAngle(const Angle: Double): Double;

function EqualPoint(const Pt1, Pt2: TPoint): Boolean;
procedure TransformPoints(var Points: array of TPoint; const XForm: TXForm);
procedure RotatePoints(var Points: array of TPoint; const Angle: Double; const OrgPt: TPoint);
procedure ScalePoints(var Points: array of TPoint; const Factor: Double; const RefPt: TPoint);
procedure ShiftPoints(var Points: array of TPoint; dX, dY: Integer; const RefPt: 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 NearestPoint(const Points: array of TPoint; const RefPt: TPoint;
  out NearestPt: TPoint): Integer;

function MakeSquare(const Center: TPoint; Radius: Integer): TRect;
function MakeRect(const Corner1, Corner2: TPoint): TRect;
function CenterOfRect(const Rect: TRect): TPoint;
procedure UnionRect(var DstRect: TRect; const SrcRect: TRect);
procedure IntersectRect(var DstRect: TRect; const SrcRect: TRect);
function OverlappedRect(const Rect1, Rect2: TRect): Boolean;

function LineLength(const LinePt1, LinePt2: TPoint): Double;
function LineSlopeAngle(const LinePt1, LinePt2: TPoint): Double;
function DistanceToLine(const LinePt1, LinePt2: TPoint; const QueryPt: TPoint): Double;
function NearestPointOnLine(const LinePt1, LinePt2: TPoint; const RefPt: TPoint): TPoint;
function NextPointOfLine(const LineAngle: Double; const ThisPt: TPoint;
  const DistanceFromThisPt: Double): TPoint;

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

function IntersectLineRect(const LinePt: TPoint; const LineAngle: Double;
  const Rect: TRect): TPoints;
function IntersectLineEllipse(const LinePt: TPoint; const LineAngle: Double;
  const Bounds: TRect): TPoints;
function IntersectLineRoundRect(const LinePt: TPoint; const LineAngle: Double;
  const Bounds: TRect; CW, CH: Integer): TPoints;
function IntersectLinePolygon(const LinePt: TPoint; const LineAngle: Double;
  const Vertices: array of TPoint): TPoints;
function IntersectLinePolyline(const LinePt: TPoint; const LineAngle: Double;
  const Vertices: array of TPoint): TPoints;

var
  CF_SIMPLEGRAPH: Integer = 0;

procedure Register;

implementation

{$R *.RES}

uses
  {$IFDEF COMPILER6_UP} Types, {$ENDIF}
  Math, SysUtils, CommCtrl, Clipbrd;

resourcestring
  SListIndexError     = 'Index out of range (%d)';
  SListEnumerateError = 'List enumeration is not initialized';
  SStreamContentError = 'Invalid stream content';
  SLinkCreateError    = 'Cannot create link with the specified parameters'; 

const
  StreamSignature: DWORD =
    (Ord('S') shl 24) or (Ord('G') shl 16) or (Ord('.') shl 8) or Ord('0');

const
  TextAlignFlags: array[TAlignment] of Integer = (DT_LEFT, DT_RIGHT, DT_CENTER);
  TextLayoutFlags: array[TTextLayout] of Integer = (DT_TOP, DT_VCENTER, DT_BOTTOM);

const
  SpaceChars = [' ', ^I];
  BreakChars = ['.', ',', ';', '?', '!', '-', ':', ')', ']', '}', '>', '/', '\'] + SpaceChars;

const
  Pi: Double = System.Pi;
  MaxDouble: Double = +1.7E+308;

const
  EmptyRect: TRect = (Left: +MaxInt; Top: +MaxInt; Right: -MaxInt; Bottom: -MaxInt);

var
  RegisteredNodeClasses: TList;
  RegisteredLinkClasses: TList;

{ Helper Functions }

type TParentControl = class(TWinControl);

{ This procedure is adapted from RxLibrary VCLUtils. }
procedure CopyParentImage(Control: TControl; DC: HDC; X, Y: Integer);
var
  I, SaveIndex: Integer;
  SelfR, CtlR: TRect;
  NextControl: TControl;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  with Control.Parent do
    ControlState := ControlState + [csPaintCopy];
  try
    SelfR := Control.BoundsRect;
    Inc(X, SelfR.Left);
    Inc(Y, SelfR.Top);
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, -X, -Y, nil);
      with TParentControl(Control.Parent) do
      begin
        with ClientRect do
          IntersectClipRect(DC, Left, Top, Right, Bottom);
        {$IFDEF COMPILER9_UP}
        Perform(WM_PRINT, DC, PRF_CHECKVISIBLE or WM_ERASEBKGND or PRF_CHILDREN);
        {$ELSE}
        Perform(WM_ERASEBKGND, DC, 0);
        PaintWindow(DC);
        {$ENDIF}
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    for I := 0 to Control.Parent.ControlCount - 1 do
    begin
      NextControl := Control.Parent.Controls[I];
      if NextControl = Control then
        Break
      else if (NextControl <> nil) and (NextControl is TGraphicControl) then
      begin
        with TGraphicControl(NextControl) do
        begin
          CtlR := BoundsRect;
          if Visible and OverlappedRect(SelfR, CtlR) then
          begin
            ControlState := ControlState + [csPaintCopy];
            SaveIndex := SaveDC(DC);
            try
              SetViewportOrgEx(DC, Left - X, Top - Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_ERASEBKGND, DC, 0);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
          end;
        end;
      end;
    end;
  finally
    with Control.Parent do
      ControlState := ControlState - [csPaintCopy];
  end;
end;

function WrapText(Canvas: TCanvas; const Text: String; MaxWidth: Integer): String;
var
  DC: HDC;
  TextExtent: TSize;
  S, P, E: PChar;
  Line: String;
  IsFirstLine: Boolean;
begin
  Result := '';
  DC := Canvas.Handle;
  IsFirstLine := True;
  P := PChar(Text);
  while P^ in SpaceChars do
    Inc(P);
  while P^ <> #0 do
  begin
    S := P;
    E := nil;
    while not (P^ in [#0, #13, #10]) do
    begin
      GetTextExtentPoint32(DC, S, P - S + 1, TextExtent);
      if (TextExtent.CX > MaxWidth) and (E <> nil) then
      begin
        if not (P^ in SpaceChars) then
        begin
          while (E >= S) and not (E^ in BreakChars) do
            Dec(E);
          if E < S then
            E := P - 1;
        end;
        Break;
      end;
      E := P;
      Inc(P);
    end;
    if E <> nil then
    begin
      while (E >= S) and (E^ in SpaceChars) do
        Dec(E);
    end;
    if E <> nil then
      SetString(Line, S, E - S + 1)
    else
      SetLength(Line, 0);
    if P^ in [#13, #10] then
    begin
      Inc(P);
      if (P^ <> (P - 1)^) and (P^ in [#13, #10]) then
        Inc(P);
      if P^ = #0 then
        Line := Line + #13#10;
    end
    else if not (P^ in SpaceChars) then
      P := E + 1;
    while P^ in SpaceChars do
      Inc(P);
    if IsFirstLine then
    begin
      Result := Line;
      IsFirstLine := False;
    end
    else
      Result := Result + #13#10 + Line;
  end;
end;

functio