PAPIR

Top  Previous  Next

 

unit Papir;

 

interface

 

uses

SysUtils, WinTypes, WinProcs, Messages, Classes,

Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls,

ClipBrd;

 

type

TRajzStyle = (rsNone,rsPoint,rsLine,rsRectangle,rsRoundRect,

           rsPolygon,rsEllipse,rsArc,rsChord,rsImage,rsText,rsRotText,

           rsPen,rsBrush);

 

TRec = record

  x1,y1,x2,y2 : integer;

end;

 

THaloRecord = record

  vanhalo: boolean;       { True=hálórajzolás mehet }

  halomeret: integer;     { rácstávolság }

  haloszin: LongInt;      { rács szine }

  halostylus: integer;    { rács vonaltipusa }

end;

 

TPolyline     = record    {Poligon rekord}

  pontszam    : word;                  {töréspontok száma}

  pontok      : Array[0..0] of TPoint; {Töréspontok}

end;

 

 

TArc          = record

  x1,y1,x2,y2 : integer;

  x3,y3,x4,y4 : integer;

end;

 

FuncHeader = record

  Rekordhossz : word;

  Funkciokod  : TRajzStyle;

end;

 

FuncRekord = record

  Rekordhossz : word;

  Funkciokod  : TRajzStyle;

  Case RajzStyle: TRajzStyle of

   rsPoint    : (p:TPoint);

   rsLine,rsRectangle,rsRoundrect,rsEllipse : (l:TRect);

   rsPolygon  : (po:TPolyline);

   rsArc      : (a:TArc);

   rsChord     : (c:TArc);

   rsText     : (t:string[20]);

   rsRotText  : (rt:byte);

   rsPen      : (rp:TPen);

   rsBrush    : (br:TBrush);

   rsImage    : (i:byte);

end;

 

{.GRX index mutatótábla rekordszerkezete}

 

IndexRekord = record

  Rekordcim   : Longint;     {mutató a funkció kezdetére}

  Funkciokod  : TRajzStyle;  {funkciókód}

  Befoglalo   : TRect;       {befoglaló téglalap}

  jelzo       : boolean;     {jelző adat valamilyen célra}

end;

 

 

TRajzlap = class(TCustomControl)

private

  FPen          : TPen;

  FBrush        : TBrush;

  FFont         : TFont;

  FRajzStyle    : TRajzStyle;

  oldFRajzStyle : TRajzStyle;

  FText         : String;

  FAlapszin     : TColor;

  FLabel        : TLabel;

  FFilenev      : String;

  FHeight       : integer;

  FWidth        : integer;

  Frajzelemdb   : Longint;

  FKoordinata   : boolean;

  Forigin       : Tpoint;

  FmovePt       : Tpoint;

  FtmFunc       : TMemoryStream; {.Gra adatfile funkciók }

  tmFuncBase    : pointer;       {Func. memorystream kezdete}

  tmFuncPointer : Longint;       {Func. m.stream aktuális pozíciója}

  tmFuncEnd     : Longint;       {Func. m.stream végére mutat,

                                      az első szabad helyre}

  tmIndex      : TMemoryStream;  {.Grx Mutatótábla a fmFunc stream-hez}

  tmIndexPointer: Longint;       {Index m.stream aktuális pozíciója}

  tmIndexEnd   : Longint;        {Index m.stream végére mutat}

  frec         : Funcrekord;

  irec         : IndexRekord;    {memorystream mutatótábla rekord}

  poly         : TPolyline;      {Poligon rekord}

  FNagyitas    : real;           {A rajz nagyítási tényezője}

 

  procedure SetAlapszin(Value: TColor);

  procedure SetFilenev(Value: string);

  procedure SetPen(Value: TPen);

  procedure SetBrush(Value: TBrush);

  procedure SetFLabel(Value: TLabel);

  procedure SetRajzStyle(Value: TRajzStyle);

{    procedure WMCut(var Message: TMessage); message WM_CUT;

  procedure WMCopy(var Message: TMessage); message WM_COPY;

  procedure WMPaste(var Message: TMessage); message WM_PASTE;}

protected

  oldorigin : TPoint;

  oldmovePt : TPoint;

  alakit    : boolean;

  drawing   : boolean;

  oldrajzstyle: TRajzStyle;

  keret     : TRec;

  bef       : Trect;         {Befoglaló téglalap}

  bennevan  : boolean;       {Jelző: a pont benne van}

  valtozott : boolean;

  Procedure Paint;override;

  procedure MouseDown(Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);override;

  procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;

  procedure MouseUp(Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);override;

