Runtime da create edilen timage'ın drag drop parent sorunu

[mss]

Merhaba arkadaşlar

Runtime esnasında bir tane pagecontrol üzerine timage create ettiriyorum. Bu image'ın pagecontrol üzerinden Mouse ile alıp aynı form üzerindeki panele Tshape taşır gibi taşımak istiyorum ancak image'ı taşımaya başladığımda formun en başına gidiyor nasıl yapabilirim. Nerede yanlış var?

Kod: Tümünü seç

procedure tform2.imgmousedown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  move:=true;
  TImage(Sender).BeginDrag(true);
  //showmessage(TImage(Sender).name);
  pt1.x:=X;
  pt1.Y:=Y;
  timage(sender).Parent:=form2;
  timage(sender).BringToFront;
  end;
procedure TForm2.MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  move:=false;
end;

procedure TForm2.DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
   accept:= sender is timage
end;

procedure TForm2.MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
if move= true then
begin
if x>pt1.x then timage(sender).Left  := mouse.cursorpos.x+(x-pt1.X);
if x<pt1.x then timage(sender).Left  := mouse.cursorpos.x+x+pt1.X);
if y>pt1.y then timage(sender).top   := mouse.cursorpos.y+y-pt1.y);
if y<pt1.y then timage(sender).top   := mouse.cursorpos.y+y+pt1.y);
end;
end;

[mrmarman]

Sana bir örnek hazırladım. Bu mesaj ekinde bulacaksın.



Yapılan işlem tümüyle bir ilüzyon yani göz aldatmacası...
Detaylı açıklamaları kod satırlarında yer alıyor.

Soruna bonus olarak bunu çift taraflı tasarladım. Yani soldan sağa, sağdan sola her iki yönde de mümkün.

Kaynak kodları ile proje bütünü bu mesaj ekindedir.

Kod: Tümünü seç

Const
  xiMarjinX = 4;
  xiMarjinY = 4;
Var
  OrjImageMousePoint,
  OrjImageFormGenelindekiReferansPoint,
  OrjImageFarkPoint : TPoint;
  boolTasiyoruz     : Boolean;
  boolGeri          : Boolean;

procedure TForm1.Image_OrjMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Panel_DublorMouseDown( Sender, Button, Shift, X, Y);
end;

procedure TForm1.Panel_DublorMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    boolGeri := TImage(Sender) = Image_Hedef;
    boolTasiyoruz := True;
 // Amacımız ilk olarak Mouse ile Image üzerinde tıklanan yeri alıp
 // Dublör Panel'imizi Image üzerinde tam örtüştürüp
 // Panel üzerindeki Mouse konumunu Image ile aynı noktaya sabitlemektir.

 // Orjinal Image üzerinde mouse ile tıkladığımız Yer...
    OrjImageMousePoint := Point( X, Y );
 // Orjinal Image üzerinde mouse ile tıkladığımız yerin Form Genelindeki Yeri...
    OrjImageFormGenelindekiReferansPoint := self.ScreenToClient( TImage(Sender).ClientToScreen(Point(X, Y)) );
 // Fark değerlerini her mouse X, Y değeri için Dublör Panel yerini stabil halde tutmak için alıyoruz...
    OrjImageFarkPoint.X := OrjImageFormGenelindekiReferansPoint.X - OrjImageMousePoint.X;
    OrjImageFarkPoint.Y := OrjImageFormGenelindekiReferansPoint.Y - OrjImageMousePoint.Y;

  // Şimdi orjinal Image'i Panel üzerindeki dublorüne kopyalıyoruz...
    Image_Dublor.Picture.Assign( TImage(Sender).Picture );
    Image_Dublor.AutoSize := True;
    Image_Dublor.Left     := xiMarjinX;
    Image_Dublor.Top      := xiMarjinY;

  // Panel büyüklüğünü dublöre göre yeniden boyutlandırıyoruz...
    Panel_Dublor.Width    := Image_Dublor.Width  + (xiMarjinX*2);
    Panel_Dublor.Height   := Image_Dublor.Height + (xiMarjinY*2);
  // Taşıma durumunda Dublörün etrafını kırmızı boyalı çerçeveli göreceğiz...
  // Maksat kullanıcı dostu olsun...
    Panel_Dublor.Color    := clRed;
    Panel_Dublor.Caption  := '';

  // Panelin orjinali ile üst üste örtüşmesini sağlıyoruz ki ilüzyon işe yarasın :)
    Panel_Dublor.Left      := OrjImageFarkPoint.X - xiMarjinX;
    Panel_Dublor.Top       := OrjImageFarkPoint.Y - xiMarjinY;

  // Dublorü Visible TRUE ile gösterip, orjinalini Visible FALSE ile gizliyoruz...
    Panel_Dublor.Visible   := True;
    Image_Orj.Visible   := False;
  end;
