Нужен движок рисования блок схем по типу Worda, Visio. Либо подскажите, как отображать интерактивные схемы технических объектов.

Не знаю как в Delphi, но в Borland C++ 5.02 в примерах есть то, что тебе надо.

Цитата

Либо подскажите, как отображать интерактивные схемы технических объектов.

Я бы сделал массив модифицированых TShape, поищи, наверняка на Torry есть такие компоненты.

Цитата(Vex @ 6.6.2004, 11:21)

Не знаю как в Delphi, но в Borland C++ 5.02 в примерах есть то, что тебе надо. Цитата Либо подскажите, как отображать интерактивные схемы технических объектов. Я бы сделал массив модифицированых TShape, поищи, наверняка на Torry есть такие компоненты.

Vex, подскажи какой именно пример в с++, а TShape не очень хорошо пошел: канва по любому прямоугольник, наложение крупного элемента на небольшой и др. неприятности

Там, не блок схемы, а просто геометрические фигуры, как в Word.
Вот тут: $Borland C++ 5.02$\Examlpes\MFC\OLE\DRAWCLI

Vex спасибо. Что интересно, когда сохраняешь схему нарисованную в Word как web, то с одной стороны экспортируется gif картинка всего изображения , с другой стороны в этой странице созданная картинка не используется, там как-то через XML идет обращение к модулю рисования этих схем (наверное dll). Вот бы код этого модуля заполучить на просмотр.

Подарок Дорабатывай сам.
unit VectorImage;

interface

uses
Windows, Messages, SysUtils, Classes, Controls, ExtCtrls,Contnrs, Graphics,
Forms,StdCtrls;

type
TDoublePoint=record
X,Y:double;
end;

TDrawOptoins=set of (doVisible,doShadowed);

TDrawPoint=class
private
fOrigin:TDoublePoint;
fColor: TColor;
fOptions: TDrawOptoins;
fBStyle: TBrushStyle;
fPStyle: TPenStyle;
fWidth: integer;
fBColor: TColor;
function GetOrigin: TPoint;
function GetVisible: boolean;
procedure SetVisible(const Value: boolean);
function GetShadowF: boolean;
procedure SetShadowF(const Value: boolean);
protected
procedure SetOrigin(const Value: TPoint); virtual;
procedure DoDraw(Canvas:TCanvas); virtual;
procedure DrawShadow(Canvas:TCanvas; Color:TColor; Size:integer); virtual;
class function DrawCmd:string; virtual;
function ScriptInfo:string; virtual;
procedure GetScriptInfo(Script:string); virtual;
procedure FromScript(Script:string);
public
function ToScript:string;
procedure Draw(Canvas:TCanvas);
constructor Create(APoint:TPoint); virtual;
function Distance(APoint:TPoint):double; virtual;
procedure Scale(kX,kY:double); virtual;
procedure Move(dX,dY:integer); virtual;
function GetRect:TRect; virtual;
published
property Origin:TPoint read GetOrigin write SetOrigin;
property Color:TColor read fColor write fColor;
property Visible:boolean read GetVisible write SetVisible;
property Shadowed:boolean read GetShadowF write SetShadowF;
property BrushStyle:TBrushStyle read fBStyle write fBStyle;
property BrushColor:TColor read fBColor write fBColor;
property PenStyle:TPenStyle read fPStyle write fPStyle;
property PenWidth:integer read fWidth write fWidth;
end;

TDrawObject=class of TDrawPoint;

TDrawLine=class(TDrawPoint)
private
fEnd:TDoublePoint;
function GetEnd: TPoint;
protected
function ScriptInfo:string; override;
procedure SetOrigin(const Value: TPoint); override;
procedure SetEnd(const Value: TPoint); virtual;
procedure DoDraw(Canvas:TCanvas); override;
procedure DrawShadow(Canvas:TCanvas; Color:TColor; Size:integer); override;
procedure GetScriptInfo(Script:string); override;
public
function GetRect:TRect; override;
constructor Create(APoint:TPoint); override;
function Distance(APoint:TPoint):double; override;
procedure Scale(kX,kY:double);override;
procedure Move(dX,dY:integer);override;
published
property EndPoint:TPoint read GetEnd write SetEnd;
end;

TArrowStyle = (asOpen,asClosed,asCircle,asRomb,asLine);

TDrawArrow=class(TDrawLine)
private
fStyle: TArrowStyle;
protected
function ScriptInfo:string; override;
procedure DoDraw(Canvas:TCanvas); override;
procedure GetScriptInfo(Script:string); override;
public
function GetRect:TRect; override;
constructor Create(APoint:TPoint); override;
published
property Style:TArrowStyle read fStyle write fStyle;
end;

TDrawArc=class(TDrawLine)
private
fCenter:TDoublePoint;
function GetCenter: TPoint;
procedure SetCenter(const Value: TPoint);
protected
function ScriptInfo:string; override;
procedure GetScriptInfo(Script:string); override;
procedure DoDraw(Canvas:TCanvas); override;
procedure DrawShadow(Canvas:TCanvas; Color:TColor; Size:integer); override;
public
function GetRect:TRect; override;
constructor Create(APoint:TPoint); override;
function Distance(APoint:TPoint):double; override;
procedure Scale(kX,kY:double);override;
procedure Move(dX,dY:integer);override;
published
property Center:TPoint read GetCenter write SetCenter;
end;

TDrawRect=class(TDrawLine)
protected
procedure DoDraw(Canvas:TCanvas); override;
procedure DrawShadow(Canvas:TCanvas; Color:TColor; Size:integer); override;
public
function Distance(APoint:TPoint):double; override;
end;

TDrawEllipse=class(TDrawRect)
protected
procedure DoDraw(Canvas:TCanvas); override;
procedure DrawShadow(Canvas:TCanvas; Color:TColor; Size:integer); override;
end;

TDrawText=class(TDrawRect{TDrawLine})
private
fCaption: string;
protected
function ScriptInfo:string; override;
procedure GetScriptInfo(Script:string); override;
procedure DoDraw(Canvas:TCanvas); override;
published
property Caption:string read fCaption write fCaption;
end;

TDrawPolyLine=class(TDrawLine)
private
fPoints:array of TDoublePoint;
function GetPoint(Index: integer): TPoint;
procedure SetPoint(Index: integer; const Value: TPoint);
procedure CalcRect;
protected
function ScriptInfo:string; override;
procedure GetScriptInfo(Script:string); override;
procedure GetPoints(var Value:array of TPoint);
procedure SetLast(APoint:TPoint);
procedure DelLast;
procedure SetEnd(const Value: TPoint); override;
procedure DoDraw(Canvas:TCanvas); override;
public
constructor Create(APoint:TPoint); override;
function Count:integer;
function NearPoint(APoint:TPoint):integer;
function AddPoint(APoint:TPoint):integer;
procedure Delete(Index:integer);
property Points[Index:integer]:TPoint read GetPoint write SetPoint;
function Distance(APoint:TPoint):double; override;
procedure Scale(kX,kY:double);override;
procedure Move(dX,dY:integer);override;
end;

TDrawPolygon=class(TDrawPolyLine)
protected
procedure DoDraw(Canvas:TCanvas); override;
end;

TDrawPolyBezier=class(TDrawPolyLine)
protected
procedure DoDraw(Canvas:TCanvas); override;
end;

TImageOptions=set of (ioEditable,ioAutoSize,ioAutoScale,ioAdd,ioAutoScript);

TShapeEvent=procedure(Sender:TObject; Shape:TDrawPoint) of object;
TMousePosEvent=procedure(Sender:TObject; APoint:TPoint) of object;

