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;
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.
YouTube Delphi Tips
"Yaşlanarak değil, yaşayarak tecrübe kazanılır. Zaman insanları değil, armutları olgunlaştırır" Peyami Safa
"Yaşlanarak değil, yaşayarak tecrübe kazanılır. Zaman insanları değil, armutları olgunlaştırır" Peyami Safa