end;

procedure TForm1.Panel_DublorMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if boolTasiyoruz then
  begin
    Panel_Dublor.Left := OrjImageFarkPoint.X + X - OrjImageMousePoint.X - xiMarjinX;
    Panel_Dublor.Top  := OrjImageFarkPoint.Y + Y - OrjImageMousePoint.Y - xiMarjinY;
  // Buda bonus..
  // Taşıdığın yer bırakılmaya uygun ise Kırmızı çerçeve Yeşil olur...
    if (X >= Panel_Hedef.Left) AND (X <= Panel_Hedef.Width  + Panel_Hedef.Left)
    AND(Y >= Panel_Hedef.Top ) AND (Y <= Panel_Hedef.Height + Panel_Hedef.Top )
      then Panel_Dublor.Color := clLime
      else Panel_Dublor.Color := clRed;
  end;
end;

procedure TForm1.Panel_DublorMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
Var
  Hedef : TRect; // RECT olması şart değildi sadece 4 değer saklamak için
  P1, P2: TPoint;
begin
  if Button = mbLeft then
  begin
    GetCursorPos(P1);           // Burası tüm Windows odaklı sonuç verir.
    P2 := ScreenToClient( P1 ); // Burası Formunun iç kısmına odaklı sonuç verir.
    case boolGeri of
    False:
      With Panel_Hedef do
      begin
        Hedef.Left   := Left;
        Hedef.Top    := Top;
        Hedef.Right  := Left + Width;
        Hedef.Bottom := Top  + Height;
      end;
    True:
      begin
        With PageControl1 do
        begin
          Hedef.Left   := Left;
          Hedef.Top    := Top;
          Hedef.Right  := Left + Width;
          Hedef.Bottom := Top  + Height;
        end;
      end;
    end; // case
  // Dublör Panelimizi gizliyoruz...
    Panel_Dublor.Visible := False;

  // Eğer hedef panel üzerinde gelinmişse aktarım gerçekleşir...
    if (P2.X >= Hedef.Left) AND (P2.X <= Hedef.Right  )
    AND(P2.Y >= Hedef.Top ) AND (P2.Y <= Hedef.Bottom )
    then begin
      if NOT boolGeri then
      begin
        // Hedef Image'e Kaynağı aktarıyoruz...
        Image_Hedef.Picture.Assign( Image_Orj.Picture );
        Image_Hedef.AutoSize := True;
        // Taşıdığımızı temizliyoruz..
        Image_Orj.Picture.Graphic := Nil;
      end else
      begin
        // Kanak Image'e Hedeften geri aktarıyoruz...
        Image_Orj.Picture.Assign( Image_Hedef.Picture );
        Image_Orj.AutoSize := True;
        // Taşıdığımızı temizliyoruz..
        Image_Hedef.Picture.Graphic := Nil;
      end;
    end;
    Image_Orj.Visible := True;
    boolTasiyoruz     := False;
  end;
end;

[mss]

Mrmarman tam aradığım birşeydi çok teşekkür ederim.

[mrmarman]

Memnun oldum.
- Bir tecrübemi paylaşmak isterim. Kafanı karıştırmak istemediğimden elimden geldiğince basite indirgemek istediğimden kodları böyle verdim.

- Ardışık olarak sıkça böyle taşıma işlemi yapıyorsan TImage'ın Assign komutu memoryleak sorunu yaşatıyor. Yani hafızadan bir türlü tümüyle temizlenemiyor.

- Bilgisayarın güçlü ise anlaşılmayabilir ama dilersen mevcut kod ile 5 .. 10 defa bir sağa bir sola aralık vermeden tekrar tekrar taşımayı dene. Bir süre sonra program hafızada şişecektir. Out Of Memory vermesi muhtemeldir.

- Bunun da basit bir çözümü var. Assign ile aktardığın yerleri bir TBitmap üzerinden eşitleyerek çözersen TBitmap'i free ettiğin anda eşitlik ve hafıza bloğu temizleniyor.

Mecut kod içerisinden bir örnek ile anlatayım:

Kod: Tümünü seç

Var
  xBitmap : TBitmap;