TVectorImage = class(TImage)
private
fScript:string;
fOrig,fEnd,fExt:TShape;
fShapes:TObjectList;
fCurShape:TDrawPoint;
fTool: TDrawObject;
fOptions: TImageOptions;
fPenColor: TColor;
oldW,oldH,EdPoint:integer;
fGridY: integer;
fGridX: integer;
fOnAdd: TShapeEvent;
fOnSelect: TShapeEvent;
fOnChang: TShapeEvent;
fOnMouse: TMousePosEvent;
fGridColor: TColor;
fOldPos:TPoint;
fMarkers:TStrings;
fOnResize: TNotifyEvent;
function Editable: Boolean;
procedure GetShape(var sh:TShape; Color:TColor; Point:TPoint);
procedure HideShape;
procedure GetNear(Point:TPoint);
procedure SetTool(const Value: TDrawObject);
function GetItem(Index: integer): TDrawPoint;
procedure SetItem(Index: integer; const Value: TDrawPoint);
procedure SetShape(const Value: TDrawPoint);
procedure SetGrid(const Index, Value: integer);
function ToGrid(var X,Y:integer):boolean;
procedure DrawGrid(Canvas:TCanvas);
procedure SetOptions(const Value: TImageOptions);
function GetScript: string;
procedure SetScript(const Value: string);
protected
procedure Loaded; override;
procedure Resize; 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 ShapeMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure ShapeMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure ShapeMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
public
constructor Create(AOwner:TComponent); override;
destructor Destroy; override;
class procedure RegisterTools(Tools:array of TDrawObject);
procedure ReDraw(ARect:TRect); overload;
procedure ReDraw; overload;
procedure Mark(AShape:TDrawPoint;const ACaption:String); overload;
procedure Mark(const ACaption:String); overload;
function GetMarker(AShape:TDrawPoint):string;
function GetMarked(const ACaption:String):TDrawPoint;
procedure GetMarkers(AList:TStrings);
procedure DelCurrent;
procedure Clear;
function Count:integer;
procedure AddShape(APoint:TPoint;Tool:TDrawObject=nil);
procedure DelShape(Index:Integer);
property Current:TDrawPoint read fCurShape write SetShape;
property DrawingTool:TDrawObject read fTool write SetTool;
property Shapes[Index:integer]:TDrawPoint read GetItem write SetItem;
function GenScript(UseCrLf:boolean=false):string;
procedure DoScript(Script:String);
published
property Options:TImageOptions read fOptions write SetOptions;
property PenColor:TColor read fPenColor write fPenColor;
property GridX:integer index 0 read fGridX write SetGrid;
property GridY:integer index 1 read fGridY write SetGrid;
property GridColor:TColor read fGridColor write fGridColor;
property Color;
property Script:string read GetScript write SetScript;
property OnSelectShape:TShapeEvent read fOnSelect write fOnSelect;
property OnAddShape:TShapeEvent read fOnAdd write fOnAdd;
property OnShapeChanged:TShapeEvent read fOnChang write fOnChang;
property OnMousePosChanged:TMousePosEvent read fOnMouse write fOnMouse;
property OnResize:TNotifyEvent read fOnResize write fOnResize;
end;

TBrushStyleCombo = class(TCustomComboBox)
private
function GetSelection: TBrushStyle;
procedure SetSelection(Value: TBrushStyle);
protected
procedure SetStyle(Value: TComboBoxStyle); override;
procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
procedure CreateWnd; override;
public
constructor Create(AOwner: TComponent); override;
procedure SetStyleList; virtual;
published
property Selected: TBrushStyle read GetSelection write SetSelection;
property Color;
property Ctl3D;
property DragMode;
property DragCursor;
property DropDownCount;
property Enabled;
property Font;
property ItemHeight;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Sorted;
property TabOrder;
property TabStop;
property Text;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnDrawItem;
property OnDropDown;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMeasureItem;
property OnStartDrag;
end;

TPenStyleCombo = class(TCustomComboBox)
private
function GetSelection: TPenStyle;
procedure SetSelection(Value: TPenStyle);
protected
procedure SetStyle(Value: TComboBoxStyle); override;
procedure DrawItem(Index: Integer; Rect: TRect;
State: TOwnerDrawState); override;
procedure CreateWnd; override;
public
constructor Create(AOwner: TComponent); override;
procedure SetStyleList; virtual;
published
property Selected: TPenStyle read GetSelection write SetSelection;
property Color;
property Ctl3D;
property DragMode;
property DragCursor;
property DropDownCount;
property Enabled;
property Font;
property ItemHeight;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Sorted;
property TabOrder;
property TabStop;
property Text;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnDrawItem;
property OnDropDown;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMeasureItem;
property OnStartDrag;
end;

TArrowStyleCombo = class(TCustomComboBox)
private
function GetSelection: TArrowStyle;
procedure SetSelection(Value: TArrowStyle);
protected
procedure SetStyle(Value: TComboBoxStyle); override;
procedure DrawItem(Index: Integer; Rect: TRect;
State: TOwnerDrawState); override;
procedure CreateWnd; override;
public
constructor Create(AOwner: TComponent); override;
procedure SetStyleList; virtual;
published
property Selected: TArrowStyle read GetSelection write SetSelection;
property Color;
property Ctl3D;
property DragMode;
property DragCursor;
property DropDownCount;
property Enabled;
property Font;
property ItemHeight;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Sorted;
property TabOrder;
property TabStop;
property Text;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnDrawItem;
property OnDropDown;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMeasureItem;
property OnStartDrag;
end;

procedure Register;

function PDistance(FromPoint,ToPoint:TPoint):double;
function LDistance(LineStart,LineEnd,ToPoint:TPoint):double;

function Point(X,Y:integer):TPoint; overload;
function Point(APoint:TDoublePoint):TPoint; overload;
function Point(APoint:TPoint):TDoublePoint; overload;

procedure DrawArrow(Canvas:TCanvas; pfrom, pto: TPoint; ArrowStyle : TArrowStyle;HeadLength :integer= 10);
function LineCross(const A1,A2, B1,B2: TPoint):TPoint;

function WrapStr(var Src:string; Len:integer):string;

implementation
uses Math,TypInfo;
const
Epsilon = 1e-8;
ShadowSize=2;
ShadowColor=clSilver;
type
THackWinControl=class(TWinControl);
// THackCanvas=class(TCanvas);
var
fGraphTools:TClassList=nil;

procedure Register;
begin
RegisterComponents('Additional', [TVectorImage,TBrushStyleCombo,TPenStyleCombo,TArrowStyleCombo]);
end;

function LineCross(const A1,A2, B1,B2: TPoint):TPoint;
var Xa,Xb,Xc,Xd,
Ya,Yb,Yc,Yd,
dx1,dy1,dx2,dy2,
D, P2: double;
begin
result.X:=-1;
result.Y:=-1;
Xa:=A1.X; Ya:=A1.Y;
Xb:=A2.X; Yb:=A2.Y;
Xc:=B1.X; Yc:=B1.Y;
Xd:=B2.X; Yd:=B2.Y;

dx1:=Xb-Xa; dy1:=Yb-Ya;
dx2:=Xd-Xc; dy2:=Yd-Yc;
D:=dy1*dx2 - dy2*dx1;

if Abs(D) < Epsilon then EXIT;

P2:=(dy1*(Xa-Xc)-dx1*(Ya-Yc))/D;
result.X:=Round(Xc+dx2*P2);
result.Y:=Round(Yc+dy2*P2);
end;

procedure DrawArrow(Canvas:TCanvas; pfrom, pto: TPoint; ArrowStyle : TArrowStyle;HeadLength :integer= 10);
var
x1,x2: Integer;
y1,y2: Integer;
xbase: Integer;
xLineDelta: Integer;
xLineUnitDelta: Double;
xNormalDelta: Integer;
xNormalUnitDelta: Double;
ybase: Integer;
yLineDelta: Integer;
yLineUnitDelta: Double;
yNormalDelta: Integer;
yNormalUnitDelta: Double;
Tmp1 : double;
begin
x1 := pfrom.x; // first point
y1 := pfrom.y;

x2 := pto.x; // second point with arrow
y2 := pto.y;

Canvas.MoveTo(x1,y1);
Canvas.LineTo(x2,y2);

xLineDelta := x2 - x1;
yLineDelta := y2 - y1;

if (xLineDelta=0) and (yLineDelta=0) then exit; // Line is 0 length
if (abs(xLineDelta)>20000) or (abs(yLineDelta)>20000) then exit; // Line is too long

Tmp1 := SQRT( SQR(xLineDelta) + SQR(yLineDelta) );
if Tmp1=0 then
xLineUnitDelta := 0
else
xLineUnitDelta := xLineDelta / Tmp1;

Tmp1 := SQRt( SQR(xLineDelta) + SQR(yLineDelta) );
if Tmp1=0 then
yLineUnitDelta := 0
else
yLineUnitDelta := yLineDelta / Tmp1;

// (xBase,yBase) is where arrow line is perpendicular to base of triangle.
// pixels
xBase := x2 - Round(HeadLength * xLineUnitDelta);
yBase := y2 - Round(HeadLength * yLineUnitDelta);

xNormalDelta := yLineDelta;
yNormalDelta := -xLineDelta;
xNormalUnitDelta := xNormalDelta / Sqrt( Sqr(xNormalDelta) + Sqr(yNormalDelta) );
yNormalUnitDelta := yNormalDelta / Sqrt( Sqr(xNormalDelta) + Sqr(yNormalDelta) );

