unitpaintpanel.pas

delphi开发矢量图的源代码

unit UnitPaintPanel;
{
  Create Date :2003.09.21;
  Create Authoer :WXZH
  E_Mail :[e-mail]

  本源代码代开，希望哪位同仁加以改进后能给本人发一份源代码,谢谢
  功能介绍：
  　　本组件继承于TCustomControl,功能包括：
  　　1、图形的绘制，包括线条，多边型，多点曲线，圆形，椭圆形
  　　2、注释的绘制，包括带指向点的绘制和不带指向点的绘制
  　　3、图形的存取：从自已定义的文件格式中读入文件，
  　　　　写入的文件格式有自己定义的文件格式或位图格式。也可以从流数据中
  　　　　进行存取。
      4、F5可以进行刷新图面，DELETE键可以删除当前选择的图形，F6可以删除填充的地方。
      5、在进行编译时要进行堆栈的改动，这是由于查找多边形的算法不好，希望哪位能改进
}
interface
uses
   Classes,Windows,Messages,ExtCtrls,Graphics,SysUtils,
   Controls,Dialogs,Menus,StdCtrls,Math,UnitGlobal,ZLib;
type
   TGraphClass =(gcLine,gcCurve,gcArc,gcRect,gcNotice);


   TGraphObject = class(TObject)
   private
     FSelected: Boolean;
     FGraphClass: TGraphClass;
     FPointList: TPointList;
     FColor: TColor;
     FFill: Boolean;
     procedure SetPointList(const Value: TPointList);
     procedure SetGraphClass(const Value: TGraphClass);
     procedure SetSelected(const Value: Boolean);
     procedure SetColor(const Value: TColor);
     procedure SetFill(const Value: Boolean);
   public
     property  Fill :Boolean read FFill write SetFill;
     property  PointList :TPointList read FPointList write SetPointList;
     property  Color :TColor read FColor write SetColor;
     property  Selected :Boolean read FSelected write SetSelected;
     property  GraphClass :TGraphClass read FGraphClass write SetGraphClass;
   end;

   TPositionDirection = (pdLeft,pdRight,pdTop,pdBottom);  //点位于矩形框的方位，左边，右边，上边，下边
   TNoticeClass   =(ncRect,ncNotice);

   TNoticeObject     = class(TObject)
   private
     FFillColor: TColor;
     FClientRect: TRect;
     FLines: TStringList;
     FPoint: TPoint;
     FSelected: Boolean;
     FNoticeClass: TNoticeClass;

     procedure SetClientRect(const Value: TRect);
     procedure SetFillColor(const Value: TColor);
     procedure SetLines(const Value: TStringList);
     function  GetPointList :TPointList;
     procedure SetPoint(const Value: TPoint);
     function PoInRectPosition(Po: TPoint;
          ARect: TRect): TPositionDirection;
     procedure SetSelected(const Value: Boolean);
     procedure SetNoticeClass(const Value: TNoticeClass);
   public
     constructor Create;
     destructor  Destroy;override;

     property NoticeClass :TNoticeClass read FNoticeClass write SetNoticeClass;
     property ClientRect :TRect read FClientRect write SetClientRect;
     property Lines :TStringList read FLines write SetLines;
     property PointList :TPointList read GetPointList;
     property FillColor :TColor read FFillColor write SetFillColor;
     property ToPoint :TPoint read FPoint write SetPoint;
     property Selected :Boolean read FSelected write SetSelected;
   end;

   TDrawClass  =(dcGraph,dcNotice) ;//所画的类别，图形，注释.....
   TPaintMouseDragEvent = procedure(Sender :TObject;var ARect :TRect;
                 var Po :TPoint;Lines :TStringList) of Object;
   TNoticeDragPoint =(npBorder,npHeader);

   TFillObject = class
     Rgn :HRgn;
     FillColor :TColor;
   end;

   TCustomPaintPanel = class(TCustomControl)
   private
     FGraphList :TList;
     FNoticeList :TList;
     FFillList :TList;
     FGraphClass: TGraphClass;
     FPointList :TPointList;
     FAbsPointList :TPointList;
     FPointCount :integer;
     FAction :TOperateAction;
     FColor: TColor;
     FSelObject: TObject;
     FMouseDownSPo :TPoint;
     FDrawClass: TDrawClass;
     FOnMouseDrag: TPaintMouseDragEvent;
     FIsFill: Boolean;
     FFillColor: TColor;
     FNoticeDragPoint: TNoticeDragPoint;
     FNoticeClass: TNoticeClass;

     procedure WMLButtonDown(var Msg :TWMLButtonDown);message WM_LButtonDown;
     procedure WMLButtonUp(var Msg :TWMLButtonUp);message WM_LButtonUp;
     procedure WMMouseMove(var Msg :TWMMouseMove);message WM_MouseMove;
     procedure WMKeyDown(var Msg :TWMKeyDown);message WM_KEYDOWN;
     procedure SetGraphClass(const Value: TGraphClass);

     procedure PaintSelected(AObject: TObject);
     procedure SetColor(const Value: TColor);
     procedure RunTimeDraw(AGraphClass :TGraphClass;APointList :TPointList);
     procedure ClearObjectSelected;
     function  PTInObject(Po: TPoint; AGraphObject: TGraphObject): Boolean;overload;
     function  PTInObject(Po :TPoint; ANoticeObject: TNoticeObject): Boolean;overload;
     procedure SetSelObject(const Value: TObject);
     procedure MoveObject(AObject: TObject; DeltaX,DeltaY: integer);
     procedure ShowMoveObject(AObject: TObject; DeltaX,DeltaY: integer);
     procedure ClearNoticeObject;
     procedure PaintGraph;
     procedure PaintNotice;
     procedure DrawNoticeText(ANoticeObject: TNoticeObject);
     procedure AddGraphObject;
     procedure SetDrawClass(const Value: TDrawClass);
     procedure SetOnMouseDrag(const Value: TPaintMouseDragEvent);
     procedure SetFillColor(const Value: TColor);
     procedure SetIsFill(const Value: Boolean);
     procedure PaintFill;
     procedure SetNoticeDragPoint(const Value: TNoticeDragPoint);
     function  PointInEdge(Po: TPoint; AGraphObject: TGraphObject): Boolean;
     procedure PointListChangToScreen(ClientPointList,
                ScreenPointList: TPointList);
     procedure ClearGraphObject;
     procedure DeleteGraph(AGraphObject: TGraphObject);
     procedure DeleteNotice(ANoticeObject: TNoticeObject);
     procedure ClearFillObject;
     procedure SetNoticeClass(const Value: TNoticeClass);
   protected
     procedure Paint;override;

     procedure DeleteObject(AObject :TObject);
     property  OnMouseDrag :TPaintMouseDragEvent read FOnMouseDrag write SetOnMouseDrag;
     property  NoticeDragPoint :TNoticeDragPoint read FNoticeDragPoint write SetNoticeDragPoint;
   public
     constructor Create(AOwner :TComponent);override;
     destructor  Destroy;override;

     procedure Delete;
     procedure Clear;

     procedure AddNotice(ARect :TRect;Po :TPoint;Lines :TStringList);
     procedure SaveToFile(const FileName :string);    //保存当前数据到文件
     procedure SaveToStream(Stream :TStream);         //保存当前数据到流数据
     procedure SaveToBitmap(const FileName :string);  //保存当前数据为位图文件
     procedure LoadFromStream(Stream :TStream);       //从流数据中载入数据
     procedure LoadFromFile(const FileName :string);  //从文件中载入数据

     property DrawClass :TDrawClass read FDrawClass write SetDrawClass;
     property NoticeClass :TNoticeClass read FNoticeClass write SetNoticeClass;
     property SelObject :TObject read FSelObject write SetSelObject;
     property Color :TColor read FColor write SetColor;
     property FillColor :TColor read FFillColor write SetFillColor;
     property IsFill :Boolean read FIsFill write SetIsFill;
     property GraphClass :TGraphClass read FGraphClass write SetGraphClass;
   end;

   TPaintPanel = class(TCustomPaintPanel)
   published
     property Align;
     property FillColor;
     property DrawClass;
     property Color;
     property GraphClass;
     property Visible;
     property OnMouseDrag;
   end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Lanya Soft',[TPaintPanel]);
