arccpic.pas

很不错的delphi 画失量图的delphi源代码

unit ArccPic;

interface

uses Windows,Graphics,Math,Classes,Controls,
  PicConst,PicBase,PicFuns;

const
  FOCUS_NUM=10;

type
  TArccType=(Arcc_Arc,Arcc_Sector,Arcc_Chord); //圆弧，扇形， 玄

type
  TArcDrawState=(ARC_DRAW,ARC_SET); //准备画，开始画，设置

type
  TArccPic=Class(TPicBase)
    private
      StartPos:TPoint;
      EndPos:TPoint;
      FocusPoint:Array[1..FOCUS_NUM] of TPoint;
      ArcStartPos:TPoint;
      ArcEndPos:TPoint;
      fArccType:TArccType;
      //ArccKeyState:TShiftState;
      fDrawState: TArcDrawState;
      procedure GetFocusPoints;
      procedure SetPicArccType(aArccType:TArccType);
    protected
    public
      constructor Create;
      destructor  Destroy; override;
      procedure DrawPic(ACanvas:TCanvas);  override;        //在acanvas上画图
      procedure MovePic(ACanvas:TCanvas; APoint:TPoint); override; //在acanvas上移动
      function  MouseInPicRegion(ACanvas:TCanvas;APoint:TPoint): MOUSE_POS; override; //鼠标位置
      function  CreatePicRgn(ACanvas:TCanvas): HRGN; override; //产生图元区域的句柄
      procedure DrawFocusRect(ACanvas:TCanvas); override; //在Acanvas上画焦点
      //鼠标响应
      procedure ParentMouseDown(ACanvas:TCanvas;CursorNum:Integer;
        Button: TMouseButton;Shift: TShiftState; APoint:TPoint); override;
      procedure ParentMouseMove(ACanvas:TCanvas;CursorNum:Integer;
        Shift: TShiftState;APoint:TPoint);  override;
      procedure ParentMouseUp(ACanvas:TCanvas;CursorNum:Integer;
        Button: TMouseButton;  Shift: TShiftState; APoint:TPoint); override;
      //键盘响应
      procedure ParentKeyDown(ACanvas:TCanvas;CursorNum:Integer; var Key: Word;
        mouse: TPoint; Shift:TShiftState); override;
      procedure ParentKeyUp(ACanvas:TCanvas;CursorNum:Integer; var Key: Word;
        mouse: TPoint; Shift: TShiftState); override;
      //图象改变
      procedure PicChangeing(ACanvas:TCanvas; mouseInPos: MOUSE_POS; chooseRect:TRect;
        mouseDownOldX, mouseDownOldY, mouseOldX, mouseOldY, mouseX, mouseY:Integer); override;
      procedure PicChangedUpdate(ACanvas:TCanvas; mouseInPos: MOUSE_POS;chooseRect: TRect; //选择图元形成的矩形
        mouseDownOldX, mouseDownOldY: Integer; mouseX, mouseY: Integer); override; //鼠标当前的坐标
      //位置代码可参见 PicConst.pas
      procedure AssignPic(SourcePic: TPicBase); override;
      //保存和读取数据
      procedure GetClassDataFromChar(var Len:Integer; var Buf:Array of Char); override;
      procedure SaveClassDataToChar(var Len:Integer; var Buf:Array of Char);  override;
      //非重载函数
      //绘图函数
      procedure DrawArccPic(ACanvas: TCanvas; startPoint:TPoint; endPoint:TPoint;ArcsPoint:TPoint;ArcePoint:TPoint);
      //property 的实现方法
    published
      property PicStartPoint:TPoint read StartPos write StartPos;
      property PicEndPoint: TPoint  read EndPos write EndPos;
      property PicArcStart: TPoint read ArcStartPos write ArcStartPos;
      property PicArcStop:  TPoint read ArcEndPos Write ArcEndPos;
      property PicArccType: TArccType read fArccType write SetPicArccType;
      property PicPen;
      property PicBrush;
      Property PicFont;
      property PicRect;
      property Choosed;
      property PicId;
      property FocusPen;
      property FocusBrush;
      property DrawEndEvent;
      property PicIndex;
  end;

implementation

constructor TArccPic.Create;
begin
  inherited Create;
  FArccType:=ARCC_ARC; //圆弧
  fDrawState:=ARC_DRAW; //正在画
end;

destructor  TArccPic.Destroy;
begin
  inherited Destroy;
end; 


