textpic.pas

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

///////////////////////
//王昌雨
//2003-06-13
//矩形
///////////////////////
unit TextPic;

interface

uses Windows,Graphics,Math,Classes,Controls, StdCtrls,Forms,
  PicConst,PicBase,PicFuns, BmpFuns;

const
  FOCUS_NUM=8;

type
  TTextPic=Class(TPicBase)
    private
      StartPos:TPoint;
      EndPos:TPoint;
      fText:TTextInfo; //String;     //文字内容
      fHollow: Boolean;          //空心
      fSided:  Boolean;  //轮廓
      fView3D: Boolean;  //3D效果
      fBkColor: TColor;  //背景颜色
      //
      oldsp,oldep:TPoint;
      FocusPoint:Array[1..FOCUS_NUM] of TPoint;
      //TextKeyState:TShiftState;
      fEdit:  TEdit;     //输入框
      fTextbmp: TBitMap; //图象
      fCanvas:TCanvas;
      fInputMode:Boolean; //图象文字输入状态
      fEditMode: Boolean; //修改模式
      fEditParent: TObject; //fEdit的parent;
      procedure GetFocusPoints;
      procedure DrawBitmapToCanvas(aCanvas:TCanvas;DRect:TRect);
      procedure SetTextPicText(V:TTextInfo);
      procedure SetTextPicRect(StartPoint,endPoint:TPoint);
      function  GetEditShowing:Boolean;
      function  GetEditText:String;
    protected

    public
      constructor Create(aEditParent:TObject);
      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 DrawTextPic(ACanvas: TCanvas; startPoint:TPoint; endPoint:TPoint);
      procedure ParentDbClick(ACanvas:TCanvas);
      //property 的实现方法
    published
      property PicStartPoint:TPoint read StartPos write StartPos;
      property PicEndPoint: TPoint  read EndPos write EndPos;
      property Text : TTextInfo Read fText Write SetTextPicText;
      property Hollow : Boolean read fHollow write fHollow default False;
      property View3D : Boolean read fView3D write fView3D default False;
      property Sided  : boolean read fSided write  fSided default False;
      property BkColor: TColor read fBkColor write fBkColor default clBlack;
      property TextBmp: TBitMap read fTextbmp Write fTextbmp;
      property Canvas:  TCanvas read fCanvas;
      property EditParent:TObject read feditParent;
      property InputMode :Boolean read fInputMode;
      property EditMode: Boolean read fEditMode;
      property EditShowing:Boolean read GetEditShowing;
      property EditText: String read GetEditText;
      property PicPen;
      property PicBrush;
      Property PicFont;
      property PicRect;
      property Choosed;
      property PicId;
      property FocusPen;
      property FocusBrush;
      property PicIndex;
  end;

  procedure EditTextChange(Sender1:TObject; Sender:TObject);
  procedure EditTextKeyDown(Sender1:TObject;Sender: TObject; var Key: Word;Shift: TShiftState);


implementation

procedure EditTextChange(Sender1:TObject; Sender:TObject);
begin
  TEdit(Sender).Width :=GetCanvasTextWidth(TEdit(Sender).Text+'  ',TEdit(Sender).Font,True);
end;

procedure EditTextKeyDown(Sender1:TObject;Sender: TObject; var Key: Word;Shift: TShiftState);
var
  aTextInfo:TTextinfo;
begin
  aTextInfo.Keyval:=Key;
  if key=13 then begin //回车键
    TEdit(Sender).Parent:=Nil;
    aTextInfo.Text:=TEdit(Sender).Text;
    TTextPic(TEdit(Sender).Owner).Text:=aTextInfo;
  end else if key=27 then begin  //ESC键
    TEdit(Sender).Parent:=Nil;
    if not TTextPic(TEdit(Sender).Owner).EditMode then begin
      aTextInfo.Text:='';
      TTextPic(TEdit(Sender).Owner).Text:=aTextInfo;
    end;
  end;
end;

constructor TTextPic.Create(aEditParent:TObject);
var
  method:TMethod;
begin
  inherited Create;
  fText.Text:='';     //文字内容
  fHollow:=False;           //空心
  fSided:=False;  //轮廓
  fView3D:=False;  //3D效果
  fBkColor:=clBlack;  //背景颜色
  fEdit:=TEdit.Create(Self);     //输入框
  fEdit.BorderStyle:=bsNone;
  fEdit.Font:=PicFont;
  fEdit.Ctl3D:=False;
  fEdit.Width:=Abs(PicFont.Height);
  fEdit.Color:=clBlack;
  fEdit.Parent:=nil;
  fCanvas:=nil;
  Method.Code:=@EditTextChange;
  Method.Data:=@EditTextChange;
  fEdit.OnChange:=TNotifyEvent(Method);
  method.Code:=@EditTextKeyDown;
  method.Data:=@EditTextKeyDown;
  fEdit.OnKeyDown:=TKeyEvent(method);
  fTextbmp:=TBitMap.Create; //图象
  fTextbmp.PixelFormat:=pf4Bit; //16色位图
  fEditParent:=aEditParent;
  fInputMode:=False;
  fEditMode:=False;