end;

const
  FileIdentify = 'WXZHP1.1';    //保存文件时采用的字符串标志名称

{ TGrapthObject }

procedure TGraphObject.SetPointList(const Value: TPointList);
begin
  FPointList := Value;
end;

procedure TGraphObject.SetGraphClass(const Value: TGraphClass);
begin
  FGraphClass := Value;
end;

procedure TGraphObject.SetSelected(const Value: Boolean);
begin
  FSelected := Value;
end;

procedure TGraphObject.SetColor(const Value: TColor);
begin
  FColor := Value;
end;

procedure TGraphObject.SetFill(const Value: Boolean);
begin
  FFill := Value;
end;


{ TPaintPanel }

constructor TCustomPaintPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FGraphList := TList.Create;
  FNoticeList := TList.Create;
  FFillList := TList.Create;
  GraphClass := gcLine;
  DrawClass := dcGraph;
  SetLength(FPointList,0);
end;

destructor TCustomPaintPanel.Destroy;
begin
  ClearGraphObject;
  ClearNoticeObject;
  FGraphList.Free;
  FNoticeList.Free;
  FFillList.Free;
  inherited;
end;

procedure TCustomPaintPanel.ClearNoticeObject;
var
  i :integer;
  NoticeObject :TNoticeObject;
begin
  for i := 0 to FNoticeList.Count - 1 do
  begin
    NoticeObject := FNoticeList[i];
    NoticeObject.Free;
  end;
  FNoticeList.Clear;
  Invalidate;