HeadLength:=HeadLength div 2;

// Draw the arrow tip
case ArrowStyle of
asClosed :
Canvas.Polygon([Point(x2,y2),
Point(xBase + ROUND(HeadLength*xNormalUnitDelta),
yBase + ROUND(HeadLength*yNormalUnitDelta)),
Point(xBase - ROUND(HeadLength*xNormalUnitDelta),
yBase - ROUND(HeadLength*yNormalUnitDelta)) ]);
asOpen :
Canvas.Polyline([Point(xBase + ROUND(HeadLength*xNormalUnitDelta),
yBase + ROUND(HeadLength*yNormalUnitDelta)),
Point(x2,y2),
Point(xBase - ROUND(HeadLength*xNormalUnitDelta),
yBase - ROUND(HeadLength*yNormalUnitDelta)) ]);
asLine:
Canvas.Polyline([Point(xBase + ROUND(HeadLength*xNormalUnitDelta),
yBase + ROUND(HeadLength*yNormalUnitDelta)),
Point(xBase - ROUND(HeadLength*xNormalUnitDelta),
yBase - ROUND(HeadLength*yNormalUnitDelta)) ]);
asCircle:
begin
Canvas.Ellipse(x2-5,y2-5,x2+5,y2+5);
end;
asRomb:
begin
x1:=x2 - Round(HeadLength * 4 * xLineUnitDelta);
y1:=y2 - Round(HeadLength * 4 * yLineUnitDelta);
Canvas.Polygon([Point(x2,y2),
Point(xBase + ROUND(HeadLength*xNormalUnitDelta),
yBase + ROUND(HeadLength*yNormalUnitDelta)),
Point(x1,y1),
Point(xBase - ROUND(HeadLength*xNormalUnitDelta),
yBase - ROUND(HeadLength*yNormalUnitDelta)) ]);
end;
end;

end;

function MaxRect(R1,R2:TRect):TRect;
begin
result.Left:=Max(Min(R1.Left,R2.Left)-1,0);
result.Top:=Max(Min(R1.Top,R2.Top)-1,0);
result.Right:=Max(R1.Right,R2.Right)+1;
result.Bottom:=Max(R1.Bottom,R2.Bottom)+1;
end;

function PDistance(FromPoint,ToPoint:TPoint):double;
begin
result:=sqrt(sqr(FromPoint.X-ToPoint.X)+sqr(FromPoint.Y-ToPoint.Y));
end;

function LDistance(LineStart,LineEnd,ToPoint:TPoint):double;
var A,B,C: double;
begin
A:=LineEnd.Y-LineStart.Y;
B:=LineStart.X-LineEnd.X;
C:= -A*LineStart.X - B*LineStart.Y;
Result := Abs(A*ToPoint.X + B*ToPoint.Y + C)/Sqrt(A*A+B*B + Epsilon);
end;

function Point(X,Y:integer):TPoint; overload;
begin
result:=Classes.Point(X,Y);
end;

function Point(APoint:TDoublePoint):TPoint; overload;
begin
result.X:=Round(APoint.X);
result.Y:=Round(APoint.Y);
end;

function Point(APoint:TPoint):TDoublePoint; overload;
begin
result.X:=APoint.X;
result.Y:=APoint.Y;
end;

function WrapStr(var Src:string; Len:integer):string;
var
b:integer;
m,c,d:byte;

function Check:boolean;
begin
result:=true;
if c<>$08 then begin
c:=c shl 1;
result:=false;
exit;
end;
(* 1 - гласная 0 - согласная *)
case m of
$0B: d:=1; {1-011}
$05: d:=2; {01-01}
$09: d:=2; {10-01}
$0A: d:=1; {1-010}
else begin
result:=false;
m:= m shr 1;
exit;
end;
end;{case}
end;


procedure setw;
begin
src:=System.Copy(result,b+d,Length(result));
System.Delete(result,b+d,Length(result));
result:=result+'-';
end;

begin
result:=src;
c:=1; m:=0;
if Length(result)<=Len then begin
src:='';
exit;
end;
for b:=Len+1 downto 1 do
case result[b] of
' ',#9,',','.',';',':','<','>','!','''','"','?','/','+','-','^':
begin
src:=System.Copy(result,b+1,Length(result));
System.Delete(result,b+1,Length(result));
exit;
end;
'А','а','Е','е','У','у','Ы','ы','О','о','Э','э','Я','я','И','и','Ё','ё','Ю','ю':
begin
m:=m or c;
if Check then begin setw; exit; end;
end;
else
if Check then begin setw; exit; end;
end;
src:=System.Copy(result,Len+1,Length(result));
System.Delete(result,Len+1,Length(result));
end;

{ TDrawPoint }

function TDrawPoint.ScriptInfo: string;
begin
result:=IntToStr(Origin.X)+','+IntToStr(Origin.Y);
end;

constructor TDrawPoint.Create(APoint: TPoint);
begin
fOrigin:=Point(APoint);
Visible:=true;
fWidth:=1;
end;

function TDrawPoint.Distance(APoint: TPoint): double;
begin
result:=PDistance(Origin,APoint);
end;

procedure TDrawPoint.DoDraw(Canvas: TCanvas);
begin
Canvas.Pixels[Origin.X,Origin.Y]:=fColor;
end;

procedure TDrawPoint.Draw(Canvas: TCanvas);
var
cl:TColor;
w:integer;
begin
if not Visible then exit;
cl:=Canvas.Pen.Color;
w:=Canvas.Pen.Width;
if Shadowed then DrawShadow(Canvas,cl,w);
Canvas.Pen.Style:=fPStyle;
Canvas.Brush.Style:=fBStyle;
Canvas.Brush.Color:=fBColor;
Canvas.Pen.Color:=Color;
Canvas.Pen.Width:=fWidth;
DoDraw(Canvas);
Canvas.Pen.Color:=cl;
Canvas.Pen.Width:=w;
end;

class function TDrawPoint.DrawCmd: string;
begin
result:=Copy(ClassName,6,100);
end;

procedure TDrawPoint.DrawShadow(Canvas: TCanvas; Color: TColor;
Size: integer);
begin
while Size>0 do begin
Canvas.Pixels[Origin.X+Size,Origin.Y+Size]:=Color;
dec(Size);
end;
end;

function TDrawPoint.GetOrigin: TPoint;
begin
result:=Point(fOrigin);
end;

function TDrawPoint.GetRect: TRect;
begin
result.TopLeft:=Origin;
result.BottomRight:=Origin;
end;

function TDrawPoint.GetShadowF: boolean;
begin
result:=doShadowed in fOptions;
end;

function TDrawPoint.GetVisible: boolean;
begin
result:=doVisible in fOptions;
end;

procedure TDrawPoint.Move(dX,dY:integer);
begin
fOrigin.X:=fOrigin.X+dX;
fOrigin.Y:=fOrigin.Y+dY;
end;

procedure TDrawPoint.Scale(kX,kY:double);
begin
fOrigin.X:=fOrigin.X*kX;
fOrigin.Y:=fOrigin.Y*kY;
end;

procedure TDrawPoint.SetOrigin(const Value: TPoint);
begin
fOrigin:=Point(Value);
end;

procedure TDrawPoint.SetShadowF(const Value: boolean);
begin
if Value then fOptions:=fOptions+[doShadowed]
else fOptions:=fOptions-[doShadowed];
end;

procedure TDrawPoint.SetVisible(const Value: boolean);
begin
if value then fOptions:=fOptions+[doVisible]
else fOptions:=fOptions-[doVisible]
end;

function TDrawPoint.ToScript: string;
begin
result:=DrawCmd+'('''+
ColorToString(fColor)+''','''+
GetEnumName(TypeInfo(TPenStyle),integer(fPStyle))+''','+
IntToStr(fWidth)+','''+
ColorToString(fBColor)+''','''+
GetEnumName(TypeInfo(TBrushStyle),integer(fBStyle))+''',';
if Visible then result:=result+'1' else result:=result+'0';
result:=result+',';
if Shadowed then result:=result+'1' else result:=result+'0';
result:=result+',';
result:=result+ScriptInfo+')';
end;

function GetScriptPart(var Script:string):string;
var
p:integer;
begin
p:=pos(',',Script);
if p=0 then begin
result:=Script;
Script:='';
end else begin
result:=Copy(Script,1,p-1);
Delete(Script,1,p);
end;
if (result<>'')and(result[Length(result)]=')') then SetLength(result,Length(result)-1);
if (result<>'')and(result[1]='''') then result:=Copy(result,2,Length(result)-2);
end;

