freepicu.pas

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

      CURSOR_CIRC: SelPic:=CircPic;
      CURSOR_ARCC: SelPic:=ArccPic;
      CURSOR_POLY: SelPic:=PolyPic;
      CURSOR_CURVE:SelPic:=CurvePic;
      CURSOR_TEXT: SelPic:=TextPic;
    end;
  end else begin
    if (SelPic is TTextPic) then  begin
      aText.Text:=TTextPic(SelPic).EditText;
      if aText.Text<>'' then aText.Keyval:=13 else aText.Keyval:=27;
      if TTextPic(SelPic).EditShowing then TTextPic(SelPic).Text:=aText;
    end;
    if PicList.Count>0 then SelPic:=TPicBase(PicList.Items[PicList.Count-1]) else SelPic:=nil;
    Image1.Cursor:=CURSOR_ARROW;
  end;
  GetImageCanvasBmp(False,True);
end;

procedure TFreePicF.GetImageCanvasBmp(DisChoose:Boolean; DrawToImage:Boolean);
var
  i1:Integer;
begin
  OffSrc.Canvas.Brush.Color:=clBlack;
  OffSrc.Canvas.FillRect(Rect(0,0,OffSrc.Width,OffSrc.Height));
  For i1:=0 to PicList.Count-1 do begin
    if DisChoose then TPicBase(PicList.Items[i1]).Choosed:=False;
    TPicBase(PicList.Items[i1]).DrawPic(OffSrc.Canvas);
  end;
  if DrawToImage then Image1.Canvas.Draw(0,0,OffSrc);
end;


Function  TFreePicF.GetMousePos(mp:TPoint;var index:Integer):MOUSE_POS;
var
  i1:Integer;
  rpos:MOUSE_POS;
begin
  Result:=POS_OUT;
  if SelPic<>Nil then begin
    if SelPic.PicIndex<>-1 then begin
      rpos:=SelPic.MouseInPicRegion(Image1.Canvas,mp);
      if rpos<>POS_OUT then begin
        Result:=rPos;
        index:=SelPic.PicIndex;
        Exit; //返回
      end;
    end;
  end;
  For i1:=PicList.Count-1 downto 0 do begin
    rpos:=TPicBase(PicList.Items[i1]).MouseInPicRegion(Image1.Canvas,mp);
    if rpos<>POS_OUT then begin
      Result:=rPos;
      index:=TPicBase(PicList.Items[i1]).PicIndex;
      Break;
    end;
  end;
end;

procedure TFreePicF.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  aText:TTextInfo;
  pindex:Integer;
begin
  mouseDownOldX := X;
  mouseDownOldY := Y;
  mouseOldX := X;
  mouseOldY := Y;
  if (SelPic is TTextPic) then  begin
    if (Image1.Tag=0) then begin
      aText.Text:=TTextPic(SelPic).EditText;
      if TTextPic(SelPic).InputMode then begin
        if aText.Text<>'' then aText.Keyval:=13 else aText.Keyval:=27;
      end;
      if TTextPic(SelPic).EditMode then aText.Keyval:=27;
      if TTextPic(SelPic).EditShowing then TTextPic(SelPic).Text:=aText;
    end else Image1.Tag:=0;
  end;
  Case Image1.Cursor of
    CURSOR_LINE..CURSOR_TEXT:
      begin
        if (SelPic is TPolyPic) then begin
          if not(TPolyPic(SelPic).PicState) then GetImageCanvasBmp(True,True);
        end else begin
          GetImageCanvasBmp(True,True);
        end;
        SelPic.Choosed:=False;
        SelPic.ParentMouseDown(Image1.Canvas,Image1.Cursor,Button,Shift,Point(x,y));
      end;
    else
      begin
        mousePos:=GetMousePos(Point(x,y),pindex);
        if MousePos=Pos_Center then begin
          GetImageCanvasBmp(True,True);
          SelPic:=TPicBase(PicList.Items[pindex]);
          SelPic.Choosed:=True;
          SelPic.DrawFocusRect(Image1.Canvas);
        end;
      end;
  end;
  SetCapture(TWinControl(Image1).Handle); //捕捉所有的鼠标输入 mouseUp时释放
end;

