Wie kann ich schnell große bereiche einer grafik kopieren ?

[pluto]

Hallo,
ich habe ein problem, ich möchte ein windows paint nach schreiben(ansicht keine problem) nur ist er beim zeichnen eines größeren objekts einfach zu langsamm/träge...
ich weiß einfach nicht mehr weiter und hoffe das ihr euch den code anschauen könnt und mir helfen könnt:

Code: Alles auswählen

procedure TForm1.PaintBox1MouseDown(Sender: TOBject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  r1:trect;
begin
  if (ssLeft in Shift) and (ssright in shift = false) then begin
    mx:=x; my:=y;
//    r1.left:=; r1.top:=0; r1.Right:=buffer3.Width; r1.Bottom:=buffer3.Height;
    buffer3.Canvas.CopyRect(br,buffer.canvas,br);
    SetValue(buffer.canvas);
  end;
 
end;
 
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  r1:Trect;
begin
  if ssLeft in Shift then begin
    if t = true then begin
      buffer.Canvas.CopyRect(br,buffer3.canvas,br);
      t:=False;
    end;
 
    if Toolindex = 1 then begin
      Buffer.Canvas.moveto(mx,my);
      Buffer.Canvas.LineTo(x,y);
    end;
 
//    if mx < x then
      r1.left:=mx;
//    else
  //    r1.left:=mx+1;
 
//    if my < y then
     r1.top:=my;
//    else
//     r1.top:=my+1;
 
//    if x > mx then
      r1.right:=x;
//    else
//      r1.right:=x-1;
 
//    if y > my then
      r1.Bottom:=y;
//    else
//      r1.Bottom:=y-1;
 
    if Toolindex = 2 then Buffer.Canvas.Rectangle(r1);
    if Toolindex = 4 then Buffer.canvas.Ellipse(r1);
    t:=true;
    paintbox1.canvas.CopyRect(br,buffer.canvas,br);
    if ti >= tc then begin
      ti:=0;
 
      br.left:=mx-1;
      br.top:=my-1;
      br.right:=x+1;
      br.Bottom:=y+1;
      paintbox1.canvas.CopyRect(br,buffer.canvas,br);
    end
    else begin
      inc(ti);
    end;
 
  end;
end;
 
procedure TForm1.PaintBox1MouseUp(Sender: TOBject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  mx:=-1; my:=-1; t:=false; clear:=False; BackupvaluetoBuffer;
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
  r1:TRect;
begin
  r1.left:=0; r1.top:=0; r1.Right:=buffer.Width; r1.Bottom:=buffer.Height;
  paintbox1.canvas.CopyRect(r1,buffer.canvas,r1);
 
end;
 
procedure TForm1.PaintBox1Resize(Sender: TObject);
begin
    SetBufferSize(paintbox1.Width,paintbox1.Height)
end;

die idee das so zu machen habe ich aus dem Delphiforum !
ich frage mich wie das die IDE von lazarus macht !
denn dort kann ich große objekte problemslos zeichnen !
selbst in meinem paint2 ist es recht träge !

weiß jemmand rat ?

VIELEN DANK FÜR EURE HILFE !

[Euklid]

Morgen!

die idee das so zu machen habe ich aus dem Delphiforum !
ich frage mich wie das die IDE von lazarus macht !

Auch unter Lazarus gibt es den Befehl Canvas.CopyRect, der relativ schnell Bildausschnitte kopieren kann.

denn dort kann ich große objekte problemslos zeichnen !

Du meinst, du kannst unter Lazarus große Objekte schneller zeichenen als unter Delphi? - Wo steckt dann das Problem?
Mir fiel bisher vor allem auf, dass mit Lazarus erstellte Programme schneller Rechenroutinen durchlaufen...

selbst in meinem paint2 ist es recht träge !

Was meinst du denn mit "es"?

Viele Grüße, Euklid

[pluto]

du hast mich falsch verstanden: ich meinte allgmein.. ob ich nun unter delphi oder unter lazarus zeichne spielt keine rolle.

Mir geht es im die technik. Wenn ich in der IDE von Lazarus komponenten vergröße(auf bildschrimgröße) geht das relativ schnell(wobei die kompoente ist ja auch nur eine grafik so gesehen z.b. ein panel oder ein memo) und wenn ich in meiner paintbox was zeichne(siehe code in meinem ersten beitrag) ist er zimlich träge !
(hättes du mein code angesehen würdes du sehen das ich mit copyrect arbeite habe sogar Bitbtl probiert ist ehe noch langsammer).

mir geht es nur darum wie es MS Paint macht große viereck schnell zu zeichnen oder halt(weil ich unter linux bin) der Formual edtior von lazarus es macht... habe schon in denn qullcode gesucht doch leider nichts passendes gefunden... das suchen wird wohl noch mehr zeit in anspruch nehmen !

[Euklid]

Ich habe deinen Code angesehen und bemerkt, dass zu copyrect verwendest. Nur hatte ich das als schnellere Routine in Erinnerung, als du es beschreibst. Habe aber auch schon länger nicht mehr damit programmiert.

[theo]

Hast du denn auch irgendwo ein Paintbox1.invalidate drin?
Die Paintbox muss man ja erst zum zeichnen veranlassen.

Bei mir (GTK) geht das Zeichnen eigentlich recht schnell, bloss flackert's halt wie blöd, wenn du zum Beispiel ein Rechteck OnMouseMove verschiebst.

[theo]

Habe übrigens soeben einen Weg gefunden, wie man das flackern unter GTK1 auf ein erträgliches Mass reduzieren kann.
Vielleicht hilft's ja auch auf Windows

Code: Alles auswählen

unit Unit1; 
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls;
 
type
 
 
  { TPaintControl }
 
  TPaintControl=class (TCustomControl)
 
  public
    procedure MouseMove(Shift: TShiftState; X,Y: Integer);  override;
    procedure Paint; override;
  end;
 
 
  { TForm1 }
 
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
 
  private
    { private declarations }
    PainterControl: TPaintControl;
  public
    { public declarations }
  end;
 
var
  Form1: TForm1; 
  mx, my:integer;
  Buffer:TBitmap;
 
implementation
 
{ TForm1 }
 
 
 
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  PainterControl := TPaintControl.Create(Self);
  PainterControl.Align := alClient;
  PainterControl.Parent := Self;
  PainterControl.DoubleBuffered := True;
  Buffer:=TBitmap.create;
  mx:=200;
  my:=200;
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  PainterControl.Free;
  Buffer.free;
end;
 
procedure TForm1.FormResize(Sender: TObject);
begin
  if Assigned(Buffer) then
  begin
  Buffer.Width:=Width;
  Buffer.Height:=Height;
  end;
end;
 
 
{ TPaintControl }
 
procedure TPaintControl.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if ssLeft in Shift then begin
  inherited MouseMove(Shift, X, Y);
  mx:=x; my:=y;
  Invalidate;
  end;
end;
 
procedure TPaintControl.Paint;
begin
  inherited Paint;
  with Buffer.Canvas do
    begin
      Brush.Color:=clRed;
      FillRect(ClientRect);
      Brush.Color:=clyellow;
      Pen.Color:=clyellow;
      Ellipse(50,50,250,250);
      Brush.Color:=clgreen;
      FillRect(Rect(mx,my,mx+300, my+300));
      TextOut(10,10,inttostr(mx)+' '+inttostr(my));
      Canvas.Draw(0,0,Buffer);
    end;
end;  
 
initialization
  {$I unit1.lrs}
 
end.

[pluto]

nein habe ich nicht drin.. der grund: der anwender soll dort selbst ein viereck zeichnen können wie im windows paint halt windows(ich bin unter linux).

das flackert weil du muss es buffern bei einer paintbox !

ich habe das ganze jetzt so gelöst aller dings habe ich noch einige fehler:

Code: Alles auswählen

procedure TForm1.PaintBox1MouseDown(Sender: TOBject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  r1:trect;
begin
  if (ssLeft in Shift) and (ssright in shift = false) then begin
    mx:=x; my:=y;
    buffer.Canvas.MoveTo(x,y);
    Origin := Point(X, Y);
    MovePt := Origin;
    BackupvaluetoBuffer;
    t:=True;
    SetStdValue(buffer);
 
  end;
 
end;
 
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  r1,r2,r3:Trect;
  px,py:Integer;
  lDrawRect: TRect;
begin
  if ssLeft in Shift then begin
//    SetStdValue(buffer);
    buffer.Canvas.Brush.Style:=bsClear;
    buffer.Canvas.pen.Style:=psSolid;
 
    DrawShape(Origin, MovePt, pmNotXor);
 
 
    buffer.Canvas.Brush.Style:=bsSolid;
    MovePt := Point(X, Y);
    DrawShape(Origin, MovePt, pmNotXor);
 
 
    r1.left:=0; r1.top:=0; r1.Right:=buffer.Width; r1.Bottom:=buffer.Height;
    paintbox1.canvas.CopyRect(r1,buffer.canvas,r1);
  end;
end;
 
procedure TForm1.PaintBox1MouseUp(Sender: TOBject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  mx:=-1; my:=-1; t:=false; clear:=False;
  DrawShape(Origin, Point(X, Y), pmcopy);
//  BackupvaluetoBuffer;
//      DrawShape(Point(mx,my), Point(x,y), pmCopy);
end;

1: sobalt ich irgnwie brush.color nutzen möchte gibt es grafik fehler... er löscht nicht mehr sauber.
2: ich habe das gefühl das lazarus unter linux ein speicher fehler hat... den:
ich teste so rum und starte mehrmal die anwendung(wird jedesmal neu compliert) ist
bis irgenwan die paintbox komplet clblack ist und alles sehr träge ist... ich beende laazrus geht es wieder...
dieser fehler trit auch auf sobalt ich das TBitmap die größe der paintbox anpassen möchte wenn der anwender mein programm maximiert hat !

ich muss ja den fokus behalten sonst kann ich doch nicht mehr zeichnen oder sehe ich das falsch ?
bzw. ich möchte ja das der user entscheiden kann wie groß das objekt ist das er zeichnet !
ich hoffe mir kann jemmand von euch helfen *guckt erwartungsvoll"
(ich habe wie ein warnsigner gesucht aber nichts gefunden... in sämlitchen delphi foren habe ich gesucht und google habe ich genutzt und in denn qullcode von lazarus habe ich gesucht... aber leider kein hinweis gefunden wie ich das problem lösen könnte !

edit:

Code: Alles auswählen

Hast du denn auch irgendwo ein Paintbox1.invalidate drin?
Die Paintbox muss man ja erst zum zeichnen veranlassen.

warum das ? das verstehe ich jetzt nicht !
wenn ich eine paintbox nutze muss ich so oder so ein offsrceen nutzen sonst flackert es wie verückt !

d.h. ich zeichne mein kram erst in eine buffer variable(wie bei dir) und zeiche die auf den bildschrim !
das problem ist dabei nur das es bei jeder mausbewegung passiert und darum ist es träge !

draum geht es mir die ganze zeit !

allerdings habe ich es mit dem ändern des pen.modes geschaft die geschwindig keit zu steigern aber leider habe ich jetzt probleme mit dem ändern von brush.color bzw. überhaupt ändern eines penstyles oder eines brushstyles !
denn ist gibt dann die wildesten grafik fehler !

achja sobalt ich die paintbox vergräße und den buffer anpasse sehe ich einen teil aus einer anderen anwendung in den neuen bereich der sich beim vergrößern gebildet hat !

[theo]

Ich kann dein Problem jetzt nicht ganz nachvollziehen, aber ich habe dir oben einen Quelltext geschickt, der ganz nett funktioniert (besser geht's glaub nicht, es sei denn du hebelst die LCL aus und machst das für jedes Widgetset speziell). Oder flackert das bei dir immer noch? Hast du dir denn mal angeschaut wie hübsch das aussieht?
Für alle die zu doof sind das Beispiel nachzuvollziehen (ich meine nicht Pluto):
- Ein neues Projekt erstellen in Lazarus. (vorher Computer booten äh sorry starten)
- Eventhandler für Form1 einbauen durch clicken im Objektinspektor auf OnCreate, OnDestroy, OnResize.
- Ganzen!!! Quelltext von Unit1 überschreiben mit dem Quellttext oben bei "Habe übrigens..."
- Start (grünen, nach rechts gerichteten Pfeil clicken oder die Funktionstaste 9 (F9) drücken.
- Auf dem dann hoffentlich erscheinenden Formular die linke Maustaste drücken und Maus ziehen -> bewegt das grüne Quadrat wie's schöner kaum geht. Bemalt gleichzeitig das ganze Formular mit der Hintergrundfarbe rot und zeigt die Mauskoordinaten an.

Wenn es dann nicht gut aussieht, hast du ein Problem mit deiner Grafik installation bzw. X-Server.

Wenn du darauf aufbaust, müsste es eigentlich sauber laufen.
Vergiss TPaintbox. Das ist Kinderkram und sowieso (auch unter Delphi / Kylix) eine der überflüssigsten Komponenten.

Leite eine Komponente von TCustomControl ab, wie im Beispiel, dann hast du mehr Spass! Und: Ein lustiges neues Jahr wünsch ich allen!

[pluto]

Danke für den tipp !
werde ich gleich testen !
(unter windows läuft das beispiel mit dem paint ganz gut: es wurde mit delphi vor einigen monanten(bevor ich mit laazrus angefangen habe) kompliert !
dort geht es soga mit andren rand und füll mustern !)

[pluto]

dein code gut prima !
nur so weit war ich auch schon auf den "normalen paintboxen weg" das problem was ich jetzt habe ist ich möchte gerne mehre grafik auf den canvas malen ohne sie in objekten zu speichern... ich hoffe du versteht wie ich meine:
bei jedem klick z.b. möchte ich ein rechteck hinzufügen und ohne sie in irgenwelchen listen abspeichern zum müssen !

[pluto]

Code: Alles auswählen

unit aaaUnit1;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls;
 
type
 
{ TPaintControl }
 
  TPaintControl=class (TCustomControl)
 
  public
    ismouseup:Boolean;
    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;
 
    procedure Paint; override;
  end;
 
 
  { TForm1 }
 
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
 
  private
    { private declarations }
    PainterControl: TPaintControl;
  public
    { public declarations }
  end;
 
var
  Form1: TForm1;
  mx, my,sx,sy:integer;
  Buffer,buffer2,buffer3:TBitmap;
 
implementation
 
{ TForm1 }
 
 
 
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  PainterControl := TPaintControl.Create(Self);
  PainterControl.Align := alClient;
  PainterControl.Parent := Self;
  PainterControl.DoubleBuffered := True;
  PainterControl.ismouseup:=False;
  Buffer:=TBitmap.create;
  Buffer2:=TBitmap.create;
  Buffer3:=TBitmap.create;
  buffer3.canvas.FillRect(ClientRect);
  mx:=200;
  my:=200;
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  PainterControl.Free;
  Buffer.free;
end;
 
procedure TForm1.FormResize(Sender: TObject);
begin
  if Assigned(Buffer) then
  begin
  Buffer.Width:=Width;
  Buffer.Height:=Height;
//  Buffer2.Width:=Width;
//  Buffer2.Height:=Height;
  Buffer3.Width:=Width;
  Buffer3.Height:=Height;
//  buffer.canvas.FillRect(ClientRect);
//  buffer3.canvas.FillRect(ClientRect);
  end;
end;
 
 
{ TPaintControl }
 
procedure TPaintControl.MouseDown(Button:TMouseButton;Shift: TShiftState; X,Y: Integer);
begin
  if ssLeft in Shift then begin
  inherited MouseDown(Button,Shift, X, Y);
  mx:=x; my:=y;
  end;
end;
 
procedure TPaintControl.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if ssLeft in Shift then begin
  inherited MouseMove(Shift, X, Y);
  sx:=x; sy:=y;
  Invalidate;
  end;
end;
 
procedure TPaintControl.MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer);
begin
  inherited MouseUp(button,Shift, X, Y);
  ismouseup:=True;
  buffer2.Width:=x; buffer2.Height:=y;
  Invalidate
end;
 
procedure TPaintControl.Paint;
begin
  inherited Paint;
 
   if ismouseup = true then begin
     ismouseup:=false;
     buffer.canvas.draw(0,0,buffer2);
   end;
 
   buffer3.Canvas.Draw(0,0,Buffer);
 
 
  with Buffer2.Canvas do begin
      Brush.Color:=clRed;
      FillRect(ClientRect);
      Brush.Color:=clgreen;
      Rectangle(mx,my,sx,sy);
 
      Buffer3.Canvas.Draw(mx,my,buffer2);
     Canvas.Draw(0,0,Buffer3);
    end;
 
end;
 
initialization
  {$I aaaUnit1.lrs}
 
end.

leider funktniert diese code nicht so wie gedacht meine idee:
ich schreibe ständig buffer2 neu d.h. dort wird das rechteck ständig neu gezeichnet !
davor wird der inhalt von buffer auf buffer3 gezeichnet(komplet) und zum schluss wird buffer4 ausgebenen !
doch leider habe ich so massive speich fehler bzw. ich sehe bildbereich aus andren anwendungen !
und es passiert leider nicht das was ich wollte:
bei mouseup wollte ich gerne den inhalt von buffer2 in buffer zeichnen... was leider anscheit nicht klaptt !

[pluto]

so habe ich es jetzt geschaft:

Code: Alles auswählen

procedure TPaintControl.Paint;
begin
  inherited Paint;
 
   if ismouseup = true then begin
     ismouseup:=false;
     buffer.canvas.copyrect(rect(mx,my,sx,sy),buffer2.canvas,rect(mx,my,sx,sy));
   end;
 
   buffer3.Canvas.Draw(0,0,Buffer);
 
 
  with Buffer2.Canvas do begin
      Brush.Color:=clRed;
      FillRect(ClientRect);
      Brush.Color:=clgreen;
      Brush.style:=bsClear;
      Pen.Style:=psDash;
      Rectangle(mx,my,sx,sy);
 
      buffer3.canvas.copyrect(rect(mx,my,sx,sy),buffer2.canvas,rect(mx,my,sx,sy));
 
 
     Canvas.Draw(0,0,Buffer3);
    end;
 
end;

PS: was auch sehr lustig ist: beim starten sehe ich das bild was ich zuvor gezeichnet habe ! obwohln inwischen die buffer2 buffer3 .free gesetzt werden !

ps: sobalt ich brush.style auf bsClear setzt habe ich ein clblack viereck
sofor habe ich pen.style z.b. psSoild gesetzt jetzt müste ich eigentlich nur den rand vom viereck sehen richtig?

achja zu den speicher fehler:
ich hahbe laazrus schon neugestartet hilft aber auch nur wengi bzw. garnicht !
ich sehe immer das bild was ich im vorfehld gepseichert habe !
ich habe das gefühl es liegt an .free !!!

[pluto]

PS: ich wollt gerne zwei bilder hochladen damit ihr es besser sehen könnt aber das werde ich leider erst machen können wenn ich die bilder mit MSPaint angepasst habe weil leider untertützt dieses forum das mit den bildern nicht 100%ig!

es währe praktisch wenn die bilder erst angezeigt werden wenn ich auf den link klicke dann währe die größe der bilder auch egla so lange sie unter ein 1MB liegt !

[theo]

PS: was auch sehr lustig ist: beim starten sehe ich das bild was ich zuvor gezeichnet habe ! obwohln inwischen die buffer2 buffer3 .free gesetzt werden !

Du musst halt zuerst den Hintergrund überpinseln wie im Beispiel:

Brush.Color:=clRed;
FillRect(ClientRect);

[pluto]

das habe ich jetzt auch geschaft nur habe ich noch probleme mit der geschwindigkeit(*schnif*) komme da einfach nicht weiter !