unitglobal.pas

delphi开发矢量图的源代码

unit UnitGlobal;

interface
uses
   Classes,Windows,Messages,ExtCtrls,Graphics,SysUtils,
   Controls,Dialogs,Menus,StdCtrls,Math,ZLib;
type
  TOperateAction  =(paNone,paSelect,paMove,paDrag,paResize,paDrawLine,paDrawGraph,
                     paDrawNotice,paModiGraph);           //操作的方法
  TPointList  = array of TPoint;
procedure XOR_Bitmap(var ABitmap : TBitmap);
function  CreateControl(ControlClass :TControlClass;Name :string;
             AOwner :TComponent = nil) :TControl;
procedure DrawPolyLine(DC :HDC;PointList :array of TPoint);
procedure DrawRect(DC :HDC;PointList :TPointList;IsFill :Boolean = False;
                    FillColor :TColor= clBlack);
procedure FillPoly(DC :HDC;PointList :TPointList;FillColor :TColor);
procedure DrawArc(DC :HDC;PointList :array of TPoint);
function  GetFillRgn(DC :HDC;Po :TPoint) :HRGN;
procedure FillArc(DC :HDC;PointList :TPointList;FillColor :TColor);
function PTInLine(PointArray:TPointList;Dot:TPoint;var Contrast:Double;var PointIndex:Integer):Boolean;
function PTInRect(Po :TPoint;ARect :TRect) :Boolean;

//以下三个函数为一位网友所提供，也是在网上找的，谢谢这位网友哦:)
function DotDis(x1,x2,y1,y2:Integer):Double;overload;
function DotDis(Dot1,Dot2:TPoint):Double; overload;
function Dot2Line(pFrom, pTo, pDot: Tpoint):Double;


implementation


////////////////////////////////////////////////////////////////////
//计算两点间的距离。
//参数：x1,x2,y1,y2:Integer，需要计算的两个点的X和Y坐标。
//返回值是两个点的距离。
////////////////////////////////////////////////////////////////////

function DotDis(x1,x2,y1,y2:Integer):Double;overload;
var X,y:Double;
//需要先将整形数据转换成双精度浮点型才不容易溢出。
begin
  x:=(x1-x2)/5000000;
  y:=(y1-y2)/5000000;
  Result:=(SQRT(SQR(x)+SQR(y)))*5000000;
end;

////////////////////////////////////////////////////////////////////
//计算两点间的距离。
//参数：Dot1,Dot2:TPoint，需要计算的两个点。
//返回值是两个点的距离。
////////////////////////////////////////////////////////////////////
function DotDis(Dot1,Dot2:TPoint):Double; overload;
begin
  Result:=DotDis(Dot1.x,Dot2.x,Dot1.y,Dot2.y);
end;

////////////////////////////////////////////////////////////////////
//点到线段的距离。如果点与直线的垂足不在线段上，则取点到线段最近点的距离。
//参数：pFrom, pTo:TPoint，线段的端点。
//      pDot，第三点。
//返回值是第三点与线段的距离。
////////////////////////////////////////////////////////////////////
function Dot2Line(pFrom, pTo, pDot: Tpoint):Double;
var
  F2T_Dis,D2T_Dis,D2F_Dis,s:Double;
begin
  F2T_Dis:=DotDis(pFrom,pTo);
  D2T_Dis:=DotDis(pDot,pTo);
  D2F_Dis:=DotDis(pDot,pFrom);
  if (D2F_Dis>SQRT(SQR(D2T_Dis)+SQR(F2T_Dis))) then
    Result:=D2T_Dis
  else if (D2T_Dis>SQRT(SQR(D2F_Dis)+SQR(F2T_Dis))) then
    Result:=D2F_Dis
  else if (Trunc(D2F_Dis)=Trunc(SQRT(SQR(D2T_Dis)+SQR(F2T_Dis)))) then
    Result:=D2T_Dis
  else if (Trunc(D2T_Dis)=Trunc(SQRT(SQR(D2F_Dis)+SQR(F2T_Dis)))) then
    Result:=D2F_Dis
  else if F2T_Dis<0.0001 then
  begin
    if D2T_Dis>D2F_Dis then
      Result:=D2F_Dis
    else
      Result:=D2T_Dis;
  end else
  begin
    s:=(D2F_Dis+D2T_Dis+F2T_Dis)/2;
    Result:=SQRT(ABS(s*(s-D2F_Dis)*(s-D2T_Dis)*(s-F2T_Dis)))*2/F2T_Dis;
  end;
end;

////////////////////////////////////////////////////////////////////
//判断点是否在一个条线上或一定距离内。
//参数：PointArray:Array of TPoint组成区域的点列表。
//      Dot，第三点。
//      Var Contrast:Double指定的距离，如果点与线的距离小于这个值，则用这个值来返回最近的距离。
//      Var PointIndex:Integer返回与该点最近的线上的点的序号。
//返回第三点是否在线上或距线一定距离。
////////////////////////////////////////////////////////////////////
function PTInLine(PointArray:TPointList;Dot:TPoint;var Contrast:Double;var PointIndex:Integer):Boolean;
const
   Minimal = 5;
var
  MaxX,MaxY,MinX,MinY,i,Count:Integer;
  dDot2LineValue:Double;
  Dis1,Dis2:Double;
