TCustomControl neden TRANSPARENT olmuyor?

[uparlayan]

Merhaba, Çözemediğim bir konu var, yardım ederseniz sevinirim;

TCustomControl soyundan türettiğim bir nesnede çizmediğim kısımların transparan kalmasını (yani nesnenin altındaki resim ve şekillerin bozulmamasını), nesneyi ekranda taşırken altındaki görüntünün sağa sola kaymamasını nasıl sağlayabilirim? Sorun, nesneyi ekranda bir yerden bir yere sürüklerken altındaki resmin bir kısmının nesne içinde sabit kalması.

Aşağıdaki ekran görüntüsü sanırım derdimi daha iyi anlatmam için yardımcı olacaktır;

Devamında da kaynak kodları veriyorum;

unit CustomKontrol;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, VCL.Controls, Forms, ExtCtrls;

type
 TAreaSelector = class( TCustomControl )
 private
   FX, FY: Integer;                                                          // Nesne sürüklenirken X ve Y koordinatlarını tutan ara değişken
   FAyar: TPen;
   FMarker: Integer;
   FFont: TFont;
   FMarkerColor: TColor;
   FCrossed: Boolean;
   procedure WMLBUTTONDOWN(var msg:TWMLButtonDown);message WM_LBUTTONDOWN;   // Nesneye fare ile basılı tutulduğunda devreye girer
   procedure WMMOUSEMOVE(var msg:TWMMouseMove);message WM_MOUSEMOVE;         // Nesne sürüklendiğinde devreye girer
   procedure SetAyar(const Value: TPen);
   procedure SetFont(const Value: TFont);
   function SetMarker: Integer;
   procedure SetMarkerColor(const Value: TColor);
   procedure SetCrossed(const Value: Boolean);
 protected
   procedure CreateParams(var params: TCreateParams); override;              // Transparent ayarını yapan metod...
   procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;    // Nesnenin kendi zeminini transparent yapan kısım
   procedure Paint; override;                                                // Şekli çizen metod...
 public
   constructor Create(aOwner: TComponent); override;
   destructor Destroy; override;
   procedure TestPaint;      // test etmek için, silinecek...
   procedure ClearPaint;     // test etmek için, silinecek...
 published
   property Ayar: TPen read FAyar write SetAyar;                             // Bir persistent sınıfa taşınacak...
   property Marker: Integer read SetMarker write FMarker;                    // Bir persistent sınıfa taşınacak...
   property MarkerColor: TColor read FMarkerColor write SetMarkerColor;      // Bir persistent sınıfa taşınacak...
   property Crossed: Boolean read FCrossed write SetCrossed;                 // Bir persistent sınıfa taşınacak...
   property Font: TFont read FFont write SetFont;                            // Bir persistent sınıfa taşınacak...

   property Caption;
   property DoubleBuffered;
   property Top;
   property Left;
   property Width;
   property Height;
   property OnClick;
   property OnDblClick;
   property OnMouseDown;
   property OnMouseEnter;
   property OnMouseLeave;
   property OnMouseMove;
   property OnMouseUp;
   property Visible;
end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents('UpGrafik', [TAreaSelector]);
end;

{ TAreaSelector }

procedure TAreaSelector.ClearPaint;
begin
 // Sadece deneysel, silinecek...
 Canvas.Lock;
 try
   with  Canvas  do begin
         Refresh;
         Pen.Width := 0;
         Brush.Style := bsClear;
         Brush.Color := clBtnFace;
         Rectangle(0, 0, ClientWidth, ClientHeight);
   end;
 finally
   Canvas.Unlock;
 end;
end;

constructor TAreaSelector.Create(aOwner: TComponent);
begin
 inherited Create(aOwner);
 ControlStyle := ControlStyle - [csOpaque];
 FAyar := TPen.Create;
 FFont := TFont.Create;
 FMarker := 16;
 FMarkerColor := clLime;
 FAyar.Color := clMaroon;
 FAyar.Width := 2;
 DoubleBuffered := FALSE;
end;

destructor TAreaSelector.Destroy;
begin
 FreeAndNil(FFont);
 FreeAndNil(FAyar);
 inherited Destroy;
end;

procedure TAreaSelector.WMLBUTTONDOWN(var msg: TWMLButtonDown);
begin
 inherited;
 FX := msg.XPos;
 FY := msg.YPos;
end;