end;

procedure TCustomPaintPanel.ClearGraphObject;
var
  i :integer;
  GraphObject :TGraphObject;
begin
  for i := 0 to FGraphList.Count - 1 do
  begin
    GraphObject := FGraphList[i];
    GraphObject.Free;
  end;
  FGraphList.Clear;
  Invalidate;
end;


procedure TCustomPaintPanel.AddNotice(ARect: TRect; Po: TPoint;
  Lines: TStringList);
var
  NoticeObject : TNoticeObject;
begin
  NoticeObject := TNoticeObject.Create;
  NoticeObject.ClientRect := ARect;
  NoticeObject.ToPoint := Po;
  NoticeObject.Lines := Lines;
  NoticeObject.Selected := True;
  SelObject := NoticeObject;
  FNoticeList.Add(NoticeObject);
end;


procedure TCustomPaintPanel.LoadFromFile(const FileName: string);
var
  Stream :TMemoryStream;
  DestStream :TMemoryStream;
  DeCompressionStream :TDeCompressionStream;
  Count :Int64;
  Buff :Pchar;
  Identify :array of Char;
begin
  Stream := TMemoryStream.Create;
  try
    Stream.LoadFromFile(FileName);

    //辨别文件的格式,是否为能识别的格式
    Stream.Position := 0;
    SetLength(Identify,Length(FileIdentify));
    Stream.ReadBuffer(Identify[0],Sizeof(Char) * Length(FileIdentify));
    if Identify[0] = FileIdentify then              //辨别文件数据格式
       raise Exception.Create('无法识别的文件格式');

    Stream.ReadBuffer(Count,Sizeof(Int64));

    //解压缩数据
    DestStream := TMemoryStream.Create;
    try
      DeCompressionStream := TDeCompressionStream.Create(Stream);
      GetMem(Buff,Count + 1);
      try
        DeCompressionStream.ReadBuffer(Buff^,Count);
        DestStream.WriteBuffer(Buff^,Count);
      finally
        FreeMem(Buff);
      end;
      LoadFromStream(DestStream); //根据数据流绘制图形
    finally
      DestStream.Free;
    end;
  finally
    Stream.Free;
  end;
end;

procedure TCustomPaintPanel.LoadFromStream(Stream: TStream);
var
  Count :integer;
  AColor :TColor;
  APointList :TPointList;
  AGraphObject :TGraphObject;
  AGraphClass :TGraphClass;
  Identify :array of Char;
begin
  Stream.Position := 0;
  while Stream.Position < Stream.Size do
  begin
    Stream.ReadBuffer(Count,Sizeof(Count));
    Stream.ReadBuffer(AColor,Sizeof(TColor));
    Stream.ReadBuffer(AGraphClass,Sizeof(TGraphClass));
    SetLength(APointList,Count);
    Stream.ReadBuffer(APointList[0],Sizeof(TPoint) * Count);
    AGraphObject := TGraphObject.Create;
    AGraphObject.PointList := Copy(APointList,0,High(APointList) + 1);
    AGraphObject.Color := AColor;
    AGraphObject.GraphClass := AGraphClass;
    FGraphList.Add(AGraphObject);
  end;
  Invalidate;
end;

procedure TCustomPaintPanel.SaveToFile(const FileName: string);
var
  AStream :TMemoryStream;
  CompressionStream :TCompressionStream;
  DestStream :TMemoryStream;
  AIdentify :PChar;
  Count :Int64;
begin
  AStream := TMemoryStream.Create;
  try
    SaveToStream(AStream);
    Count := AStream.Size;
    DestStream := TMemoryStream.Create;
    try     //Start DestStream
      CompressionStream := TCompressionStream.Create(clMax,DestStream);
      try
        AStream.SaveToStream(CompressionStream);       //压缩数据
      finally
        CompressionStream.Free;
      end;
      AStream.Clear;

      //写入标志字符串
      AStream.WriteBuffer(FileIdentify,Sizeof(Char) * Length(FileIdentify));