begin
...
...
  // Şimdi orjinal Image'i Panel üzerindeki dublorüne kopyalıyoruz...

  // TImage Assign olayında ardışık olarak sık yapılıyorsa MemoryLeak oluşuyor.
  // Bunun önüne geçmek için Assign yerine dinamik eşitlik kullanıyoruz...
  // Böylece hafızadan tümüyle FREE edildiğine emin olabiliyoruz...
    xBitmap := TBitmap.Create;
      xBitmap.Width  := Image_Orj.Width;
      xBitmap.Height := Image_Orj.Height;
      xBitmap.Canvas.Draw(0, 0, TImage(Sender).Picture.Graphic);
      Image_Dublor.Picture.Bitmap := xBitmap;
    xBitmap.Free;
  //Image_Dublor.Picture.Assign( TImage(Sender).Picture ); // MemoryLeak sorunu yaşatıyor...
    Image_Dublor.AutoSize := True;
    Image_Dublor.Left     := xiMarjinX;
    Image_Dublor.Top      := xiMarjinY;

[thelvaci]

Muharrem bey, hangi Delphi versiyonunda Memory Leak alıyorsunuz ? Ben; XE5 ile aşağıdaki gibi bir kod denedim ve memory leak almadım.

Kod: Tümünü seç

procedure TForm2.Button1Click(Sender: TObject);
var
  iCounter : Integer;
begin
  for iCounter := Low(Word) to High(Word) do
    Image1.Picture.Assign( Image2.Picture );

  ShowMessage('Completed!');
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutdown := true;
end;

[mrmarman]

Tuğrul bey,

Delphi 2007 ile derliyorum. Hatta verdiğim linkte projeyle birlikte derlenmişi de var. Test edebilirsiniz.

Daha önce vektörel resim bankası projelendirmiştim. Oradan kalma bir tecrübeyle söyledim. Akşam XE7 ile de derler bakarım belki de çözmüşlerdir.

[mrmarman]

Tekrar merhaba.

- Hakikaten Delphi XE7 ile aynı kodu derledim. Sorun çıkarmadı. Ancak Delphi 2007 ile hiçbir kod değişikliği yapmadan derledim, 6-7 kere sağdan sola ve soldan sağa aktarım yaptığımda Out Of memory verdirmeyi eskisi gibi yine -malesef- başardım...

Aşağıdaki kod aynen önce Delphi 2007 ardından da Delphi XE7 ile derleniğ çalıştırıldı.
Kaynak kodları içeren temrin proje bu mesajın ekinde...
Her işlem sonrası ekranda hafıza kullanımını raporladım. Delphi sürümlerinde bu farklılığı gözlemleyebilirsiniz. Delphi XE7'de öyle ki bu sorun giderilmiş...

Kod: Tümünü seç

procedure TForm1.BitBtn1Click(Sender: TObject);
  function MemoryUsed: cardinal;
  var
      st: TMemoryManagerState;
      sb: TSmallBlockTypeState;
  begin
      GetMemoryManagerState(st);
      result := st.TotalAllocatedMediumBlockSize + st.TotalAllocatedLargeBlockSize;
      for sb in st.SmallBlockTypeStates do begin
          result := result + sb.UseableBlockSize * sb.AllocatedBlockCount;
      end;
  end;
begin
  Image2.Picture.Assign( Image1.Picture );
  Image1.Picture := Nil;
  Application.ProcessMessages;
  Image1.Picture.Assign( Image2.Picture );
  Image2.Picture := Nil;
  Memo1.Lines.Add( Format('Adım: %d / Kullanılan Memory = %s', [ Memo1.Lines.Count + 1,  FormatFloat( '#,###0',MemoryUsed() )]) );
end;

Ayrıca Delphi Versiyonunu da başlangıca dahil ettim ki, hangi sürümle çalıştırırsanız Form Caption'da görünebilsin.

Kod: Tümünü seç

function DelphiVersion : String;
Var
  strSurum : String;
begin
  strSurum := '';
  case Trunc( CompilerVersion * 10 ) of
     280: strSurum := 'XE7';
     270: strSurum := 'XE6';
     265: strSurum := 'AppMethod';
     260: strSurum := 'XE5';
     250: strSurum := 'XE4';
     240: strSurum := 'XE3';
     230: strSurum := 'XE2';
     220: strSurum := 'XE';
     210: strSurum := '2010';
     200: strSurum := '2009';
     190: strSurum := '2007 .NET';
     185: strSurum := '2007';
     180: strSurum := '2006';
     170: strSurum := '2005';
     160: strSurum := '8 .NET';
     150: strSurum := '7';
     140: strSurum := '6';
     130: strSurum := '5';
     120: strSurum := '4';
     100: strSurum := '3';
      90: strSurum := '2';
      80: strSurum := '1';
  else
    Result := 'Delphi''nin bilmediğim bir sürümü...'
  end;
  if strSurum <> '' then Result := 'Compiler Version : Delphi ' + strSurum;