begin
  Result:=False;
  Count:=High(PointArray)+1;
  PointIndex:=-1;
  if Count<=1 then
    Exit;
  MaxX:=0;
  MaxY:=0;
  MinX:=MaxInt;
  MinY:=MaxInt;
  For i:=0 to Count-1 do
  begin
    if MaxX<PointArray[i].x then
      MaxX:=PointArray[i].x;
    if MaxY<PointArray[i].y then
      MaxY:=PointArray[i].y;
    if MinX>PointArray[i].x then
      MinX:=PointArray[i].x;
    if MinY>PointArray[i].y then
      MinY:=PointArray[i].y;
  end;
  if (Dot.x>MaxX+Contrast)
    or (Dot.x<MinX-Contrast)
    or (Dot.Y>MaxY+Contrast)
    or (Dot.Y<MinY-Contrast)
  then
    Exit;
  For i:=0 to Count-2 do
  begin
    dDot2LineValue:=Dot2Line(PointArray[i],PointArray[i+1],Dot);
    if dDot2LineValue<=Contrast then
    begin
      Result:=True;
      Contrast:=dDot2LineValue;
      Dis1:=DotDis(PointArray[i],Dot);
      Dis2:=DotDis(PointArray[i+1],Dot);
      if (Dis1<Dis2) and (Dis1<=Minimal) then
        PointIndex:=i
      else if (Dis2<Dis1) and (Dis2<=Minimal) then
        PointIndex:=i+1;
    end;
  end;
end;


//检测点是否在矩形框内

function PTInRect(Po :TPoint;ARect :TRect) :Boolean;
begin
  Result := False;
  if (Po.X > ARect.Left ) and (Po.X < ARect.Right) and (Po.Y > ARect.Top) and
     (Po.Y < ARect.Bottom) then
      Result := True;
end;

// 填充矩形
procedure FillRect(DC :HDC;PointList :TPointList;FillColor :TColor);
var
  P :TPointList;
begin
  SetLength(P,4);
  P[0] := PointList[0];
  P[2] := PointList[High(PointList)];
  P[1] := Point(P[2].X ,P[0].Y);
  P[3] := Point(P[0].X ,P[2].Y);
  FillPoly(DC,P,FillColor);
end;
//画圆形

procedure DrawArc(DC :HDC;PointList :array of TPoint);
begin
  Arc(DC,PointList[0].X,PointList[0].Y,PointList[High(PointList) ].X,
     PointList[High(PointList)].Y,0,0,0,0);
end;

//填充圆形
procedure FillArc(DC :HDC;PointList :TPointList;FillColor :TColor);
var
  Rgn :HRGN;
begin
  Rgn := CreateEllipticRgn(PointList[0].X ,PointList[0].Y ,PointList[High(PointList)].X,
                           PointList[High(PointList)].Y);
  FillRgn(DC,Rgn,CreateSolidBrush(FillColor));
  DeleteObject(Rgn);
end;

//填充点四周的封闭区域

procedure FillPoly(DC :HDC;PointList :TPointList;FillColor :TColor);
var
  Rgn :HRGN;
begin
  Rgn := CreatePolygonRgn(PointList[0],High(PointList) + 1,ALternate);
  FillRgn(DC,Rgn,CreateSolidBrush(FillColor));
  DeleteObject(Rgn);
end;

//
function GetFillRgn(DC :HDC;Po :TPoint) :HRGN;
var
  Rgn :HRGN;
  BKColor :TColor;
  TempAry :array[0..1000,0..1000] of Boolean;
  procedure FillRgn(Po :TPoint);
  var
    TempRgn :HRGN;
  begin
    TempRgn := CreateRectRgn(Po.X,Po.Y,Po.X + 1,Po.Y + 1);
    CombineRgn(Rgn,Rgn,TempRgn,RGN_OR);
    DeleteObject(TempRgn);
    if (GetPixel(DC,Po.X ,Po.Y) <> BKColor) or TempAry[Po.X,Po.Y ] then Exit;
    TempAry[Po.X,Po.Y ] := True;

    FillRgn(Point(Po.X + 1,Po.Y));
    FillRgn(Point(Po.X - 1,Po.Y));
    FillRgn(Point(Po.X ,Po.Y + 1));
    FillRgn(Point(Po.X ,Po.Y - 1));
  end;
begin
  BKColor := GetPixel(DC,Po.X ,Po.Y);
  Rgn := CreateRectRgn(Po.X,Po.Y,Po.X + 1,Po.Y + 1);
  FillRgn(PO);
  Result := Rgn;
end;

//根据点画线,但不封闭

procedure DrawPolyLine(DC :HDC;PointList :array of TPoint);
var
  i :integer;
  Po :TPoint;
begin
  MoveToEx(DC,PointList[0].X,PointList[0].Y,@Po);
  for i := 1 to High(PointList)  do
  begin
    LineTo(DC,PointList[i].X,PointList[i].Y);
  end;
end;

//画矩形框，
procedure DrawRect(DC :HDC;PointList :TPointList;IsFill :Boolean = False;
           FillColor :TColor= clBlack);
var
  i :integer;
  Po :TPoint;
begin
  i := High(PointList);
  MoveToEx(DC,PointList[0].X,PointList[0].Y,@Po);
  LineTo(DC,PointList[0].X,PointList[i].Y);
  LineTo(DC,PointList[i].X,PointList[i].Y);
  LineTo(DC,PointList[i].X,PointList[0].Y);
  LineTo(DC,PointList[0].X,PointList[0].Y);
  if IsFill then
  begin
    FillRect(DC,PointList,FillColor);
  end;
end;
//根据类名创建类的实例

function CreateControl(ControlClass :TControlClass;Name :string;
            AOwner :TComponent = nil) :TControl;
begin
  Result := ControlClass.Create(AOwner);
  Result.Name  := Name;
end;

  //对图片取反，暂时未用
procedure XOR_Bitmap(var ABitmap : TBitmap);
var
  i,j :integer;
begin
  for i := 0 to ABitmap.Width do
    for j := 0 to ABitmap.Height do
      ABitmap.Canvas.Pixels[i,j] := ABitmap.Canvas.Pixels[i,j] XOR $FFFF;
end;


end.