procedure TArccPic.GetFocusPoints;
begin
  focusPoint[1] := startPos; //左上
  focusPoint[2] := Point((StartPos.X+ endPos.X)div 2, StartPos.Y); //上中
  focusPoint[3] := Point(EndPos.X,StartPos.Y); //右上
  focusPoint[4] := Point(StartPos.X,(StartPos.Y+ endPos.Y)div 2); //左中
  focusPoint[5] := Point(EndPos.X,(StartPos.Y+ endPos.Y)div 2); //右中
  focusPoint[6] := Point(StartPos.X,EndPos.Y); //左下
  focusPoint[7] := Point((StartPos.X + endPos.X)div 2, EndPos.Y); //下中
  focusPoint[8] := endPos; //终点
  focusPoint[9] := ArcStartPos;
  focusPoint[10]:= ArcEndPos;
end;

procedure TArccPic.SetPicArccType(aArccType:TArccType);
begin
  if FArccType<>aArccType then fArccType:=aArccType;
end;

procedure TArccPic.DrawPic(ACanvas:TCanvas);         //在acanvas上画图
var
  pp: array[1..4] of TPoint;
  drawStartPoint: Tpoint;
  drawEndPoint: Tpoint;
  DrawarcsPoint: TPoint;
  DrawarcePoint: TPoint;
begin
  drawStartPoint := startPos;
  drawEndPoint := endPos;
  drawarcsPoint:=ArcStartPos;
  drawarcePoint:=ArcEndPos;
  pp[1] := drawStartPoint;
  pp[2] := drawEndPoint;
  pp[3] := drawarcsPoint;
  pp[4] := drawarcePoint;
  LpToDp(ACanvas.Handle, pp[1], 4); //取得设备坐标
  drawStartPoint := pp[1];
  drawEndPoint:=pp[2];
  drawarcsPoint:=pp[3];
  drawarcePoint:=pp[4];
  ACanvas.Pen:=PicPen;
  ACanvas.Brush:=PicBrush;
  ACanvas.Font:=PicFont;
  DrawArccPic(ACanvas, drawStartPoint, drawEndPoint,drawarcsPoint,DrawarcePoint);
  if Choosed then DrawFocusRect(ACanvas);
end;

procedure TArccPic.MovePic(ACanvas:TCanvas; APoint:TPoint);  //在acanvas上移动
var
  tmprect:TRect;
begin
  Inc(startPos.x, APoint.X);
  Inc(startPos.y, APoint.y);
  Inc(endpos.x, APoint.x);
  Inc(endpos.y, APoint.y);
   //调整图元矩形区域
  tmprect.Left := Min(startPos.x, endPos.x);
  tmprect.Top := Min(startPos.y, endpos.Y);
  tmprect.Right := Max(startPos.x, endpos.x);
  tmprect.Bottom := Max(startPos.y, endPos.y);
  if tmprect.Right = tmprect.Left then Inc(tmprect.Right, 2);
  if tmprect.Top = tmprect.Bottom then Inc(tmprect.Bottom, 2);
  PicRect:=tmpRect;
end;

function  TArccPic.MouseInPicRegion(ACanvas:TCanvas;APoint:TPoint): MOUSE_POS;  //鼠标位置
var
  mPoint: Tpoint;
  mRect: TRect;
  FocusNumber: Integer; //焦点数量
  i: Integer;
  fPicHRGN: HRGN;
begin
  result := POS_OUT;
  focusNumber := FOCUS_NUM; // =2 焦点数量
  fPicHRGN := CreatePicRgn(ACanvas);
    //CreateLineRgn(startPoint.x,startPoint.y,endPoint.x,endPoint.y);//,Top,Right,Bottom);
  if not Choosed then begin //图元未选中，只要判断是否在图元区域即可
    if PtInRegion(fPicHrgn, APoint.x, APoint.y) = True then result := POS_CENTER
  end else begin //图元被选中，不仅要判断是否在图元区域，还需要判断在图元的具体位置
    if PtInRegion(fPicHrgn, APoint.x, APoint.y) = True then  result := POS_CENTER;
    GetFocusPoints;  //取焦点坐标
    LpToDp(ACanvas.Handle, focusPoint[1], focusNumber);
    mPoint:=APoint;
    for i := FocusNumber Downto 1 do  begin
      with mRect do  begin
        Left := focusPoint[i].x - FOCUS_SIZE;
        Top := focusPoint[i].y - FOCUS_SIZE;
        Right := focusPoint[i].x + FOCUS_SIZE;
        Bottom := focusPoint[i].y + FOCUS_SIZE;
      end;
      if PtInRect(mRect, mPoint) = True then  begin
        if i>8 then begin
          Result := MOUSE_POS(Ord(POS_ARCSTART)- 1 + (i-8));
        end else begin
          Result := MOUSE_POS(Ord(POS_LEFTTOP)- 1 + i);
        end;         // =14 圆弧起点
        Break;
      end
    end;
  end;
  DeleteObject(fPicHrgn);