end;

[mrmarman]

Bir şey aklıma geldi, denemeden edemedim. Garip bir sonuca ulaştım...



Formun ekran kopyasından görebileceğiniz gibi, en az 1 kere Bitmap hareketi yaparsam, Assign işlemindeki problem kendiliğinden ortadan kalkıyor.
- Resimdeki (1) ve (2) nolu adımlar BitBtn1'deki bulunan Assign ile yapıldı. Memory'deki genişlemeye dikkat edin.
- (3) nolu adım ile bir defalığına BitBtn2'deki TBitmap aktarması ile yapıldı. Memory bir anda kendini topladı.
- (4) ve (5) nolu adımlar yeniden Assign ile yapıldı ama eskisi gibi sorun yaratmadı...

Kod: Tümünü seç

function MemoryUsed: cardinal;
var
    st: TMemoryManagerState;
    sb: TSmallBlockTypeState;
begin
    GetMemoryManagerState(st);
    result := st.TotalAllocatedMediumBlockSize + st.TotalAllocatedLargeBlockSize;
    for sb in st.SmallBlockTypeStates do begin
        result := result + sb.UseableBlockSize * sb.AllocatedBlockCount;
    end;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
  Image2.Picture.Assign( Image1.Picture );
  Image1.Picture := Nil;
  Application.ProcessMessages;
  Image1.Picture.Assign( Image2.Picture );
  Image2.Picture := Nil;
  Memo1.Lines.Add( Format('Adım: %d / Kullanılan Memory = %s', [ Memo1.Lines.Count + 1,  FormatFloat( '#,###0',MemoryUsed() )]) );
end;

procedure TForm1.BitBtn2Click(Sender: TObject);
  procedure Aktar( Image1, Image2 : TImage );
  Var
    xBitmap : TBitmap;
  begin
    xBitmap := TBitmap.Create;
      xBitmap.Width  := Image1.Width;
      xBitmap.Height := Image1.Height;
      xBitmap.Canvas.Draw(0, 0, Image1.Picture.Graphic);
      Image2.Picture.Bitmap := xBitmap;
    xBitmap.Free;
  end;
begin
  Aktar( Image1, Image2 );
  //Image2.Picture.Assign( Image1.Picture );
  Image1.Picture := Nil;
  Application.ProcessMessages;
  Aktar( Image2, Image1 );
  //Image1.Picture.Assign( Image2.Picture );
  Image2.Picture := Nil;
  Memo1.Lines.Add( Format('Adım: %d / Kullanılan Memory = %s', [ Memo1.Lines.Count + 1,  FormatFloat( '#,###0',MemoryUsed() )]) );
end;

[mrmarman]

Nihai olarak Delphi 2007 'deki garip tutumu sunuyorum. Tekrar altını çiziyorum, Delphi XE7'de böyle bir sorun yok.

Form Create olayına bir defalığına aşağıdaki kodu yazarsanız eski kodları değiştirmenize kesinlikle gerek kalmıyor.
Yaptığı iş boş çukur açıp içini doldurmak deriz ya öyle bir şey. Memory sorunu ortadan kalkıyor. Orjinal image içindeki bir Bitmap'e alıp, onu eşitliyoruz oluyor bitiyor.

Kod: Tümünü seç

procedure TForm1.FormCreate(Sender: TObject);
Var
  xBitmap : TBitmap;
begin
  xBitmap := TBitmap.Create;
  With xBitmap.Create do
  begin
    Width := Image_Orj.Width;
    Height:= Image_Orj.Height;
    Canvas.Draw(0, 0, Image_Orj.Picture.Graphic);
    Image_Orj.Picture.Bitmap := xBitmap;
    Free;
  end;
end;

[thelvaci]

Ellerinize sağlık, maalesef Delphi'nin kodlarında arada sırada bu tarz ciddi bug'lar olabiliyor. Pek kısa zaman dilimlerinde de düzeltmiyorlar. Bahsettiğiniz sürüm zamanlarında TMemoryStream'de ciddi leak'ler vardı ve bunu rapor etmiştim, ama rapor Fixed statüsüne alınmamış. Lâkin sorun ortadan kalkmış, sanırım sorunları ortadan kaldırdıktan sonra raporları da güncellemeye zamanları olmuyor. Bahse konu leak; memorystream'deki leak'ten kaynaklanıyor olabilir, debug edip takip etmek lazım.

Rapor linkleri aşağıda bakmak isteyen olur ise;
TMemoryStream.Write bug(Invalid parameter value)
TParameter.LoadFromStream