procedure TAreaSelector.WMMOUSEMOVE(var msg: TWMMouseMove);
begin
 inherited; // ok
 if (ssLeft in KeysToShiftState(msg.Keys)) then begin
     Left := Left + msg.XPos - FX; //  ok
     Top  := Top  + msg.YPos - FY; //  ok
     PerformEraseBackground(Self, Self.Handle);
     //Update;
     //Refresh;
     //Invalidate; // ok
 end;
end;

procedure TAreaSelector.TestPaint;
begin
 // Sadece deneysel, silinecek...
 Paint;
end;

procedure TAreaSelector.SetAyar(const Value: TPen);
begin
 FAyar := Value;
end;

procedure TAreaSelector.SetCrossed(const Value: Boolean);
begin
 FCrossed := Value;
end;

procedure TAreaSelector.SetFont(const Value: TFont);
begin
 FFont := Value;
end;

function TAreaSelector.SetMarker: Integer;
begin
 Result := FMarker;
end;

procedure TAreaSelector.setMarkerColor(const Value: TColor);
begin
 FMarkerColor := Value;
end;

procedure TAreaSelector.CreateParams(var Params: TCreateParams);
begin
 params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT or WS_EX_TOPMOST ;  // ok
 inherited CreateParams(params);                                           // ok
end;

procedure TAreaSelector.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
 SetBkMode (msg.DC, TRANSPARENT);  // ok
 msg.Result := 1;                  // ok  // Bu satır ile Windows'a, bizim nesnenin altındaki her ne ise onu silmemesini söylüyoruz.
end;

procedure TAreaSelector.Paint;
var
 Bolge: HRGN;
 _Top,_Left,_Right,_Bottom, CW, CH, TW, TH, M2: Integer; // Çizim alanına özgü değişkenler
begin
 //  https://docs.microsoft.com/tr-tr/previou...1(v=vs.60)
 Bolge := CreateRectRgn( 0, 0, ClientWidth, ClientHeight);
 SelectClipRgn(Canvas.Handle, Bolge);
 Canvas.Lock;
 try
   with  Canvas  do begin
         // Çizim alanının ölçülerinin belirlenmesi
         CW := ClientWidth;
         CH := ClientHeight;
         M2 := FMarker div 2;
         _Top    :=  0 + M2;
         _Left   :=  0 + M2;
         _Bottom :=  CH - M2;
         _Right  :=  CW - M2;

         {
         Brush.Style := bsClear;
         Brush.Color := clBtnFace;
         Rectangle(_Left, _Top, _Right, _Bottom);
         }

         // Kenar çizgileri hazırlığı
         Pen := FAyar;

         // kernar çizgilerinin çizilmesi
         MoveTo(_Left, _Top);
         LineTo(_Right, _Top);
         LineTo(_Right, _Bottom);
         LineTo(_Left, _Bottom);
         LineTo(_Left, _Top);

         if (FCrossed = True) then begin
             LineTo(_Right, _Bottom);
             MoveTo(_Right, _Top);
             LineTo(_Left, _Bottom);
         end;

         // Köşelerdeki Yeşil kutucuklara hazırlık
         Pen.Width   := 1;
         Pen.Color   := FMarkerColor;
         Brush.Color := FMarkerColor;

         // Köşe kutucuklarının çizimi
         Rectangle(0          , 0           , FMarker    , FMarker     );  //  Sol üst köşe
         Rectangle(_Right - M2, 0           , _Right + M2, FMarker     );  //  Sağ üst köşe
         Rectangle(_Right - M2, _Bottom - M2, _Right + M2, _Bottom + M2);  //  Sağ alt köşe
         Rectangle(0          , _Bottom - M2, FMarker    , _Bottom + M2);  //  Sol alt köşe

         // Kutunun ortasındaki metnin yazılışı
         Brush.Style := bsClear;
         Font := Self.FFont;

         TW := TextWidth(Self.Caption) div 2;
         TH := TextHeight(Self.Caption) div 2;

         TextOut( (CW div 2) - TW, (CH div 2) - TH, Self.Caption);
   end;
 finally
   Canvas.Unlock;
 end;
 SelectClipRgn(Canvas.Handle, HRGN(nil));
 DeleteObject(Bolge);
end;

end.

[narkotik]

Şuan için deneme şansım yok fakat şu linkte sanki aradığınız var gibi
https://www.experts-exchange.com/questio...ntrol.html

[uparlayan]

İlginiz için teşekkür ederim fakat Region kullanımından özellikle kaçınmam gerekiyor çünkü şeklin içinde fakat Region'un dışında kalan kısımlara, yani bu nesnenin altında kalacak olan diğer bileşenlere tıklanmasını da önlemem gerekiyor.

---