procedure TFreePicF.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  pindex:Integer;
  picCursor:TCursor;
  procedure GetPicParentCursor;
  begin
    picCursor := crArrow; //箭头
    mousePos:=GetMousePos(Point(x,y),pindex);
    case mousePos of
      //矩形顶点
      POS_LEFTTOP: picCursor := crSizeNWSE; //左上
      POS_RIGHTTOP: picCursor := crSizeNESW; //右上
      POS_RIGHTBOTTOM: picCursor := crSizeNWSE; //右下
      POS_LEFTBOTTOM: picCursor := crSizeNESW; //左下
      //矩形的边中点
      POS_CENTERTOP: picCursor := crSizeNS; //上中
      POS_RIGHTCENTER: picCursor := crSizeWE; //右中
      POS_CENTERBUTTOM: picCursor := crSizeNS; //下中
      POS_LEFTCENTER: picCursor := crSizeWE; //左中
      POS_CENTER: picCursor := crSize; //矩形中央
      //直线端点
      POS_LINESTART: picCursor := CURSOR_LINE_END; //直线起点 1999.1.12
      POS_LINEEND: picCursor := CURSOR_LINE_END; //直线终点 1999.1.12
      POS_ROUNDRECT_TOP: picCursor := CURSOR_TRUN_VER; //圆角矩形的上圆角点
      POS_ROUNDRECT_LEFT: picCursor := CURSOR_TRUN_VER; //圆角矩形的左圆角点
      POS_ARCSTART: picCursor := CURSOR_TRUN_VER; //圆弧的起点
      POS_ARCEND: picCursor := CURSOR_TRUN_VER; //圆弧的终点
      POS_POLYPOINT: picCursor := CURSOR_TRUN_VER; //多边形顶点
      POS_CURVEPOINT: picCursor := CURSOR_TRUN_VER; //多边形顶点
    end;
    Image1.Cursor:=picCursor;
  end;
begin
  Case  Image1.Cursor of
    CURSOR_LINE..CURSOR_TEXT:
      begin
        SelPic.ParentMouseMove(Image1.Canvas,Image1.Cursor,Shift,Point(X,Y));
      end;
    CURSOR_ARROW:
      begin
        if (ssLeft in Shift) then Exit;
        GetPicParentCursor;
      end;
    else
      begin
        if (ssLeft in Shift) then begin
          if Ord(mousePos)>0 then begin
            if SelPic=nil then Exit;
            SelPic.PicChangeing(Image1.Canvas,MousePos,SelPic.PicRect,
                   MouseDownOldx,MouseDownOldY,MouseOldX,MouseOldY,X,Y);
          end;
          MouseOldX:=X;
          MouseOldY:=Y;
        end else begin
          GetPicParentCursor;
        end;
      end;
  end;
end;


procedure TFreePicF.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Case  Image1.Cursor of
    CURSOR_LINE..CURSOR_TEXT:
      begin
        SelPic.Choosed:=True;
        SelPic.ParentMouseUp(Image1.Canvas,Image1.Cursor,Button,Shift,Point(x,y));
      end;
    CURSOR_ARROW:
      begin
        SelPic:=Nil;
        GetImageCanvasBmp(True,True);
      end;
    else
      begin
        if Button=mbLeft then begin
          if SelPic=Nil then Exit;
          SelPic.PicChangedUpdate(Image1.Canvas,MousePos,SelPic.PicRect,MouseDownOldX,MouseDownOldY,X,Y);
          GetImageCanvasBmp(False,True);
        end else begin
          if SelPic=Nil then Exit;
          if (SelPic is TTextPic) then begin
            N1.Enabled:=False;
            N2.Enabled:=False;
            X1.Enabled:=False;
            N11.Enabled:=True;
            G1.Enabled:=True;
          end else begin
            N1.Enabled:=True;
            N2.Enabled:=True;
            X1.Enabled:=True;
            N11.Enabled:=False;
            G1.Enabled:=False;
            if ((SelPic is TLinePic) or (SelPic is TPolyPic)) then N6.Enabled:=False else N6.Enabled:=True;
            if (SelPic is TArccPic) then begin
              if TArccPic(SelPic).PicArccType=ARCC_ARC then N6.Enabled:=False else N6.Enabled:=True;
            end;
          end;
          PicMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
        end;
      end;
  end;
  ReleaseCapture; //释放鼠标
end;


procedure TFreePicF.N1Click(Sender: TObject);
var
  linew:Integer;
begin
  linew:=SelPic.PicPen.Width;
  if ShowSetLineWidthForm(linew) then begin
    SelPic.PicPen.Width:=linew;
    GetImageCanvasBmp(False,True);
  end;
end;