end;

destructor  TTextPic.Destroy;
begin
  fEditParent:=nil;
  fEdit.Free;
  fTextbmp.Free;
  fCanvas:=Nil;
  inherited Destroy;
end;

procedure TTextPic.SetTextPicText(V:TTextinfo);
begin
  fEdit.Parent:=Nil;
  if fCanvas<>nil then InvalidatePicRect(fCanvas,PicRect);
  Case V.Keyval of
    13: begin  //回车键
          //if fText.Text<>V.Text then begin
            fText.Text:=V.Text;
            fInputMode:=False;
            fEditMode:=False;
            if (fText.Text='') then fText.Text:=' ';
            Endpos.X:=StartPos.X+GetCanvasTextWidth(fText.Text,PicFont,True);
            endPos.Y:=StartPos.Y+GetCanvasTextWidth(fText.Text,PicFont,False); //fEdit.Height;
            SetTextPicRect(StartPos,endPos);
            Choosed:=True;
            DrawTextPic(fCanvas,StartPos,EndPos);
            if Assigned(DrawEndEvent) then DrawEndEvent(Self);
          //end;
        end;
    27: begin  //ESC键
          if fEditMode then DrawTextPic(fCanvas,StartPos,EndPos);
        end;
  end;
  fEdit.Text:='';
end;

procedure TTextPic.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; //终点
end;

procedure TTextPic.DrawBitmapToCanvas(ACanvas:TCanvas;DRect:TRect);
var
  i,j:Integer;
  x,y:integer;
begin
  x:=DRect.Left;
  y:=Drect.Top;
  For i:=0 to fTextbmp.Width-1 do begin
    for j:=0 to fTextbmp.Height-1 do begin
      if fTextBmp.Canvas.Pixels[i,j]<>clBlack then begin
        ACanvas.Pixels[x+i,y+j]:=fTextbmp.Canvas.Pixels[i,j];
      end;
    end;
  end;
  if Choosed then  DrawFocusRect(ACanvas);
end;

function  TTextPic.GetEditText:String;
begin
  Result:=fEdit.Text;
end;

procedure TTextPic.SetTextPicRect(StartPoint,EndPoint:TPoint);
var
  tmpRect:TRect;
  pp: array[1..2] of TPoint;
begin
  pp[1] := StartPoint;
  pp[2] := EndPoint;
  DpToLp(fCanvas.Handle, pp[1], 2);
  startPos := pp[1];
  endPos := pp[2];
  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.Left =tmpRect.Right then Inc(tmpRect.Right);
  if tmpRect.Top =tmpRect.Bottom then Inc(tmpRect.Bottom);
  StartPos:=tmprect.TopLeft;
  endpos:=tmprect.BottomRight;
  PicRect:=tmpRect;
end;

function  TTextPic.GetEditShowing:Boolean;
begin
  if (fInputMode or fEditMode) then Result:=True else Result:=False;
end;

procedure TTextPic.DrawPic(ACanvas:TCanvas);          //在acanvas上画图
var
  pp: array[1..2] of TPoint;
  drawStartPoint: Tpoint;
  drawEndPoint: Tpoint;
begin
  drawStartPoint := startPos;
  drawEndPoint := endPos;
  pp[1] := drawStartPoint;
  pp[2] := drawEndPoint;
  LpToDp(ACanvas.Handle, pp[1], 2); //取得设备坐标
  drawStartPoint := pp[1];
  drawEndPoint:=pp[2];
  fCanvas:=ACanvas;
  ACanvas.Pen:=PicPen;
  ACanvas.Brush:=PicBrush;
  ACanvas.Font:=PicFont;
  DrawTextPic(ACanvas, drawStartPoint, drawEndPoint);
  if Choosed then DrawFocusRect(ACanvas);;
end;

procedure TTextPic.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  TTextPic.MouseInPicRegion(ACanvas:TCanvas;APoint:TPoint): MOUSE_POS;  //鼠标位置
var
  mPoint: Tpoint;
  mRect: TRect;
  FocusNumber: Integer; //焦点数量
  i: Integer;
  RectHRGN: HRGN;
begin
  result := POS_OUT;
  focusNumber := FOCUS_NUM; // =2 焦点数量
  RectHRGN := CreatePicRgn(ACanvas);