freepicu.pas

矢量图源代码 包括直线文本矩形等等

unit FreePicU;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ImgList, ComCtrls, ToolWin, ExtCtrls, Buttons,Contnrs,
  PicBase,LinePic,RectPic,RounPic,CircPic,ArccPic,PolyPic,CurvePic,TextPic, //图象类
  PicConst,PicFuns, BmpFuns, Menus;  //常量

type
  TFreePicF = class(TForm)
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Panel1: TPanel;
    ScrollBox1: TScrollBox;
    Image1: TImage;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton8: TSpeedButton;
    SpeedButton9: TSpeedButton;
    SpeedButton10: TSpeedButton;
    SpeedButton11: TSpeedButton;
    SpeedButton12: TSpeedButton;
    SpeedButton13: TSpeedButton;
    SpeedButton14: TSpeedButton;
    SpeedButton15: TSpeedButton;
    SpeedButton0: TSpeedButton;
    PicMenu: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    N5: TMenuItem;
    N6: TMenuItem;
    N7: TMenuItem;
    N8: TMenuItem;
    N9: TMenuItem;
    N10: TMenuItem;
    N11: TMenuItem;
    N12: TMenuItem;
    N13: TMenuItem;
    N14: TMenuItem;
    N15: TMenuItem;
    N16: TMenuItem;
    SpeedButton7: TSpeedButton;
    SpeedButton6: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton17: TSpeedButton;
    SpeedButton18: TSpeedButton;
    SpeedButton16: TSpeedButton;
    G1: TMenuItem;
    N17: TMenuItem;
    N18: TMenuItem;
    N19: TMenuItem;
    N3D1: TMenuItem;
    X1: TMenuItem;
    S1: TMenuItem;
    N20: TMenuItem;
    I1: TMenuItem;
    A1: TMenuItem;
    O1: TMenuItem;
    C1: TMenuItem;
    N21: TMenuItem;
    N22: TMenuItem;
    N23: TMenuItem;
    N24: TMenuItem;
    N25: TMenuItem;
    N26: TMenuItem;
    procedure FormShow(Sender: TObject);
    procedure SpeedButton0Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure SpeedButton8Click(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure N1Click(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure N10Click(Sender: TObject);
    procedure N11Click(Sender: TObject);
    procedure N3D1Click(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure N16Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Image1DblClick(Sender: TObject);
    procedure N20Click(Sender: TObject);
    procedure N26Click(Sender: TObject);
  private
    //
    mouseOldX, mouseOldY: Integer; //前一次鼠标的位置
    mouseDownOldX, mouseDownOldY: Integer; //鼠标Down的位置
    mousePos:MOUSE_POS;
    //
    CopyPic:TPicBase;
    {CopyLine:TLinePic;
    CopyRect:TRectPic;
    CopyRoun:TRounPic;
    CopyCirc:TCircPic;
    CopyArcc:TArccPic;
    CopyPoly:TPolyPic;
    CopyCurve:TCurvePic;
    CopyText:TTextPic;}
    //
    OffSrc:TBitMap;
    PicList:TComponentList;
    SelPic: TPicBase;
    LinePic:TLinePic;
    RectPic:TRectPic;
    RounPic:TRounPic;
    CircPic:TCircPic;
    ArccPic:TArccPic;
    PolyPic:TPolyPic;
    CurvePic:TCurvePic;
    TextPic:TTextPic;
    procedure InitPicVar;
    procedure FreePicVar;
    procedure PicDrawEndEvent(Pic:TComponent);
    procedure GetImageCanvasBmp(DisChoose:Boolean; DrawToImage:Boolean);
    Function  GetMousePos(mp:TPoint;var index:Integer):MOUSE_POS;
    procedure ClearPicListData;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FreePicF: TFreePicF;
  LedW,LedH:Integer;

var
  InfBuf:Array[0..4] of Char;
  PicBuf:Array[0..1023] of Char;  //2k数据空间
  BufLen: Integer;

implementation

uses SetLineW;

{$R *.dfm}


procedure TFreePicF.InitPicVar;
begin
  SelPic := TPicBase.Create;
  LinePic:=TLinePic.Create;
  LinePic.DrawEndEvent:=PicDrawEndEvent;
  RectPic:=TRectPic.Create;
  RectPic.DrawEndEvent:=PicDrawEndEvent;
  RounPic:=TRounPic.Create;
  RounPic.DrawEndEvent:=PicDrawEndEvent;
  CircPic:=TCircPic.Create;
  CircPic.DrawEndEvent:=PicDrawEndEvent;
  ArccPic:=TArccPic.Create;
  ArccPic.DrawEndEvent:=PicDrawEndEvent;
  PolyPic:=TPolyPic.Create;
  PolyPic.DrawEndEvent:=PicDrawEndEvent;
  CurvePic:=TCurvePic.Create;
  CurvePic.DrawEndEvent:=PicDrawEndEvent;
  TextPic:=TTextPic.Create(ScrollBox1);
  TextPic.DrawEndEvent:=PicDrawEndEvent;
  CopyPic:=TPicBase.Create;
end;

procedure TFreePicF.FreePicVar;
begin
  CopyPic:=nil;
  CopyPic.Free;
  SelPic:=Nil;
  SelPic.Free;
  LinePic.Free;
  RectPic.Free;
  RounPic.Free;
  CircPic.Free;
  ArccPic.Free;
  PolyPic.Free;
  CurvePic.Free;
  TextPic.Free;
end;

procedure TFreePicF.PicDrawEndEvent(Pic:TComponent);
var
  PicLine:TLinePic;
  PicRect:TRectPic;
  PicRoun:TRounPic;
  PicCirc:TCircPic;
  PicArcc:TArccPic;
  PicPoly:TPolyPic;
  PicCurve:TCurvePic;
  PicText:TTextPic;
begin
  Case TPicBase(Pic).PicId of
    PIC_LINE:
        begin
          PicLine:=TLinePic.Create;
          PicLine.AssignPic(TLinePic(Pic));
          PicLine.PicIndex:=PicList.Count;
          PicList.Add(PicLine);
        end;
    PIC_RECT:
        begin
          PicRect:=TRectPic.Create;
          PicRect.AssignPic(TRectPic(Pic));
          PicRect.PicIndex:=PicList.Count;
          PicList.Add(PicRect);
        end;
    PIC_ROUN:
        begin
          PicRoun:=TRounPic.Create;
          PicRoun.AssignPic(TRounPic(Pic));
          PicRoun.PicIndex:=PicList.Count;
          PicList.Add(PicRoun);
        end;
    PIC_CIRC:
        begin
          PicCirc:=TCircPic.Create;
          PicCirc.AssignPic(TCircPic(Pic));
          PicCirc.PicIndex:=PicList.Count;
          PicList.Add(PicCirc);
        end;
    PIC_ARCC:
        begin
          PicArcc:=TArccPic.Create;
          PicArcc.AssignPic(TArccPic(Pic));
          PicArcc.PicIndex:=PicList.Count;
          PicList.Add(PicArcc);
        end;
    PIC_POLY:
        begin
          PicPoly:=TPolyPic.Create;
          PicPoly.AssignPic(TPolyPic(Pic));
          PicPoly.PicIndex:=PicList.Count;
          PicList.Add(PicPoly);
          TPolyPic(Pic).PolyPointNum:=0;
        end;
    PIC_CURVE:
        begin
          PicCurve:=TCurvePic.Create;
          PicCurve.AssignPic(TCurvePic(Pic));
          PicCurve.PicIndex:=PicList.Count;
          PicList.Add(PicCurve);
          TCurvePic(Pic).CurvePointNum:=0;
        end;
    PIC_TEXT:
        begin
          PicText:=TTextPic.Create(Nil);
          PicText.AssignPic(TTextPic(Pic));
          PicText.PicIndex:=PicList.Count;
          PicList.Add(PicText);
        end;
  end;
  GetImageCanvasBmp(False,True);
end;

procedure TFreePicF.FormShow(Sender: TObject);
begin
  OffSrc.PixelFormat:=pf4Bit;
  OffSrc.Canvas.Brush.Color:=clBlack;
  OffSrc.Canvas.Brush.Style:=bsSolid;
  OffSrc.Width:=LedW;
  OffSrc.Height:=LedH;
  OffSrc.Canvas.FillRect(Rect(0,0,OffSrc.Width,OffSrc.Height));
  Image1.Picture.Assign(OffSrc);
end;

procedure TFreePicF.SpeedButton0Click(Sender: TObject);
begin
  GetImageCanvasBmp(True,False);
  ShowAllSizeOfImage(OffSrc);
end;

procedure TFreePicF.FormCreate(Sender: TObject);
begin
  DoubleBuffered:=True;
  InitPicVar;   //初始化图象变量类
  OffSrc:=TBitmap.Create;
  PicList:=TComponentList.Create;
end;

procedure TFreePicF.FormClose(Sender: TObject; var Action: TCloseAction);
var
  i1:Integer;
begin
  For i1:=PicList.Count-1 downto 0 do begin
    Case TPicBase(PicList.Items[i1]).PicId of
      PIC_LINE:  TLinePic(PicList.Items[i1]).Free;
      PIC_RECT:  TRectPic(PicList.Items[i1]).Free;
      PIC_ROUN:  TRounPic(PicList.Items[i1]).Free;
      PIC_CIRC:  TCircPic(PicList.Items[i1]).Free;
      PIC_ARCC:  TArccPic(PicList.Items[i1]).Free;
      PIC_POLY:  TPolyPic(PicList.Items[i1]).Free;
      PIC_CURVE: TCurvePic(PicList.Items[i1]).Free;
      PIC_TEXT:  TTextPic(PicList.Items[i1]).Free;
    end;
  end;
  FreePicVar;  //释放图象变量类
  OffSrc.Free;
  PicList.Free;
end;

procedure TFreePicF.SpeedButton8Click(Sender: TObject);
var
  atext:TTextInfo;
begin
  if TSpeedButton(Sender).Down then begin
    Case TSpeedButton(Sender).Tag of
      1..4:
         begin
           Image1.Cursor:=TSpeedButton(Sender).Tag;
         end;
      5: begin
           Image1.Cursor:=5;
           ArccPic.PicArccType:=ARCC_ARC;
         end;
      6: begin
           Image1.Cursor:=5;
           ArccPic.PicArccType:=ARCC_SECTOR;
         end;
      7: begin
           Image1.Cursor:=5;
           ArccPic.PicArccType:=ARCC_CHORD;
         end;
      8: begin
           Image1.Cursor:=6;
           PolyPic.PolyType:=PolyOpen;
         end;
      9: begin
           Image1.Cursor:=6;
           PolyPic.PolyType:=PolyClose;
         end;
      10:begin
           Image1.Cursor:=7;
         end;
      11:begin
           Image1.Cursor:=8;
         end;
    end;
    if (SelPic is TTextPic) then  begin
      aText.Keyval:=27;
      if TTextPic(SelPic).EditShowing then TTextPic(SelPic).Text:=aText;
    end;
    Case Image1.Cursor of
      CURSOR_LINE: SelPic:=LinePic;
      CURSOR_RECT: SelPic:=RectPic;
      CURSOR_ROUN: SelPic:=RounPic;