end;

function  TArccPic.CreatePicRgn(ACanvas:TCanvas): HRGN; //产生图元区域的句柄
var
  hrgnFlag: Integer;
  tmpHrgn: HRGN;
  centerX, centerY: Integer; //圆心坐标
  pp: array[1..4] of TPoint;
begin
  pp[1] := StartPos;
  pp[2] := Endpos;
  pp[3] := ArcStartPos;
  pp[4] := ArcendPos;
  LpToDp(ACanvas.Handle, pp[1], 4);
  hrgnFlag:=0; Result:=0;
  case fArccType of
    Arcc_Arc: //Arc
      begin
        hrgnFlag := 0; //圆弧
      end;
    Arcc_Sector: //Chord
      begin
        if PicBrush.style = bsClear then
          hrgnflag := 1 //chird and clear
        else
          hrgnflag := 2; //chord and solid
      end;
    Arcc_Chord: //Pie
      begin
        if PicBrush.style = bsClear then
          hrgnflag := 3 //Pie and clear
        else
          hrgnflag := 4; //Pie and solid
      end;
  end;
  case hrgnFlag of
    0: //Arc
      begin
        Result := CreateArcRgn(pp[1],pp[2],pp[3],pp[4]);
      end;
    1: //chord and clear
      begin
        Result := CreateArcRgn(pp[1],pp[2],pp[3],pp[4]);
        tmpHrgn := CreateLineRgn(arcStartPos.x, arcStartPos.y,arcEndPos.x, arcEndPos.y);
        CombineRGN(Result, Result, tmpHrgn, RGN_OR);
        DeleteObject(tmpHrgn);
      end;
    2: //chord and solid
      begin
        Result := CreatePieRgn(pp[1],pp[2],pp[3],pp[4],Ord(fArccType));
      end;
    3: //Pie and clear
      begin
        centerX := (StartPos.x + endPos.x) div 2; //圆心坐标
        centerY := (Startpos.y + endPos.y) div 2;
        Result := CreateArcRgn(pp[1],pp[2],pp[3],pp[4]);
        //起点至圆心
        tmpHrgn := CreateLineRgn(arcStartPos.x, arcStartPos.y, centerX, centerY);
        CombineRGN(Result, Result, tmpHrgn, RGN_OR);
        //终点至圆心
        tmpHrgn := CreateLineRgn(arcEndPos.x, arcEndPos.y, centerX, centerY);
        CombineRGN(Result, Result, tmpHrgn, RGN_OR);
        DeleteObject(tmpHrgn);
      end;
    4: //Pie and solid
      begin
        Result:= CreatePieRgn(pp[1],pp[2],pp[3],pp[4],Ord(fArcctype));
      end;
  end;
end;

procedure TArccPic.DrawFocusRect(ACanvas:TCanvas);  //在Acanvas上画焦点
var
  mRect: TRect;
  FocusNumber: Integer; //焦点数量
  i: Integer;
begin
  focusNumber := FOCUS_NUM; //=2   焦点数量
  GetFocusPoints;  //取焦点坐标
  LpToDp(ACanvas.Handle,FocusPoint[1],FocusNumber);
  ACanvas.Pen:=FocusPen;
  ACanvas.Brush:=FocusBrush;
  for i := 1 to focusNumber do begin  //绘制焦点矩形
    if i>8 then ACanvas.Brush.Color:=clLime;
    mRect.Left := focusPoint[i].x - FOCUS_SIZE;
    mRect.Top := focusPoint[i].y - FOCUS_SIZE;
    mRect.Right := focusPoint[i].x + FOCUS_SIZE;
    mRect.Bottom := focusPoint[i].y + FOCUS_SIZE;
    ACanvas.Rectangle(mRect.Left, mRect.Top, mRect.Right, mRect.Bottom);
  end;
end;

//鼠标响应
procedure TArccPic.ParentMouseDown(ACanvas:TCanvas;CursorNum:Integer;
        Button: TMouseButton;Shift: TShiftState; APoint:TPoint);