Öğrenme sürecinde olduğum için bu konuda içime sinmeyen birçok alt başlık var, bunları zamanla buradan sormaya devam edeceğim.

procedure TAreaSelector.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(params);
  params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT or WS_EX_TOPMOST;
end;

Nesnenin CreateParams metodunu yukarıdaki gibi düzelttikten ve Aşağıdaki ekran görüntüsünde sarı renk ile vurgulanan kısma bir dörtgen çizdirirken bunun PEN.MODE ayarını pmMask olarak ayarladıktan sonra kısmen de olsa sorunumu çözmüş oldum fakat şu iki sorun rahatsız edici, bunları nasıl çözeriz?

1. Sürüklerken bir titreme oluşuyor,
   
2. TWinControl ve torunları üzerine fare imlecini getirdiğimde benim nesne (TCustomControl'den türettiğim halde) diğer nesnenin altına kaçıyor veya TWinControl torunu nesne kendisini benim nesnenin üzerine yeniden çiziyor...
   

[mustafasivlin]

Merhaba,

Titreme olayına çözmek için DoubleBuffered := True olarak seçip denediniz mi acaba?

[engerex]

Titremeyi DoubleBuffered aktif yapılarak çözülebilir. RAM kullanımı artacaktır.

[uparlayan]

(03-04-2018, Saat: 13:18)mustafasivlin Adlı Kullanıcıdan Alıntı: Merhaba,

Titreme olayına çözmek için DoubleBuffered := True olarak seçip denediniz mi acaba?

(03-04-2018, Saat: 13:22)engerex Adlı Kullanıcıdan Alıntı: Titremeyi DoubleBuffered aktif yapılarak çözülebilir. RAM kullanımı artacaktır.

Ben de o şekilde sanıyordum fakat DoubleBuffered := True yaptığımda aşağıdaki gibi bir durum oluşuyor;



Kodun son durumu şöyle;

unit CustomKontrol;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, VCL.Controls, Forms, ExtCtrls;

type
  TAreaSelector = class( TCustomControl )
  private
    FX, FY: Integer;                                                          // Nesne sürüklenirken X ve Y koordinatlarını tutan ara değişken
    FAyar: TPen;
    FMarker: Integer;
    FFont: TFont;
    FMarkerColor: TColor;
    FCrossed: Boolean;
    FZemin: TBrush;
    procedure WMLBUTTONDOWN(var msg:TWMLButtonDown);message WM_LBUTTONDOWN;   // Nesneye fare ile basılı tutulduğunda devreye girer
    procedure WMMOUSEMOVE(var msg:TWMMouseMove);message WM_MOUSEMOVE;         // Nesne sürüklendiğinde devreye girer
    procedure SetAyar(const Value: TPen);
    procedure SetFont(const Value: TFont);
    function SetMarker: Integer;
    procedure SetMarkerColor(const Value: TColor);
    procedure SetCrossed(const Value: Boolean);
    procedure SetZemin(const Value: TBrush);
  protected
    procedure CreateParams(var params: TCreateParams); override;              // Transparent ayarını yapan metod...
    procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;    // Nesnenin kendi zeminini transparent yapan kısım
    procedure Paint; override;                                                // Şekli çizen metod...
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    procedure TestPaint;      // test etmek için, silinecek...
    procedure ClearPaint;     // test etmek için, silinecek...
    function Vesikalik(const aControl: TControl): TBitmap;                    // Bir TControl'ün ekran görüntüsünü Bitmap olarak verir...
  published
    property Ayar: TPen read FAyar write SetAyar;                             // Bir persistent sınıfa taşınacak...
    property Zemin: TBrush read FZemin write SetZemin;
    property Marker: Integer read SetMarker write FMarker;                    // Bir persistent sınıfa taşınacak...
    property MarkerColor: TColor read FMarkerColor write SetMarkerColor;      // Bir persistent sınıfa taşınacak...
    property Crossed: Boolean read FCrossed write SetCrossed;                 // Bir persistent sınıfa taşınacak...
    property Font: TFont read FFont write SetFont;                            // Bir persistent sınıfa taşınacak...

    property Caption;
    property DoubleBuffered;
    property Top;
    property Left;
    property Width;
    property Height;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property ParentBackground;
    property Visible;
 end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('UpGrafik', [TAreaSelector]);
end;

{ TAreaSelector }

procedure TAreaSelector.ClearPaint;
begin
  // Sadece deneysel, silinecek...
  Canvas.Lock;
  try
    with  Canvas  do begin
          Refresh;
          Pen.Width := 0;
          Brush.Style := bsClear;
          Brush.Color := clBtnFace;
          Rectangle(0, 0, ClientWidth, ClientHeight);
    end;
  finally
    Canvas.Unlock;
  end;
end;

constructor TAreaSelector.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  ControlState := ControlState + [ csCustomPaint, csGlassPaint];
  {
  TControlState = set of (csLButtonDown, csClicked, csPalette,
    csReadingState, csAlignmentNeeded, csFocusing, csCreating,
    csPaintCopy, csCustomPaint, csDestroyingHandle, csDocking,
    csDesignerHide, csPanning, csRecreating, csAligning, csGlassPaint,
    csPrintClient);
  }
  ControlStyle := ControlStyle
                - [ csOpaque ]
                + [ csCaptureMouse ]
                ;
  {
  csAcceptsControls, csCaptureMouse,
  csDesignInteractive, csClickEvents, csFramed, csSetCaption, csOpaque,
  csDoubleClicks, csFixedWidth, csFixedHeight, csNoDesignVisible,
  csReplicatable, csNoStdEvents, csDisplayDragImage, csReflector,
  csActionClient, csMenuEvents, csNeedsBorderPaint, csParentBackground,
  csPannable, csAlignWithMargins, csGestures, csPaintBlackOpaqueOnGlass,
  csOverrideStylePaint
  }
  FAyar             := TPen.Create;
  FFont             := TFont.Create;
  FZemin            := TBrush.Create;
  FMarker           := 16;
  FMarkerColor      := clLime;
  FAyar.Color       := clMaroon;
  FAyar.Width       := 2;
  FZemin.Color      := clSilver;
  FZemin.Style      := bsSolid;
  DoubleBuffered    := FALSE;
  ParentBackground  := TRUE;
end;

destructor TAreaSelector.Destroy;
begin
  FreeAndNil(FZemin);
  FreeAndNil(FFont);
  FreeAndNil(FAyar);
  inherited Destroy;
end;

procedure TAreaSelector.WMLBUTTONDOWN(var msg: TWMLButtonDown);
begin
  inherited;
  FX := msg.XPos;
  FY := msg.YPos;
  Invalidate;
end;

procedure TAreaSelector.WMMOUSEMOVE(var msg: TWMMouseMove);
begin
  inherited; // ok
  if (ssLeft in KeysToShiftState(msg.Keys)) then begin
      Left := Left + msg.XPos - FX; //  ok
      Top  := Top  + msg.YPos - FY; //  ok
      //Invalidate; // ok
  end;
end;

procedure TAreaSelector.TestPaint;
begin
  // Sadece deneysel, silinecek...
  Paint;
end;

function TAreaSelector.Vesikalik(const aControl: TControl): TBitmap;
begin
  Result := TBitmap.Create;
  Result.Width       := aControl.Width;
  Result.Height      := aControl.Height;
  Result.PixelFormat := pfDevice;
  Result.Canvas.Lock;
  try
    aControl.Perform(WM_PAINT, Result.Canvas.Handle, 0);
  finally
    Result.Canvas.Unlock;
  end;
end;

procedure TAreaSelector.SetAyar(const Value: TPen);
begin
  FAyar := Value;
end;

procedure TAreaSelector.SetCrossed(const Value: Boolean);
begin
  FCrossed := Value;
end;

procedure TAreaSelector.SetFont(const Value: TFont);
begin
  FFont := Value;
end;

function TAreaSelector.SetMarker: Integer;
begin
  Result := FMarker;
end;

procedure TAreaSelector.setMarkerColor(const Value: TColor);
begin
  FMarkerColor := Value;
end;

procedure TAreaSelector.SetZemin(const Value: TBrush);
begin
  FZemin := Value;
end;

procedure TAreaSelector.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(params);                                           // ok
  params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT or WS_EX_TOPMOST ;  // ok
end;

procedure TAreaSelector.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
  SetBkMode (msg.DC, TRANSPARENT);  // ok
  msg.Result := 1;                  // ok  // Bu satır ile Windows'a, bizim nesnenin altındaki her ne ise onu silmemesini söylüyoruz.
end;

procedure TAreaSelector.Paint;
var
  Bolge: HRGN;
  _Top,_Left,_Right,_Bottom, CW, CH, TW, TH, M2: Integer; // Çizim alanına özgü değişkenler
begin
  //  https://docs.microsoft.com/tr-tr/previou...1(v=vs.60)

  //SetWindowRgn(Handle, 0, False); // Bu, pencere bölgesini temizler...

  Bolge := CreateRectRgn( 0, 0, ClientWidth, ClientHeight);
  SelectClipRgn(Canvas.Handle, Bolge);
  Canvas.Lock;
  try
    with  Canvas  do begin
          // Çizim alanının ölçülerinin belirlenmesi
          CW := ClientWidth;
          CH := ClientHeight;
          M2 := FMarker div 2;
          _Top    :=  0 + M2;
          _Left   :=  0 + M2;
          _Bottom :=  CH - M2;
          _Right  :=  CW - M2;

          Pen.Width   := 1;
          Pen.Color   := FZemin.Color;
          Pen.Mode    := pmMask;
          Brush.Style := bsSolid;
          Brush.Color := FZemin.Color;
          Rectangle(0, 0, CW, CH);
          Pen.Mode    := pmCopy;

          // Kenar çizgileri hazırlığı
          Pen := FAyar;

          // kernar çizgilerinin çizilmesi
          MoveTo(_Left, _Top);
          LineTo(_Right, _Top);
          LineTo(_Right, _Bottom);
          LineTo(_Left, _Bottom);
          LineTo(_Left, _Top);

          if (FCrossed = True) then begin
              LineTo(_Right, _Bottom);
              MoveTo(_Right, _Top);
              LineTo(_Left, _Bottom);
          end;

          // Köşelerdeki Yeşil kutucuklara hazırlık
          Pen.Width   := 1;
          Pen.Color   := FMarkerColor;
          Brush.Color := FMarkerColor;

          // Köşe kutucuklarının çizimi
          Rectangle(0          , 0           , FMarker    , FMarker     );  //  Sol üst köşe
          Rectangle(_Right - M2, 0           , _Right + M2, FMarker     );  //  Sağ üst köşe
          Rectangle(_Right - M2, _Bottom - M2, _Right + M2, _Bottom + M2);  //  Sağ alt köşe
          Rectangle(0          , _Bottom - M2, FMarker    , _Bottom + M2);  //  Sol alt köşe

          // Kutunun ortasındaki metnin yazılışı
          Brush.Style := bsSolid;
          Brush.Color := FMarkerColor;
          Font := Self.FFont;

          TW := TextWidth(Self.Caption) div 2;
          TH := TextHeight(Self.Caption) div 2;

          TextOut( (CW div 2) - TW, (CH div 2) - TH, Self.Caption);
    end;
  finally
    Canvas.Unlock;
  end;
  SelectClipRgn(Canvas.Handle, HRGN(nil));
  DeleteObject(Bolge);
end;

end.

SÜRÜKLEME TESTİ İÇİN KULLANDIĞIM KOD İSE AŞAĞIDADIR;

implementation

{$R *.dfm}

procedure TForm1.AreaSelector_MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); // nesnenin OnMouseMove olayı
var
  XX: TAreaSelector;