procedure TDrawPoint.FromScript(Script: string);
var
p:string;
begin
if (Script='')or(Script[1]<>'''') then exit;
p:=GetScriptPart(Script);
fColor:=StringToColor(p);
p:=GetScriptPart(Script);
fPStyle:=TPenStyle(GetEnumValue(TypeInfo(TPenStyle),p));
p:=GetScriptPart(Script);
fWidth:=StrToInt(p);
p:=GetScriptPart(Script);
fBColor:=StringToColor(p);
p:=GetScriptPart(Script);
fBStyle:=TBrushStyle(GetEnumValue(TypeInfo(TBrushStyle),p));
p:=GetScriptPart(Script);
if p='1' then Visible:=true else Visible:=false;
p:=GetScriptPart(Script);
if p='1' then Shadowed:=true else Shadowed:=false;
GetScriptInfo(Script);
end;

procedure TDrawPoint.GetScriptInfo(Script: string);
var
p:string;
begin
p:=GetScriptPart(Script);
fOrigin.X:=StrToInt(p);
p:=GetScriptPart(Script);
fOrigin.Y:=StrToInt(p);
end;

{ TDrawLine }

constructor TDrawLine.Create(APoint: TPoint);
begin
inherited;
fEnd:=Point(APoint);
end;

function TDrawLine.Distance(APoint: TPoint): double;
begin
result:=LDistance(Origin,EndPoint,APoint);
end;

procedure TDrawLine.DoDraw(Canvas: TCanvas);
begin
Canvas.MoveTo(Origin.X,Origin.Y);
Canvas.LineTo(EndPoint.X,EndPoint.Y);
end;

procedure TDrawLine.DrawShadow(Canvas: TCanvas; Color: TColor;
Size: integer);
var
o,e:TDoublePoint;
begin
o:=fOrigin; e:=fEnd;
if Origin.X=EndPoint.X then begin
fOrigin.Y:=fOrigin.Y+Size;
fEnd.Y:=fEnd.Y+Size;
while Size>0 do begin
fOrigin.X:=fOrigin.X+Size;
fEnd.X:=fOrigin.X;
dec(Size);
DoDraw(Canvas);
end;
end else
if Origin.Y=EndPoint.Y then begin
fOrigin.X:=fOrigin.X+Size;
fEnd.X:=fEnd.X+Size;
while Size>0 do begin
fOrigin.Y:=fOrigin.Y+Size;
fEnd.Y:=fOrigin.Y;
dec(Size);
DoDraw(Canvas);
end;
end;
fOrigin:=o; fEnd:=e;
end;

function TDrawLine.GetEnd: TPoint;
begin
result:=Point(fEnd);
end;

function TDrawLine.GetRect: TRect;
begin
result.Left:=Min(Origin.X,EndPoint.X);
result.Right:=Max(Origin.X,EndPoint.X)+ShadowSize+1;
result.Top:=Min(Origin.Y,EndPoint.Y);
result.Bottom:=Max(Origin.Y,EndPoint.Y)+ShadowSize+1;
end;

procedure TDrawLine.GetScriptInfo(Script: string);
var
p:string;
begin
p:=GetScriptPart(Script);
fOrigin.X:=StrToInt(p);
p:=GetScriptPart(Script);
fOrigin.Y:=StrToInt(p);
p:=GetScriptPart(Script);
fEnd.X:=StrToInt(p);
p:=GetScriptPart(Script);
fEnd.Y:=StrToInt(p);
end;

procedure TDrawLine.Move(dX,dY:integer);
begin
inherited;
fEnd.X:=fEnd.X+dX;
fEnd.Y:=fEnd.Y+dY;
end;

procedure TDrawLine.Scale(kX, kY:double);
begin
inherited;
fEnd.X:=fEnd.X*kX;
fEnd.Y:=fEnd.Y*kY;
end;

function TDrawLine.ScriptInfo: string;
begin
result:=inherited ScriptInfo+','+IntToStr(EndPoint.X)+','+IntToStr(EndPoint.Y);
end;

procedure TDrawLine.SetEnd(const Value: TPoint);
begin
fEnd:=Point(Value);
end;

procedure TDrawLine.SetOrigin(const Value: TPoint);
var
p:TPoint;
begin
p:=Origin;
// inherited;
Move(Value.X-P.X,Value.Y-P.Y);
end;


{ TDrawArrow }

constructor TDrawArrow.Create(APoint: TPoint);
begin
inherited;
fStyle:=asOpen;
end;

procedure TDrawArrow.DoDraw(Canvas: TCanvas);
begin
DrawArrow(Canvas,Origin,EndPoint,fStyle);
end;

function TDrawArrow.GetRect: TRect;
begin
result:=inherited GetRect;
result.Left:=Max((result.Left-5),0);
result.Top:=Max((result.Top-5),0);
result.Right:=result.Right+5;
result.Bottom:=result.Bottom+5;
end;

procedure TDrawArrow.GetScriptInfo(Script: string);
var
p:string;
begin
p:=GetScriptPart(Script);
fStyle:=TArrowStyle(GetEnumValue(TypeInfo(TArrowStyle),p));
inherited GetScriptInfo(Script);
end;

function TDrawArrow.ScriptInfo: string;
begin
result:=''''+GetEnumName(TypeInfo(TArrowStyle),integer(fStyle))+''','+
inherited ScriptInfo;
end;

{ TDrawArc }

constructor TDrawArc.Create(APoint: TPoint);
begin
inherited;
Center:=APoint;
end;

function TDrawArc.Distance(APoint: TPoint): double;
var
d1,d2:double;
begin
d1:=sqrt(sqr(Origin.X-APoint.X)+sqr(Origin.Y-APoint.Y));
d2:=sqrt(sqr(EndPoint.X-APoint.X)+sqr(EndPoint.Y-APoint.Y));
if d1<d2 then result:=d1 else result:=d2;
end;

procedure TDrawArc.DoDraw(Canvas: TCanvas);
var
r:TRect;
begin
r:=GetRect;
Canvas.Arc(r.Left,r.Top,r.Right,r.Bottom,Origin.X,Origin.Y,EndPoint.X,EndPoint.Y);
end;

procedure TDrawArc.DrawShadow(Canvas: TCanvas; Color: TColor;
Size: integer);
begin
//
end;

function TDrawArc.GetCenter: TPoint;
begin
result:=Point(fCenter);
end;

function TDrawArc.GetRect: TRect;
var
r:integer;
begin
r:=Round(sqrt(sqr(Origin.X-Center.X)+sqr(Origin.Y-Center.Y)));
result.Left:=Center.X-r;
result.Top:=Center.Y-r;
result.Right:=Center.X+R;
result.Bottom:=Center.Y+R;
end;

procedure TDrawArc.GetScriptInfo(Script: string);
var
p:string;
begin
p:=GetScriptPart(Script);
fOrigin.X:=StrToInt(p);
p:=GetScriptPart(Script);
fOrigin.Y:=StrToInt(p);
p:=GetScriptPart(Script);
fEnd.X:=StrToInt(p);
p:=GetScriptPart(Script);
fEnd.Y:=StrToInt(p);
p:=GetScriptPart(Script);
fCenter.X:=StrToInt(p);
p:=GetScriptPart(Script);
fCenter.Y:=StrToInt(p);
end;

procedure TDrawArc.Move(dX,dY:integer);
begin
inherited;
fCenter.X:=fCenter.X+dX;
fCenter.Y:=fCenter.Y+dY;
end;

procedure TDrawArc.Scale(kX, kY: double);
begin
inherited;
fCenter.X:=fCenter.X*kX;
fCenter.Y:=fCenter.Y*kY;
end;

function TDrawArc.ScriptInfo: string;
begin
result:=inherited ScriptInfo+','+IntToStr(Center.X)+','+IntToStr(Center.Y);
end;

procedure TDrawArc.SetCenter(const Value: TPoint);
begin
fCenter:=Point(Value);
end;

{ TDrawRect }

function TDrawRect.Distance(APoint: TPoint): double;
var
d:double;
begin
result:=LDistance(Point(Origin.X,EndPoint.Y),Point(Origin.X,Origin.Y),APoint);
d:=LDistance(Point(EndPoint.X,EndPoint.Y),Point(EndPoint.X,Origin.Y),APoint);
if d<result then result:=d;
d:=LDistance(Point(EndPoint.X,EndPoint.Y),Point(Origin.X,EndPoint.Y),APoint);
if d<result then result:=d;
d:=LDistance(Point(EndPoint.X,Origin.Y),Point(Origin.X,Origin.Y),APoint);
if d<result then result:=d;
end;

procedure TDrawRect.DoDraw(Canvas: TCanvas);
begin
Canvas.Rectangle(Origin.X,Origin.Y,EndPoint.X,EndPoint.Y);
end;

procedure TDrawRect.DrawShadow(Canvas: TCanvas; Color: TColor;
Size: integer);
var
vX,vY,hX,hY,vL,hL:integer;
begin
hX:=Min(Origin.X,EndPoint.X);
hY:=Max(Origin.Y,EndPoint.Y);
vX:=Max(Origin.X,EndPoint.X);
vY:=Min(Origin.Y,EndPoint.Y);
hL:=vX-hX; hX:=hX+Size;
vL:=hY-vY; vY:=vY+Size;
while Size>0 do begin
Canvas.MoveTo(hX,hY); Canvas.LineTo(hX+hL,hY);
inc(hY);
Canvas.MoveTo(vX,vY); Canvas.LineTo(vX,vY+vL);
inc(vX);
dec(Size);
end;
end;

{ TDrawEllipse }

procedure TDrawEllipse.DoDraw(Canvas: TCanvas);
begin
Canvas.Ellipse(Origin.X,Origin.Y,EndPoint.X,EndPoint.Y);
end;

procedure TDrawEllipse.DrawShadow(Canvas: TCanvas; Color: TColor;
Size: integer);
begin
//
end;

{ TDrawPolyLine }

function TDrawPolyLine.AddPoint(APoint: TPoint): integer;
begin
SetLength(fPoints,Count+1);
fPoints[Count-1]:=Point(APoint);
result:=Length(fPoints);
end;

function TDrawPolyLine.Count: integer;
begin
result:=Length(fPoints);
end;

procedure TDrawPolyLine.Delete(Index: integer);
var
i:integer;
begin
if (Index<0)or(Count=0) then exit;
for i:=Index to Count-2 do
fPoints[i]:=fPoints[i+1];
SetLength(fPoints,Count-1);
end;

function TDrawPolyLine.Distance(APoint: TPoint): double;
var
d:double;
i:integer;
begin
result:=-1;
for i:=1 to Count-1 do begin
d:=LDistance(Points[i-1],Points[i],APoint);
if (d<result)or(result=-1) then result:=d;
end;
end;

function TDrawPolyLine.GetPoint(Index: integer): TPoint;
begin
result:=Point(fPoints[Index]);
end;

procedure TDrawPolyLine.Scale(kX, kY: double);
var
i:integer;
begin
inherited;
for i:=0 to Count-1 do begin
fPoints[i].X:=fPoints[i].X*kX;
fPoints[i].Y:=fPoints[i].Y*kY;
end;
end;

procedure TDrawPolyLine.SetPoint(Index: integer; const Value: TPoint);
begin
fPoints[Index]:=Point(Value);
end;

procedure TDrawPolyLine.GetPoints(var Value: array of TPoint);
var
i:integer;
begin
for i:=0 to Count-1 do Value[i]:=Points[i];
end;

procedure TDrawPolyLine.SetLast(APoint: TPoint);
begin
if Count=0 then AddPoint(APoint)
else Points[Count-1]:=APoint;
CalcRect;
end;

procedure TDrawPolyLine.DoDraw(Canvas: TCanvas);
var
a:array of TPoint;
begin
SetLength(a,Count);
GetPoints(a);
Canvas.Polyline(a);
end;

procedure TDrawPolyLine.DelLast;
begin
if Length(fPoints)>0 then SetLength(fPoints,Length(fPoints)-1);
CalcRect;
end;

procedure TDrawPolyLine.CalcRect;
var
i:integer;
lt,br:TPoint;
begin
lt.X:=-1; lt.Y:=-1;
br.X:=-1; br.Y:=-1;
for i:=0 to Count-1 do begin
if (Points[i].X<lt.X)or(lt.X=-1) then lt.X:=Points[i].X;
if (Points[i].Y<lt.Y)or(lt.Y=-1) then lt.Y:=Points[i].Y;
if (Points[i].X>br.X)or(br.X=-1) then br.X:=Points[i].X;
if (Points[i].Y>br.Y)or(br.Y=-1) then br.Y:=Points[i].Y;
end;
fOrigin.X:=lt.X;
fOrigin.Y:=lt.Y;
fEnd.X:=br.X;
fEnd.Y:=br.Y;
end;

constructor TDrawPolyLine.Create(APoint: TPoint);
begin
inherited;
AddPoint(APoint);
end;

procedure TDrawPolyLine.SetEnd(const Value: TPoint);
var
P:TDoublePoint;
begin
P:=fEnd;
inherited;
Scale(fEnd.X/P.X,fEnd.Y/P.Y);
end;

procedure TDrawPolyLine.Move(dX, dY: integer);
var
i:integer;
begin
inherited;
for i:=0 to Count-1 do begin
fPoints[i].X:=fPoints[i].X+dX;
fPoints[i].Y:=fPoints[i].Y+dY;
end;
end;

function TDrawPolyLine.NearPoint(APoint: TPoint): integer;
var
dist,min:double;
i:integer;
begin
min:=-1;
result:=-1;
for i:=0 to Count-1 do begin
dist:=PDistance(APoint,Points[i]);
if (dist<min)or(min=-1) then begin
min:=dist;
result:=i;
end;
end;
end;

function TDrawPolyLine.ScriptInfo: string;
var
i:integer;
begin
result:=inherited ScriptInfo+',[';
for i:=0 to Count-1 do
result:=result+IntToStr(Points[i].X)+','+IntToStr(Points[i].Y)+',';
if Result[Length(result)]=',' then SetLength(result,Length(result)-1);
result:=result+']';
end;

procedure TDrawPolyLine.GetScriptInfo(Script: string);
var
p:string;
pnt:TPoint;
begin
p:=GetScriptPart(Script);
fOrigin.X:=StrToInt(p);
p:=GetScriptPart(Script);
fOrigin.Y:=StrToInt(p);
p:=GetScriptPart(Script);
fEnd.X:=StrToInt(p);
p:=GetScriptPart(Script);
fEnd.Y:=StrToInt(p);
Script:=Trim(Script);
if (Script<>'')and(Script[1]='[') then System.Delete(Script,1,1);
while (Script<>'')and(Script[Length(Script)] in [']',')']) do SetLength(Script,Length(Script)-1);
while Count>0 do Delete(0);
while Script<>'' do begin
p:=GetScriptPart(Script);
pnt.X:=StrToInt(p);
p:=GetScriptPart(Script);
pnt.Y:=StrToInt(p);
AddPoint(pnt);
end;
CalcRect;
end;

{ TDrawPolygon }

procedure TDrawPolygon.DoDraw(Canvas: TCanvas);
var
a:array of TPoint;
begin
SetLength(a,Count);
GetPoints(a);
Canvas.Polygon(a);
end;

{ TDrawPolyBezier }

procedure TDrawPolyBezier.DoDraw(Canvas: TCanvas);
var
a:array of TPoint;
begin
SetLength(a,Count);
GetPoints(a);
Canvas.PolyBezier(a);
end;

{ TDrawText }

procedure TDrawText.DoDraw(Canvas: TCanvas);
var
Rect:TRect;
Th,Lc,Cw,Cc:integer;
s,p:string;
begin
Canvas.Font.Color:=Color;
Canvas.Font.Height:=PenWidth;
Rect.Left:=Min(Origin.X,EndPoint.X);
Rect.Top:=Min(Origin.Y,EndPoint.Y);
Rect.Right:=Max(Origin.X,EndPoint.X);
Rect.Bottom:=Max(Origin.Y,EndPoint.Y);
Canvas.FillRect(Rect);
if Trim(fCaption)<>'' then
Th:=Canvas.TextHeight(fCaption)
else
Th:=Canvas.TextHeight('H');
Lc:=(Rect.Bottom-Rect.Top) div Th;
if (Lc<1)or(fCaption='') then exit;
Cw:=Canvas.TextWidth(fCaption) div Length(fCaption);
Cc:=(Rect.Right-Rect.Left) div Cw;
Rect.Bottom:=Rect.Top+Th;
s:=fCaption;
while (s<>'')and(Lc>0) do begin
p:=WrapStr(s,Cc);
Canvas.TextOut(Rect.Left,Rect.Top,p);
//.TextRect(Rect,0,0,p);
Rect.Top:=Rect.Top+Th;
Rect.Bottom:=Rect.Top+Th;
dec(Lc);
end;
end;

procedure TDrawText.GetScriptInfo(Script: string);
var
p:string;
begin
p:=GetScriptPart(Script);
fOrigin.X:=StrToInt(p);
p:=GetScriptPart(Script);
fOrigin.Y:=StrToInt(p);
p:=GetScriptPart(Script);
fEnd.X:=StrToInt(p);
p:=GetScriptPart(Script);
fEnd.Y:=StrToInt(p);
p:=GetScriptPart(Script);
fCaption:=p;
end;

function TDrawText.ScriptInfo: string;
begin
result:=inherited ScriptInfo+','''+fCaption+'''';
end;

{ TVectorImage }

constructor TVectorImage.Create(AOwner: TComponent);
begin
inherited;
fOldPos.x:=-1;
fOldPos.y:=-1;
fShapes:=TObjectList.Create;
DrawingTool:=TDrawLine;
fPenColor:=clBlack;
Cursor:=crCross;
Color:=clWindow;
fGridColor:=clBtnFace;
oldW:=-1;
fGridX:=1;
fGridY:=1;
// InvalidateRect(self.Canvas.Handle, Nil, False);
end;

destructor TVectorImage.Destroy;
begin
fShapes.Free;
fMarkers.Free;
inherited;
end;

function TVectorImage.Editable: Boolean;
begin
result:=ioEditable in fOptions;
end;

procedure TVectorImage.GetNear(Point:TPoint);
var
i:integer;
min,dist:double;
begin
min:=-1;
Current:=nil;
for i:=0 to fShapes.Count-1 do begin
dist:=Abs(TDrawPoint(fShapes[i]).Distance(Point));
if (dist<min)or(min=-1) then begin
min:=dist;
Current:=TDrawPoint(fShapes[i]);
end;
end;
if not Assigned(Current) then exit;
GetShape(fOrig,clGreen,Current.Origin);
if Current.InheritsFrom(TDrawPolyLine) then (Current as TDrawPolyLine).CalcRect;
if Current.InheritsFrom(TDrawLine) then GetShape(fEnd,clBlue,TDrawLine(Current).EndPoint);
if Current.InheritsFrom(TDrawArc) then GetShape(fExt,clFuchsia,TDrawArc(Current).Center);
end;

procedure TVectorImage.GetShape(var sh: TShape; Color: TColor; Point:TPoint);
begin
if not Assigned(sh) then begin
sh:=TShape.Create(self);
sh.Width:=5;
sh.Height:=5;
sh.Shape:=stCircle;
end;
sh.Tag:=0;
sh.Left:=Left+Point.x-2;
sh.Top:=Top+Point.y-2;
sh.OnMouseDown:=ShapeMouseDown;
sh.OnMouseMove:=ShapeMouseMove;
sh.OnMouseUp:=ShapeMouseUp;
sh.Parent:=self.Parent;
sh.Brush.Color:=Color;
sh.Cursor:=crCross;
sh.Visible:=true;
end;

procedure TVectorImage.HideShape;

procedure DoHide(sh:TShape);
begin
sh.Visible:=false;
sh.OnMouseDown:=ShapeMouseDown;
sh.OnMouseMove:=ShapeMouseMove;
sh.OnMouseUp:=ShapeMouseUp;
end;

begin
if Assigned(fOrig) then DoHide(fOrig);
if Assigned(fEnd) then DoHide(fEnd);
if Assigned(fExt) then DoHide(fExt);
end;

procedure TVectorImage.Loaded;
begin
inherited;
Resize;
Redraw;
end;

procedure TVectorImage.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
if not Editable then exit;
ToGrid(X,Y);
if not(ioAdd in fOptions) then begin
if Assigned(fOrig)and(fOrig.Visible)and Assigned(Current)and
(Current is TDrawPolyLine) then begin
if Button=mbRight then begin
HideShape;
Current:=nil;
exit;
end else begin
EdPoint:=(Current as TDrawPolyLine).NearPoint(Point(X,Y));
GetShape(fExt,clFuchsia,(Current as TDrawPolyLine).Points[EdPoint]);
end;
end else begin
HideShape;
GetNear(Point(x,y));
end;
exit;
end;
HideShape;
if Assigned(fTool) then begin
if fTool.InheritsFrom(TDrawPolyLine) then begin
if Button=mbRight then begin
if Assigned(Current) then begin
(Current as TDrawPolyLine).DelLast;
Redraw;
end;
Current:=nil;
exit;
end;
if not Assigned(Current) then AddShape(Point(X,Y));
(Current as TDrawPolyLine).AddPoint(Point(X,Y));
exit;
end;
AddShape(Point(X,Y));
Current.Draw(Canvas);
if Current is TDrawText then begin
GetShape(fOrig,clGreen,Point(X,Y));
(Current as TDrawText).EndPoint:=Point(X+Canvas.TextWidth('WWWW'),Y+Canvas.TextHeight('W')+2);
GetShape(fEnd,clBlue,(Current as TDrawText).EndPoint);
end;
if Current is TDrawArc then begin
GetShape(fOrig,clGreen,Point(X,Y));
GetShape(fEnd,clBlue,Point(X,Y));
GetShape(fExt,clFuchsia,Point(X,Y));
end;
end;
end;

procedure TVectorImage.MouseMove(Shift: TShiftState; X, Y: Integer);
var
r:TRect;
begin
inherited;
if ToGrid(X,Y) then exit;
if Assigned(fOnMouse) then fOnMouse(self,Point(X,Y));
if not(Editable and Assigned(Current)) then exit;
if Current.InheritsFrom(TDrawArc)or(Current.InheritsFrom(TDrawText)) then exit;
if not(ioAdd in fOptions) then exit;
if ioAutoSize in fOptions then begin
if X>Width then Width:=x;
if Y>Height then Height:=y;
end;
r:=Current.GetRect;
if Current.InheritsFrom(TDrawPolyLine) then begin
// Canvas.Pen.Mode:=pmNotXor;
// Current.Draw(Canvas);
(Current as TDrawPolyLine).SetLast(Point(X,Y));
// Current.Draw(Canvas);
end else
if Current is TDrawLine then begin
// Canvas.Pen.Mode:=pmNotXor;
// Current.Draw(Canvas);
(Current as TDrawLine).EndPoint:=Point(X,Y);
// Current.Draw(Canvas);
end else
if Current.ClassType=TDrawPoint then
MouseDown(mbLeft,Shift,X, Y);
Redraw(MaxRect(r,Current.GetRect));
if Assigned(fOnChang) then fOnChang(self,Current);
end;

procedure TVectorImage.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if not(Editable and Assigned(Current)) then exit;
if Current.InheritsFrom(TDrawArc)or
(Current.InheritsFrom(TDrawText))or
(Current.InheritsFrom(TDrawPolyLine)) then exit;
if not(ioAdd in fOptions) then exit;
Canvas.Pen.Mode:=pmCopy;
Current.Draw(Canvas);
Current:=nil;
end;

procedure TVectorImage.ReDraw;
begin
ReDraw(Rect(0,0,Width,Height));
end;

procedure TVectorImage.ReDraw(ARect: TRect);
var
i:integer;
bmp:TBitmap;
begin
bmp:=TBitmap.Create;
try
bmp.Width:=Width;
bmp.Height:=Height;
bmp.Canvas.Pen.Color:=ShadowColor;
bmp.Canvas.Pen.Width:=ShadowSize;
bmp.Canvas.Brush.Style:=bsSolid;
bmp.Canvas.Brush.Color:=Color;
bmp.Canvas.FillRect(ClientRect);
DrawGrid(bmp.Canvas);
for i:=0 to fShapes.Count-1 do
(fShapes[i] as TDrawPoint).Draw(bmp.Canvas);
Canvas.Lock;
Canvas.CopyRect(ARect,bmp.Canvas,ARect);
Canvas.Unlock;
finally
bmp.free;
end;
end;


procedure TVectorImage.Resize;
var
bmp:TBitmap;
i:integer;
dX,dY:double;
begin
inherited;
HideShape;
bmp:=TBitmap.Create;
try
bmp.Width:=Width;
bmp.Height:=Height;
bmp.Canvas.Brush.Color:=Color;
bmp.Canvas.FillRect(ClientRect);
bmp.Canvas.Pen.Color:=ShadowColor;
bmp.Canvas.Pen.Width:=ShadowSize;
DrawGrid(bmp.Canvas);
if (ioAutoScale in Options)and(oldW>0)and(oldH>0) then begin
dX:=Width/oldW;
dY:=Height/oldH;
for i:=0 to fShapes.Count-1 do begin
TDrawPoint(fShapes[i]).Scale(dX,dY);
TDrawPoint(fShapes[i]).Draw(bmp.Canvas);
end;
end else
bmp.Canvas.Draw(0,0,Picture.Graphic);
oldW:=Width;
oldH:=Height;
// BitBlt(Picture.Bitmap.Canvas.Handle,0,0,Width,Height,bmp.Canvas.Handle,0,0,SrcPaint);
Picture.Graphic := bmp;
finally
bmp.Free;
end;
if Assigned(fOnResize) then fOnResize(self);
end;

procedure TVectorImage.ShapeMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
(Sender as TShape).Tag:=1;
end;

procedure TVectorImage.ShapeMouseMove(Sender:TObject; Shift:TShiftState; X,Y:Integer);
var
P:TPoint;
b:boolean;
r:TRect;
begin
b:=ToGrid(X,Y);
P.X:=(Sender as TShape).Left-Left+2;
P.Y:=(Sender as TShape).Top-Top+2;
if Assigned(fOnMouse) then fOnMouse(self,P);
if (Sender as TShape).Tag=0 then exit;
(Sender as TShape).Left:=(Sender as TShape).Left+X;
(Sender as TShape).Top:=(Sender as TShape).Top+Y;
if b then exit;
{ Canvas.Pen.Mode:=pmNotXor;
fShape.Draw(Canvas);}
r:=Current.GetRect;
if Sender=fOrig then begin
Current.Origin:=P;
if Current.InheritsFrom(TDrawLine) then begin
fEnd.Left:=Left+(Current as TDrawLine).EndPoint.X-2;
fEnd.Top:=Top+(Current as TDrawLine).EndPoint.Y-2;
if Assigned(fExt)and(fExt.Visible) then begin
if(Current is TDrawPolyLine) then begin
fExt.Left:=Left+(Current as TDrawPolyLine).Points[EdPoint].X-2;
fExt.Top:=Top+(Current as TDrawPolyLine).Points[EdPoint].Y-2;
end;
if(Current is TDrawArc) then begin
fExt.Left:=Left+(Current as TDrawArc).Center.X-2;
fExt.Top:=Top+(Current as TDrawArc).Center.Y-2;
end;
end;
end;
end;
if (Sender=fEnd)and(Current.InheritsFrom(TDrawLine)) then TDrawLine(Current).EndPoint:=P;
if (Sender=fExt) then begin
if Current.InheritsFrom(TDrawArc) then TDrawArc(Current).Center:=P;
if Current.InheritsFrom(TDrawPolyLine) then begin
(Current as TDrawPolyLine).Points[EdPoint]:=P;
(Current as TDrawPolyLine).CalcRect;
fEnd.Left:=Left+(Current as TDrawPolyLine).EndPoint.X-2;
fEnd.Top:=Top+(Current as TDrawPolyLine).EndPoint.Y-2;
fOrig.Left:=Left+(Current as TDrawPolyLine).Origin.X-2;
fOrig.Top:=Top+(Current as TDrawPolyLine).Origin.Y-2;
end;
end;
if Assigned(fOnChang) then fOnChang(self,Current);
Redraw(MaxRect(r,Current.GetRect));
if ioAutoSize in fOptions then begin
if P.X>Width then Width:=P.x;
if P.Y>Height then Height:=P.y;
end;
end;

procedure TVectorImage.ShapeMouseUp(Sender:TObject; Button:TMouseButton; Shift:TShiftState; X,Y:Integer);
begin
(Sender as TShape).Tag:=0;
end;

procedure TVectorImage.DelCurrent;
var
i:integer;
begin
HideShape;
i:=fShapes.IndexOf(Current);
if i>=0 then fShapes.Delete(i);
Current:=nil;
ReDraw;
end;

procedure TVectorImage.SetTool(const Value: TDrawObject);
begin
fTool := Value;
HideShape;
Current:=nil;
end;

function TVectorImage.Count: integer;
begin
result:=fShapes.Count;
end;

function TVectorImage.GetItem(Index: integer): TDrawPoint;
begin
result:=TDrawPoint(fShapes[Index]);
end;

procedure TVectorImage.SetItem(Index: integer; const Value: TDrawPoint);
var
pn:TDrawPoint;
begin
pn:=GetItem(Index);
fShapes[Index]:=Value;
pn.Free;
end;

procedure TVectorImage.SetShape(const Value: TDrawPoint);
begin
if fCurShape = Value then exit;
fCurShape := Value;
if ioEditable in fOptions then begin
HideShape;
if Assigned(fCurShape) then begin
GetShape(fOrig,clGreen,fCurShape.Origin);
if fCurShape.InheritsFrom(TDrawLine) then
GetShape(fEnd,clBlue,TDrawLine(fCurShape).EndPoint);
if fCurShape.InheritsFrom(TDrawArc) then
GetShape(fExt,clFuchsia,TDrawArc(fCurShape).Center);
end;
end;
if Assigned(fOnSelect) then fOnSelect(self,fCurShape);
end;

procedure TVectorImage.AddShape(APoint:TPoint;Tool:TDrawObject);
begin
if Assigned(Tool) then DrawingTool:=Tool;
fCurShape:=DrawingTool.Create(APoint);
fCurShape.Color:=fPenColor;
fCurShape.BrushColor:=Color;
if fCurShape is TDrawText then fCurShape.PenWidth:=Canvas.Font.Height;
fShapes.Add(fCurShape);
fCurShape.BrushStyle:=bsClear;
if Assigned(fOnAdd) then fOnAdd(self,fCurShape);
end;

procedure TVectorImage.SetGrid(const Index, Value: integer);
begin
if Index=0 then fGridX :=Max(Value,1)
else fGridY:=Max(Value,1);
end;

function TVectorImage.ToGrid(var X, Y: integer):boolean;
begin
X:=((X+1) div fGridX)*fGridX;
Y:=((Y+1) div fGridY)*fGridY;
result:=(fOldPos.X=X)and(fOldPos.Y=Y);
fOldPos:=Point(X,Y);
end;

procedure TVectorImage.DrawGrid(Canvas: TCanvas);
var
x,y:integer;
begin
if (fGridX<=1)or(fGridY<=1) then exit;
X:=0;
while X<Width do begin
inc(X,GridX);
Y:=0;
while Y<Height do begin
inc(Y,GridY);
Canvas.Pixels[X,Y]:=fGridColor;
end;
end;
end;

procedure TVectorImage.DelShape(Index: Integer);
begin
fShapes.Delete(Index);
Current:=nil;
end;

procedure TVectorImage.Clear;
begin
HideShape;
if Assigned(fMarkers) then fMarkers.Clear;
fShapes.Clear;
Redraw;
end;

procedure TVectorImage.Mark(AShape: TDrawPoint; const ACaption: String);
var
i:integer;
begin
if not Assigned(AShape)or(fShapes.IndexOf(AShape)<0) then exit;
if not Assigned(fMarkers) then fMarkers:=TStringList.Create;
i:=fMarkers.IndexOf(ACaption);
if i>=0 then fMarkers.Delete(i);
i:=fMarkers.IndexOfObject(AShape);
if i>=0 then begin
if ACaption='' then fMarkers.Delete(i)
else fMarkers[i]:=ACaption;
end else begin
if ACaption='' then exit;
fMarkers.AddObject(ACaption,AShape);
end;
end;

procedure TVectorImage.Mark(const ACaption: String);
begin
Mark(Current,ACaption);
end;

function TVectorImage.GetMarked(const ACaption: String): TDrawPoint;
var
i:integer;
begin
result:=nil;
if not Assigned(fMarkers) then exit;
i:=fMarkers.IndexOf(ACaption);
if i>=0 then result:=TDrawPoint(fMarkers.Objects[i]);
end;

function TVectorImage.GetMarker(AShape: TDrawPoint): string;
var
i:integer;
begin
result:='';
if not Assigned(fMarkers) then exit;
i:=fMarkers.IndexOfObject(AShape);
if i>=0 then result:=fMarkers[i];
end;

procedure TVectorImage.GetMarkers(AList: TStrings);
begin
if not Assigned(AList) then exit;
AList.Clear;
if not Assigned(fMarkers) then exit;
AList.Assign(fMarkers);
end;

function TVectorImage.GenScript(UseCrLf: boolean): string;
var
i:integer;
s:string;
begin
result:='SIZE('+IntToStr(Width)+','+IntToStr(Height)+');';
if UseCrLf then result:=result+#13#10;
for i:=0 to fShapes.Count-1 do begin
result:=result+TDrawPoint(fShapes[i]).ToScript+';';
if UseCrLf then result:=result+#13#10;
s:=GetMarker(TDrawPoint(fShapes[i]));
if s<>'' then begin
result:=result+'Mark('''+s+''');';
if UseCrLf then result:=result+#13#10;
end;
end;
end;

procedure TVectorImage.DoScript(Script: String);
var
p:integer;
L:string;

procedure GetClass(AName:string);
var
i:integer;
cl:TDrawObject;
s:string;
o:TImageOptions;
begin
if AName='SIZE' then begin
fCurShape:=nil;
o:=fOptions;
fOptions:=fOptions-[ioAutoScale];
Delete(L,1,5);
s:=GetScriptPart(L);
Width:=StrToInt(s);
s:=GetScriptPart(L);
Height:=StrToInt(s);
fOptions:=o;
end else
if AName='MARK' then begin
Delete(L,1,6);
SetLength(L,Length(L)-2);
Mark(L);
end else begin
fCurShape:=nil;
for i:=0 to fGraphTools.Count-1 do
if AnsiUpperCase(TDrawObject(fGraphTools[i]).DrawCmd)=AName then begin
cl:=TDrawObject(fGraphTools[i]);
AddShape(Point(0,0),cl);
exit;
end;
end;
end;

begin
while Script<>'' do begin
p:=Pos(';',Script);
if p=0 then exit;
L:=Copy(Script,1,p-1);
Delete(Script,1,p);
while (L<>'')and(L[1] in [#13,#10,' ',#9]) do Delete(L,1,1);
p:=pos('(',L);
if p=0 then continue;
GetClass(AnsiUpperCase(Copy(L,1,p-1)));
if not Assigned(fCurShape) then continue;
Delete(L,1,p);
fCurShape.FromScript(L);
end;
fCurShape:=nil;
end;

class procedure TVectorImage.RegisterTools(Tools: array of TDrawObject);
var
i:integer;
begin
if not Assigned(fGraphTools) then fGraphTools:=TClassList.Create;
for i:=Low(Tools) to High(Tools) do
fGraphTools.Add(Tools[i]);
end;

procedure TVectorImage.SetOptions(const Value: TImageOptions);
begin
HideShape;
fOptions := Value;
end;

function TVectorImage.GetScript: string;
begin
if ioAutoScript in Options then
result:=GenScript
else
result:=fScript;
end;

procedure TVectorImage.SetScript(const Value: string);
begin
fScript:=Value;
DoScript(fScript);
end;

{ TBrushStyleCombo }

function Tbrushstylecombo.GetSelection:TBrushStyle;
begin
result:=TBrushStyle(ItemIndex);
end;

procedure Tbrushstylecombo.SetSelection(Value: TBrushStyle);
var
i: integer;
dat:PTypeData;
begin
dat:=GetTypeData(TypeInfo(TBrushStyle));
for i:=dat.MinValue to dat.MaxValue do
if TBrushStyle(i) = Value then
begin
ItemIndex :=i;
exit;
end;
end;

procedure Tbrushstylecombo.SetStyle(Value: TComboBoxStyle);
begin
inherited SetStyle(csOwnerDrawFixed);
end;

procedure Tbrushstylecombo.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
r:TRect;
begin
r.top := Rect.top+1;
r.bottom := Rect.bottom-1;
r.left := Rect.left + 3;
// r.right := r.left + (r.Right-r.Left);
r.right := r.left + 40;

with Canvas do
begin
FillRect(Rect);
pen.color:=clBlack;
canvas.brush.color:=clBlack;
canvas.brush.style:=TBrushStyle(Index);
rectangle(r.left,r.top,r.Right,r.Bottom);
rectangle(r.left,r.top,r.left + 40,r.Bottom);
FrameRect®;
end;
r := Rect;
// r.left := r.left + 40;
r.left := r.left + (r.Right-r.Left);

canvas.brush.style:=bsSolid;
canvas.brush.color:=clSilver;
inherited DrawItem(Index, r, State);
end;

procedure Tbrushstylecombo.CreateWnd;
begin
inherited CreateWnd;
SetStyleList;
end;

constructor Tbrushstylecombo.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Style := csOwnerDrawFixed;
end;

procedure Tbrushstylecombo.SetStyleList;
var
c: integer;
dat:PTypeData;
begin
dat:=GetTypeData(TypeInfo(TBrushStyle));
with items do
begin
clear;
for c := dat.MinValue to dat.MaxValue do Add('');
end;
end;

{ Tpenstylecombo }

function Tpenstylecombo.GetSelection: TPenStyle;
begin
result:=TPenStyle(ItemIndex);
end;

procedure Tpenstylecombo.SetSelection(Value: TPenStyle);
var
i: integer;
dat:PTypeData;
begin
dat:=GetTypeData(TypeInfo(TPenStyle));
for i:=dat.MinValue to dat.MaxValue do
if TPenStyle(i) = Value then
begin
ItemIndex :=i;
exit;
end;
end;

procedure Tpenstylecombo.SetStyle(Value: TComboBoxStyle);
begin
inherited SetStyle(csOwnerDrawFixed);
end;

procedure Tpenstylecombo.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
r: TRect;
begin
r.top := Rect.top + 3;
r.bottom := Rect.bottom - 3;
r.left := Rect.left + 3;
r.right := r.left + 45;

with Canvas do
begin
FillRect(Rect);
pen.style:=tpenstyle(index);

pen.color:=clBlack;
moveto(r.Left,r.top + (r.Bottom - r.top) div 2);
lineto(r.right,r.top + (r.Bottom - r.top) div 2);

FrameRect®;
end;
r := Rect;
r.left := r.left + 50;

inherited DrawItem(Index, r, State);
end;

procedure Tpenstylecombo.CreateWnd;
begin
inherited CreateWnd;
SetStyleList;
end;

constructor Tpenstylecombo.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Style := csOwnerDrawFixed;
end;

procedure Tpenstylecombo.SetStyleList;
var
c: integer;
dat:PTypeData;
begin
dat:=GetTypeData(TypeInfo(TPenStyle));
with items do
begin
clear;
for c := dat.MinValue to dat.MaxValue do Add('');
end;
end;


{ TArrowStyleCombo }

constructor TArrowStyleCombo.Create(AOwner: TComponent);
begin
inherited;
Style := csOwnerDrawFixed;
end;

procedure TArrowStyleCombo.CreateWnd;
begin
inherited;
SetStyleList;
end;

procedure TArrowStyleCombo.DrawItem(Index: Integer; Rect: TRect;
State: TOwnerDrawState);
var
r: TRect;
begin
r.top := Rect.top + 3;
r.bottom := Rect.bottom - 3;
r.left := Rect.left + 3;
r.right := Rect.Right-8;

Canvas.FillRect(Rect);
Canvas.pen.color:=clBlack;
DrawArrow(Canvas,Point(r.Left,r.top + (r.Bottom - r.top) div 2),
Point(r.right,r.top + (r.Bottom - r.top) div 2),
TArrowStyle(Index),6);
Canvas.FrameRect®;
end;

function TArrowStyleCombo.GetSelection: TArrowStyle;
begin
result:=TArrowStyle(ItemIndex);
end;

procedure TArrowStyleCombo.SetSelection(Value: TArrowStyle);
var
i: integer;
dat:PTypeData;
begin
dat:=GetTypeData(TypeInfo(TArrowStyle));
for i:=dat.MinValue to dat.MaxValue do
if TArrowStyle(i) = Value then
begin
ItemIndex :=i;
exit;
end;
end;

procedure TArrowStyleCombo.SetStyle(Value: TComboBoxStyle);
begin
inherited SetStyle(csOwnerDrawFixed);
end;

procedure TArrowStyleCombo.SetStyleList;
var
c: integer;
dat:PTypeData;
begin
dat:=GetTypeData(TypeInfo(TArrowStyle));
with items do
begin
clear;
for c := dat.MinValue to dat.MaxValue do Add('');
end;
end;


initialization
TVectorImage.RegisterTools([TDrawPoint,TDrawLine,TDrawArc,TDrawArrow,TDrawEllipse,
TDrawPolyBezier,TDrawPolygon,TDrawPolyLine,TDrawRect,TDrawText]);
finalization
fGraphTools.Free;
end.