var
  pp:TPoint;
begin
  if Button = mbRight then  Exit;
  //设置pen的格式
  ACanvas.Pen:=PicPen;
  ACanvas.Pen.Mode:=pmXor;
  //设置Brush的格式
  ACanvas.Brush:=PicBrush;
  case fDrawState of
    ARC_DRAW:
      begin
        StartPos:=APoint;  //设置图元的起点
        EndPos := APoint;   //置终点坐标
        ArcStartPos:=APoint;
        ArcEndPos:=APoint;
      end;
    ARC_SET:   //确定圆弧的终点，圆弧的起点由mouseUp确定
      begin
        pp :=PointToCirclePoint(StartPos,EndPos, APoint);
        DpToLp(ACanvas.Handle, pp, 1);
        ArcEndPos:=pp;
      end;
  end;
end;

procedure TArccPic.ParentMouseMove(ACanvas:TCanvas;CursorNum:Integer;
        Shift: TShiftState;APoint:TPoint);
var
  radiu: Integer;
  centerX, centerY: Integer;
  pp: array[1..4] of TPoint;
begin
  case fDrawState of
    ARC_DRAW: //确定圆弧半径和起点
       begin
         if (ssLeft in Shift) then begin
          //清除前一次绘制的图形
           DrawArccPic(ACanvas,StartPos,EndPos,ArcStartPos,ArcEndPos);
           //绘制当前的图形
           centerX := (endPos.X + StartPos.x) div 2; //圆心
           centerY := (EndPos.y + StartPos.y) div 2;
           radiu := round(sqrt(sqr(Apoint.X - centerX) + sqr(Apoint.Y - centerY))); //半径
           StartPos.x := centerX - radiu; //调整圆弧的四角坐标
           StartPos.y := centerY - radiu;
           endPos.x := centerX + radiu;
           EndPos.y := centerY + radiu;
           DrawArccPic(ACanvas,StartPos,EndPos,ArcStartPos,ArcEndPos);
         end;
       end;
    ARC_SET: //确定圆弧终点
       begin
         //设置pen的格式
         ACanvas.Pen:=PicPen;
         ACanvas.Pen.Mode:=pmXor;
         //设置Brush的格式
         ACanvas.Brush:=PicBrush;
         centerX := (EndPos.x + StartPos.x) div 2; //圆心
         centerY := (EndPos.y + StartPos.y) div 2;
         //清除前一次绘制的图形
         //if fArccType<>ARCC_SECTOR then begin
           ACanvas.MoveTo(centerX, centerY);
           ACanvas.LineTo(arcEndPos.x, arcEndPos.y);
         //end;
         DrawArccPic(ACanvas,StartPos,EndPos,ArcStartPos,ArcEndPos);
         //绘制当前的图形
         pp[1] :=PointToCirclePoint(StartPos,EndPos, APoint);
         DpToLp(ACanvas.Handle, pp[1], 1);
         arcEndPos := pp[1]; //确定新的圆弧终点
         //if fArccType<>ARCC_SECTOR then begin
           ACanvas.MoveTo(centerX, centerY);
           ACanvas.LineTo(arcEndPos.x, arcEndPos.y);
         //end;
         DrawArccPic(ACanvas,StartPos,EndPos,ArcStartPos,ArcEndPos);
      end;
  end;
end;

procedure TArccPic.ParentMouseUp(ACanvas:TCanvas;CursorNum:Integer;
        Button: TMouseButton;  Shift: TShiftState; APoint:TPoint);
var
  pp: array[1..4] of TPoint;
  tmpRect:TRect;
  centerx,centery:Integer;
begin
  case fDrawState of
    ARC_DRAW: //确定半径和圆弧的起点
      begin
        arcStartPos:=APoint;
        arcEndPos := APoint;
        if ((Abs(EndPos.x - StartPos.x) < MinCellSize) or
            (Abs(EndPos.y - StartPos.y) < MinCellSize)) then  begin
          endPos.x := endPos.x + MinCellSize;
          endpos.y := endpos.y + MinCellSize;
        end;
        pp[1] := StartPos;
        pp[2] := EndPos;
        pp[3] := arcStartPos;
        pp[4] := arcEndPos;
        DpToLp(ACanvas.Handle, pp[1], 4);
        StartPos := pp[1];
        endPos   := pp[2];
        arcStartPos := pp[3];
        arcEndPos := pp[4];
        with tmpRect do  begin //保证右下角坐标大于,等于左上角坐标