begin
  XX := TAreaSelector(Sender);
  XX.Invalidate;
  Caption := XX.Top.ToString + ' x ' + XX.Left.ToString;
end;

[mustafasivlin]

TPanel üzerinden türetilmiş bir bileşen oluştursanız ve istediğiniz özellikleri ona ekleseniz işinizi görür mü? Transparent Panel için çeşitli örnekler var. Şuradan bakabilirsiniz : http://delphidabbler.com/tips/210

[uparlayan]

(03-04-2018, Saat: 13:59)mustafasivlin Adlı Kullanıcıdan Alıntı: TPanel üzerinden türetilmiş bir bileşen oluştursanız ve istediğiniz özellikleri ona ekleseniz işinizi görür mü? Transparent Panel için çeşitli örnekler var. Şuradan bakabilirsiniz : http://delphidabbler.com/tips/210

Teşekkürler, lakin;

Verdiğiniz linki inceledim, türetilmiş bir bileşen üzerinden bu işlemi yaptığımda temelde 3 problem ortaya çıkyor;

• İhtiyacım olmayan ek özellikler bileşene eklemlenmiş oluyor
  
• Ata sınıftan türettiğim bir nesneyi fare ile form üzerinde taşıdığımda yavaşlama meydana geliyor, bunun sebebi muhtemelen ata sınıfın bu durum için kendisinde mevcut olan kodlar ve kontroller devreye giriyor olabilir.
  
• Nesnenin altında kalan kısmın önce resmini bir bitmap'a çekiyor, sonra Canvas'a bu bitmapı yamayıp üzerine Paint ile çizim yapıyor (Sürüklerken meydana gelen yavaşlamaya bu da sebep oluyordur muhtemelen)
  

Ben verdiğiniz linkte "Answer 2" başlığı altındaki yöntemi kullanarak hızlı bir deneme yaptığımda yukarıdaki problemlerle karşılaştım;