public

  property Canvas;

  constructor Create(AOwner:TComponent);override;

  destructor Destroy;override;

  Procedure Cls;

  procedure DrawShape(TopLeft,BottomRight: TPoint;

         AMode: TPenMode; ujrajz: Boolean);

  function  LoadFromFile(fnev: string):boolean;

  function  SaveToFile(fnev: string):boolean;

  Procedure RecordSave(frec:funcrekord);

  procedure RecordLoad(var frec:funcrekord);

  procedure ReDraw;

  procedure KillDraw;

{    procedure CopyToClipboard;

  procedure CutToClipboard;

  procedure PasteFromClipboard;

   {Rajzelem rekordok memória stream-je}

  property tmFunc: TmemoryStream read FtmFunc write Ftmfunc;

   {Rajzelemek száma}

  property rajzelemdb: Longint read Frajzelemdb write Frajzelemdb;

  property origin    : TPoint  read Forigin     write Forigin;

  property movePt    : TPoint  read FmovePt     write FmovePt;

published

  Property Align;

  Property Filenev : string read FFilenev write SetFilenev;

    { Koordináta megjelenik az aktuális kurzor pozícióban }

  property Koordinata: boolean read FKoordinata write FKoordinata default false;

  Property KoordLabel: TLabel read Flabel write SetFlabel;

  Property Alapszin : TColor read FAlapszin write SetAlapszin default clWhite;

  Property Pen : TPen read FPen write SetPen;

  Property Brush : TBrush read FBrush write SetBrush;

  Property RajzStyle : TRajzStyle read FRajzStyle write SetRajzStyle;

{    property Nagyitas: real read FNagyitas write FNagyitas;}

  Property Text;

 

  Property Top;

  Property Left;

  Property Height default 50;

  Property Width default 50;

  Property OnDblClick;

  Property OnMouseDown;

  Property OnMouseMove;

  Property OnMouseUp;

end;

 

Function F_Name(fn:string):string;

 

Const Lapmeretek : Array[0..2,1..2] of word = ((210,297),(297,420),(500,600));

 

procedure Register;

 

Var i,j: integer;

 

implementation

 

procedure Register;

begin

   RegisterComponents('AL',[TRajzlap]);

end;

 

constructor TRajzlap.Create(AOwner:TComponent);

begin

   inherited Create(AOwner);

   tmFunc  := TMemoryStream.Create;

   tmIndex := TMemoryStream.Create;

   tmFuncBase := tmFunc.Memory;

   FPen:=TPen.Create;

   FBrush:=TBrush.Create;

   tmFuncPointer := 0;

   tmIndexPointer:= 0;

   filenev:='';

   rajzelemdb := 0;

   Brush.color:=clWhite;

   height:=50;width:=50;

   FAlapszin := clWhite;

{     nagyitas:=1;}

end;

 

destructor TRajzlap.Destroy;

begin

   FPen.Free;

   FBrush.Free;

   tmFunc.Destroy;

   tmIndex.Destroy;

   inherited Destroy;

end;

 

 

procedure TRajzlap.Paint;

begin

 inherited Paint;

 RedRaw;

end;

 

procedure TRajzlap.SetAlapszin(Value: TColor);

begin

If FAlapszin<>Value then begin

   FAlapszin:=Value;

   Redraw;

end;

end;

 

procedure TRajzlap.SetFilenev(Value: string);

begin

If FFilenev<>Value then

   If FileExists(Value) then begin

      LoadFromFile(Value);

      FFilenev:=Value;

   end;

end;

 

procedure TRajzlap.SetPen(Value:TPen);

begin

If FPen<>Value then begin

 FPen.Assign(Value);

 Canvas.Pen.Assign(Value);

 Invalidate;

end;

end;

 

procedure TRajzlap.SetBrush(Value: TBrush);

begin

If FBrush<>Value then begin

FBrush.Assign(Value);

Invalidate;

end;

end;

 

procedure TRajzlap.SetFLabel(Value: TLabel);

begin

If Flabel<>Value then begin

 Flabel:=Value;

 Invalidate;

end;

end;

 

procedure TRajzlap.SetRajzStyle(Value: TRajzStyle);

begin

FRajzStyle:=Value;

frec.Funkciokod:=Value;

bef := Rect(32000,32000,0,0);

poly.pontszam:=0;

end;

 

{ A grafikus felület törlése aktuális ecsetszínnel}

Procedure TRajzlap.Cls;

begin

Canvas.Brush.style := bsSolid;

Canvas.Brush.color := Alapszin;

Canvas.FillRect(clientrect);

Update;

end;

 

procedure TRajzlap.MouseDown(Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

Origin := Point(X, Y);

MovePt := Origin;

 

Case RajzStyle of

rsNone:

    begin

    end;

rsPoint,rsLine,rsRectangle,rsRoundRect:

    begin

         DrawShape(Origin, MovePt, pmNotXor,False);

         Drawing := True;

         Cursor:=crCross;

         Canvas.MoveTo(X, Y);

    end;

rsPolygon:

    Case Button of

    mbLeft:

    begin

         DrawShape(Origin, MovePt, pmCopy,True);

    end;

    mbRight:

    begin

         DrawShape(oldOrigin, MovePt, pmXor,True);

         RecordSave(frec);

         Drawing:=False;

    end;

    end;

end;

 

    oldOrigin := Point(x,y);

    oldMovePt := Point(x,y);

    inherited MouseDown(Button, Shift, X, Y);

end;

 

procedure TRajzlap.MouseMove(Shift: TShiftState; X,

Y: Integer);

begin

if Drawing then

begin

  DrawShape(Origin, MovePt, pmNotXor,False);

  MovePt := Point(X, Y);

  DrawShape(Origin, MovePt, pmNotXor,False);

end;

If FLabel<>nil then (Flabel as TLabel).Caption:=Format('%d, %d', [X, Y]);

If Koordinata then

begin

   Canvas.TextOut(x+8,y-8,Format('%d, %d', [X, Y]));

end;

inherited MouseMove(Shift, X, Y);

end;

 

procedure TRajzlap.MouseUp(Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

Var kiirandoszoveg: String;

  R : TRect;

begin

MovePt := Point(X, Y);

If (Origin.x=MovePt.x) and (Origin.y=MovePt.y) and not (rajzstyle=rsPolygon)

  and not (RajzStyle=rsPoint)  then

  begin

      rajzstyle := rsNone;

      Drawing:=False;

      alakit:=False;

  end;

if Drawing and (Button=mbLeft) then

  begin

    Case rajzstyle of

    rsPoint:

      begin

         DrawShape(Origin, MovePt, pmCopy, True);

      end;

    rsText:

    begin

      kiirandoszoveg:=Inputbox('Kiirandó szöveg','',kiirandoszoveg);

      If Length(Kiirandoszoveg)>0 then

      begin

        Canvas.Font.Height:=abs(MovePt.y-Origin.y);

        Canvas.Font.Size:=Trunc(abs(MovePt.x-Origin.x) div Length(kiirandoszoveg));

        R := Rect(Origin.x,Origin.y,x,y);

        Canvas.TextRect(R,0,0,kiirandoszoveg);

      end;

    end;

    rsPolygon : DrawShape(Origin, MovePt, pmCopy, True);

    end;

      oldrajzstyle:=rajzstyle;

      oldOrigin:=Origin;

      oldMovePt:=MovePt;

  end;

If rajzstyle=rsPolygon then

   Origin := MovePt

else begin

   Drawing := False;

   Cursor := crDefault;

end;

inherited MouseUp(Button, Shift, X, Y);

end;

 

procedure TRajzlap.DrawShape(TopLeft,BottomRight: TPoint;

         AMode: TPenMode; ujrajz: Boolean);

var p: TPen;

  b: TBrush;

  x1,y1,x2,y2: integer;

begin

  P:=FPen;

  b:=FBrush;

  Canvas.Pen.Mode := AMode;

  valtozott := True;

  x1:=TopLeft.X;

  y1:=TopLeft.Y;

  x2:=BottomRight.X;

  y2:=BottomRight.Y;

 

  If ujrajz then

  begin

         case rajzstyle of

              rsPoint  : begin

                 frec.p := Point(x1,y1);

                 bef    := Rect(x1,y1,x2,y2);

                 end;

              rsLine,rsRectangle,rsRoundRect,rsEllipse : begin

                 frec.l := Rect(x1,y1,x2,y2);

                 bef    := Rect(x1,y1,x2,y2);

                 end;

              rsPolygon:

                begin

                  If x1<bef.left then bef.left:=x1;

                  If x2>bef.right then bef.right:=x2;

                  If y1<bef.Top then bef.top:=y1;

                  If y2>bef.Bottom then bef.Bottom:=y2;

                  With poly do begin

                    pontok[pontszam] := Point(x1,y1);

                    pontszam := pontszam + 1;

                  end;

 

                end;

         end;

         frec.funkciokod := RajzStyle;

  end else begin

         Canvas.Pen.Color:= clBlack;

  end;

 

  case rajzstyle of

    rsPoint:  Canvas.Pixels[x1,y1]:=p.Color;

    rsLine: begin

              Canvas.MoveTo(x1,y1);

              Canvas.LineTo(x2,y2);

            end;

    rsRectangle: Canvas.Rectangle(x1,y1,x2,y2);

    rsEllipse  : Canvas.Ellipse(x1,y1,x2,y2);

    rsRoundRect: Canvas.RoundRect(x1,y1,x2,y2,(x1-x2) div 2, (y1-y2) div 2);

    rsPolygon: begin

              Canvas.MoveTo(x1,y1);

              Canvas.LineTo(x2,y2);

            end;

  end;

  canvas.pen := p;

  canvas.brush := b;

end;

 

function TRajzlap.LoadFromFile(fnev: string):boolean;

begin

 tmFunc.LoadFromFile(F_Name(fnev)+'.GRA');

 tmIndex.LoadFromFile(F_Name(fnev)+'.GRX');

 filenev := fnev;

 Redraw;

end;

 

function TRajzlap.SaveToFile(fnev: string):boolean;

begin

If valtozott then

begin

     tmFunc.SaveToFile(F_Name(fnev)+'.GRA');

     tmIndex.SaveToFile(F_Name(fnev)+'.GRX');

end;

valtozott := False;

end;

 

Function F_Name(fn:string):string;

var s: string;

begin

s:=ExtractFileName(fn);

Result:=Copy(s,1,Pos('.',s)-1);

end;

 

 

{ Teljes rajz ujrarajzolása }

 

procedure TRajzlap.ReDraw;

var x1,y1,x2,y2,x3,y3,x4,y4: integer;

  fhead : FuncHeader;

  hossz : Longint;

  rdb   : Longint;

  p     : TPoint;

begin

Cls;

tmFunc.Seek(0,0);

rajzelemdb := 0;

hossz:=tmFunc.Read(frec,SizeOf(frec));

While hossz<>0 do

begin

     RajzStyle := frec.Funkciokod;

 

     case rajzstyle of

         rsLine,rsRectangle,rsRoundRect,rsEllipse :

         begin

              Origin := Point(frec.l.left,frec.l.top);

              MovePt := Point(frec.l.right,frec.l.bottom);

              DrawShape(Origin, MovePt, pmCopy,False);

         end;

         rsArc:

         begin

         end;

         rsChord:

         begin

         end;

         rsPolygon:

         begin

             For i:=1 to frec.po.pontszam-1 do begin

               p:=frec.po.pontok[i];

               Origin := Point(p.x,p.y);

               p:=frec.po.pontok[i+1];

               MovePt := Point(p.x,p.y);

               DrawShape(Origin, MovePt, pmCopy,False);

             end;

         end;

     end;

     hossz:=tmFunc.Read(frec,SizeOf(frec));

     rajzelemdb := rajzelemdb + 1;

end;

end;

 

{ Teljes rajz kiirtása}

 

procedure TRajzlap.KillDraw;

var sd: TSaveDialog;

  path: string;

begin

If valtozott then

begin

  If MessageDlg('A kép megváltozott! Kívánja menteni?',

         mtInformation,mbYesNoCancel,0)=mrYes then begin

     sd:=TSaveDialog.Create(Application);

     sd.DefaultExt:='GRA';

     path:=ExtractFilePath(Filenev);

     sd.InitialDir:=Copy(path,1,Length(path)-1);

     sd.Filename:=Filenev;

     If sd.execute then SaveToFile(sd.Filename);

     sd.Free;

  end;

end;

tmFunc.SetSize(0);

rajzelemdb := 0;

valtozott  := False;

Cls;

end;

 

{ Mentés a memorzstream-ekre}

Procedure TRajzlap.RecordSave(frec:funcrekord);

begin

frec.rekordhossz:= SizeOf(frec);

With irec do begin

     rekordcim  := tmFuncPointer;

     funkciokod := RajzStyle;

     befoglalo  := bef;

     jelzo      := false;

end;

tmFuncPointer := tmFuncPointer + SizeOf(frec);

tmFunc.Write(frec,SizeOf(frec));

tmIndex.Write(irec,SizeOf(irec));

rajzelemdb := rajzelemdb + 1;

valtozott:=True;

end;

 

procedure TRajzlap.RecordLoad(var frec:funcrekord);

begin

end;

 

{

procedure TRajzlap.CopyToClipboard;

begin

if Picture.Graphic <> nil then Clipboard.Assign(Picture);

end;

 

procedure TRajzlap.CutToClipboard;

begin

if Picture.Graphic <> nil then

begin

  CopyToClipboard;

  Picture.Graphic := nil;

end;

end;

 

procedure TRajzlap.PasteFromClipboard;

begin

if Clipboard.HasFormat(CF_PICTURE) then

  Picture.Assign(Clipboard);

end;

 

 

procedure TRajzlap.WMCut(var Message: TMessage);

begin

CutToClipboard;

end;

 

procedure TRajzlap.WMCopy(var Message: TMessage);

begin

CopyToClipboard;

end;

 

procedure TRajzlap.WMPaste(var Message: TMessage);

begin

PasteFromClipboard;

end;

}

end.