procedure TFreePicF.N20Click(Sender: TObject);
begin
  Case TMenuItem(Sender).Tag of
    1: SelPic.PicPen.Style:=psSolid;
    2: SelPic.PicPen.Style:=psDash;
    3: SelPic.PicPen.Style:=psDot;
    4: SelPic.PicPen.Style:=psDashDot;
    5: SelPic.PicPen.Style:=psDashDotDot;
  end;
  GetImageCanvasBmp(False,True);
end;


procedure TFreePicF.N3Click(Sender: TObject);
begin
  Case TMenuItem(Sender).Tag of
    1: SelPic.PicPen.Color:=clRed;
    2: SelPic.PicPen.Color:=clLime;
    3: SelPic.PicPen.Color:=clYellow;
  end;
  GetImageCanvasBmp(False,True);
end;


procedure TFreePicF.N10Click(Sender: TObject);
begin
  Case TMenuItem(Sender).Tag of
    1: SelPic.PicBrush.Style:=bsClear;
    2: SelPic.PicBrush.Color:=clRed;
    3: SelPic.PicBrush.Color:=clLime;
    4: SelPic.PicBrush.Color:=clYellow;
  end;
  if TMenuItem(Sender).Tag<>1 then SelPic.PicBrush.Style:=bsSolid;
  GetImageCanvasBmp(False,True);
end;

procedure TFreePicF.N26Click(Sender: TObject);
begin
  Case TMenuItem(Sender).Tag of
    1: SelPic.PicBrush.Style:=bsCross;
    2: SelPic.PicBrush.Style:=bsDiagCross;
    3: SelPic.PicBrush.Style:=bsHorizontal;
    4: SelPic.PicBrush.Style:=bsVertical;
    5: SelPic.PicBrush.Style:=bsBDiagonal;
    6: SelPic.PicBrush.Style:=bsFDiagonal;
  end;
  GetImageCanvasBmp(False,True);
end;


procedure TFreePicF.N11Click(Sender: TObject);
var
  aTextInfo:TTextInfo;
  FontDialog:TFontDialog;
begin
  FontDialog:=TFontDialog.Create(Nil);
  try
    FontDialog.Font.Assign(SelPic.PicFont);
    if FontDialog.Execute then begin
      SelPic.PicFont.Assign(FontDialog.Font);
      aTextInfo.Keyval:=13;
      aTextInfo.Text:=TTextPic(SelPic).Text.Text;
      TTextPic(SelPic).Text:=aTextinfo;
      GetImageCanvasBmp(False,True);
    end;
  finally
    FontDialog.Free;
  end;
end;

procedure TFreePicF.N3D1Click(Sender: TObject);
begin
  Case TMenuItem(Sender).Tag of
    1: begin
         TTextPic(SelPic).Hollow:=False;
         TTextPic(SelPic).Sided:=False;
         TTextPic(SelPic).View3D:=False;
       end;
    2: TTextPic(SelPic).Hollow:=True;
    3: TTextPic(SelPic).Sided:=True;
    4: TTextPic(SelPic).View3D:=True;
  end;
  GetImageCanvasBmp(False,True);
end;

procedure TFreePicF.SpeedButton4Click(Sender: TObject);
var
  mIndex:Integer;
  mLinePic:TLinePic;
  mRectPic:TRectPic;
  mRounPic:TRounPic;
  mCircPic:TCircPic;
  mArccPic:TArccPic;
  mPolyPic:TPolyPic;
  mCurvePic:TCurvePic;
  mTextPic:TTextPic;
  procedure ChangPicListItemIndex;
  var
    I:Integer;
  begin
    For I:=0 to PicList.Count-1 do TPicBase(PicList.Items[I]).PicIndex:=I;
    GetImageCanvasBmp(False,True);
  end;
  procedure ChangPicListSelect;
  var
    I:Integer;
  begin
    For I:=0 to PicList.Count-1 do TPicBase(PicList.Items[I]).Choosed:=False;
  end;
begin
  Case TSpeedButton(Sender).Tag of
    1: begin
         if SelPic<>Nil then begin
           if SelPic.PicIndex>=0 then CopyPic:=SelPic;
         end;
       end;
    2: begin
         if SelPic<>Nil then begin
           CopyPic:=SelPic;
           mIndex:=SelPic.PicIndex;
           TPicBase(PicList.Items[mIndex]).Free;;
           SelPic:=Nil;
           ChangPicListItemIndex;
         end;
       end;
    3: begin
         if CopyPic<>Nil then begin
           ChangPicListSelect;
           Case TPicBase(CopyPic).PicId of
             PIC_LINE:
                 begin