[mrmarman]

Bir hata da Type içerisinde String tanımlıysa

dışarıdayım syntax hatalarım olabilir spontan yazıyorum.

Örneğin

Kod: Tümünü seç

   Type tDeneme = Record
      a,b,c,d,e,f,g,h : string;
   end;

olsun, bunu kullanırken. aşağıdaki şekilde statik eşitlikte sorun yok...

Kod: Tümünü seç

var
  Test : tDeneme;
  i : Integer;
begin
  for i := 0 to 1000 do 
  begin
    zeromemory( @Test , sizeof(Test ) ); // veya fillchar( test, sizeof(test), 0 ); // fark etmiyor
    With Test do 
    begin
      a := 'ARMAN';  
      b := 'ARMAN';
      c := 'ARMAN';
      d := 'ARMAN';
      e := 'ARMAN';
      f := 'ARMAN';
      g := 'ARMAN';
      h := 'ARMAN';
    end;
  end;
end;

ama dinamik bir eşitlik yani ürünü string olan bir fonksiyon, örneğin copy() ile

Kod: Tümünü seç

var
  Test : tDeneme;
  i : Integer;
begin
  for i := 0 to 1000 do 
  begin
    zeromemory( @Test , sizeof(Test ) ); // veya fillchar( test, sizeof(test), 0 ); // fark etmiyor her ikisinde de sorunlu
    With Test do 
    begin
      a := copy('ARMAN', 1, 5);  
      b := copy('ARMAN', 1, 5);
      c := copy('ARMAN', 1, 5);
      d := copy('ARMAN', 1, 5);
      e := copy('ARMAN', 1, 5);
      f := copy('ARMAN', 1, 5);
      g := copy('ARMAN', 1, 5);
      h := copy('ARMAN', 1, 5);
    end;
  end;
end;

dediğimizde işler değişiyor.. ZeroMemory de FillChar da kar etmiyor. İçerik temizleniyor tamam ama hafızadan temizlenmiyor bilakis şişiyor.

Çözüm olarak her defasında Type tanımı altına bir default değer tanımlamak ile hallediyorum.

Kod: Tümünü seç

Const
  DenemeVarsayilan : tDeneme = ();

sonra da ZeroMemory veya FillChar yerine

Kod: Tümünü seç

  Test := DenemeVarsayilan;

kullanırsam sorun ortadan kalkıyor. Bu da ek bir bilgi olarak bu başlıkta kalsın.

[thelvaci]

İlginç. String'ler referans sayımlıdırlar ve nerede tanımlı olurlarsa olsunlar, referansları sıfıra eriştiğinde hafızadan silinmeleri gerekir. Normalde; sizin record'un kullandığınız scope'tan çıkmasına müteakiben; FinalizeRecord'un çağrılıyor olması gerekirdi. Çağrılıp çağrılmadığını gözlemleyebilir misiniz size zahmet ?

[mrmarman]

Sahadayım, delphi başına geçtiğimde bakabilirim. Siz de bu örneği yukarıdaki gibi timer içinden memory okutmayı deneyin isterseniz

[thelvaci]

Eğer buna rağmen hâla record'un memory leak'e neden olduğunu gözlemliyorsanız, bu durumda; FillChar yada ZeroMemory kullanmadan önce; Finalize kullanıp sonuçlarını bizimle paylaşırmısınız.

[thelvaci]

Aşağıdaki gibi bir kodu Delphi XE5 üzerinde denedim ve memory leak ile karşılaştım.

Kod: Tümünü seç

type
  TDeneme = record
    Value1 : String;
    Value2 : String;
    Value3 : String;
    Value4 : String;
  end;

procedure TForm2.Button1Click(Sender: TObject);
var
  Deneme    : TDeneme;
  iCounter  : Integer;

  wHour,
  wMinute,
  wSecond,
  wMilliSecond : Word;
begin
  for iCounter := Low(Word) to High(Word) do
  begin
    FillChar(Deneme, SizeOf(TDeneme), 0);

    DecodeTime(Now, wHour, wMinute, wSecond, wMilliSecond);

    Deneme.Value1 := InttoStr(wHour);
    Deneme.Value2 := InttoStr(wMinute);
    Deneme.Value3 := InttoStr(wSecond);
    Deneme.Value4 := InttoStr(wMilliSecond);
  end;

  ShowMessage('Completed.!');
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutdown := true;
end;

Ancak; döngü içinde FillChar'dan hemen önce; Finalize(Deneme) yazar iseniz memory leak ile karşılaşmayacaksınız.