Görsel Komponent Yapımı

[qamyoncu]

Merhabalar;

Bir Tİmage ve TEdit ve ya TLabel komponentlerini birleştirmek istiyorum.. Frame işime yaramaz malesef. Yardımcı olacak arkadaşlara teşekkürler..

[qamyoncu]

Arkadaşlar gerçekten acil yardıma ihtiyacım var..

Kaynak bulamadım sıfırdan görsel komponent yapımı ile ilgili, hep görsel olmayan komponent örnekleri var.

TImage nesnesinden türemiş bir image nesnesinin altında TLabel nesnesinden türemiş bir Label bulundurmayı amaçlıyorum. Komponentin adını TBImage olsa; BImage1.Caption:='Merhaba' dediğimde label nesnesinde bu gözükmeli.. :/ Delphi'nin kendi komponentlerini inceledim ama bulamadım böyle bir örnek veyahut anlayamadım. Yardımlarınızı bekliyorum, sağ olun:)

[uparlayan]

Merhaba, aşağıdaki sayfada yapmak istediğine bezer bir bileşen hakkında bilgi verilmiş, eğer iyi incelersen amacına ulaşırsın

http://www.kavramca.com/index.php?k=31&t=Upeditbutton

saygılar

[qamyoncu]

Kaynağı iyice inceledim ve teşekkürler ederim ilginiz için hocam; ancak 'Access Violation 000000000' hatası alıyorum sürekli ve delphinin kendi source kodlarındada sorunlar yaratıyor.

Yaptığım şudur:

Kod: Tümünü seç

TBImage = class(TGraphicControl)
private
...
FFImage : TImage;
...
procedure GetFFImage(const Value: TPicture);
...
...
property PictureAlt: TPicture write GetFFImage;
...
...
constructor TBImage.Create(AOwner: TComponent);
begin
...
...
FFImage:= TImage.Create(AOwner);
with FFImage do
begin
Picture:=nil;
Left:=0;
Top:=0;
Height:=97;
Width:=87;
end;
end;
...
...
procedure GetFFImage(const Value: TPicture);
begin
if Value<>FFImage.Picture then
FFImage.Picture:=Value;
end;

Yapmak istediğim:
TImage nesnesinin kodlarını aynen aldım ve ismini TBImage yaptım. Alt kısmına TextOut fonksiyonu ile bir Caption bölümü oluşturdum. TLabel kullanmadım. Şimdi ise Bu nesnenin arkaplanı için bir adet daha Picture gerekiyor. Bunun için TImage kullandım yukarıdaki gibi ancak komponenti kendi programıma ekleyip PictureAlt Property'sinde değişiklik yaptığım anda 'Access Violation 00000..' hatası alıyorum ve bir daha komponente tıklayamıyorum. Sorunumu bulamadım, eğer gerekirse tam kodları da atabilirim. Ancak lazım olan kısımlar bunlardır. Teşekkürler..

[Lost Soul]

constructor da

Kod: Tümünü seç

FFImage :=Timage.create
inherited create;
 

destructor da ise

Kod: Tümünü seç

FFImage.Free;
Inherited Destroy;

yazdınız mı.

[qamyoncu]

Dediklerinizi (Yani sadece inherited kısımlarını) yazdığım zaman formuma TBImage nesnesi koyduğum an delphi kendini kapatıyor:/ Anlayamadım..
Buyrun tam kod:

Kod: Tümünü seç

unit BImage;

interface

uses Messages, Windows, SysUtils, Classes,
  Controls, Forms, Menus, Graphics, StdCtrls, Consts, StrUtils, ExtCtrls;


type
  TCinsiyet = (cnKiz , cnErkek);
  TBImage = class(TGraphicControl)
private
    FPicture: TPicture;
    FFImage : TImage;
    FOnProgress: TProgressEvent;
    FStretch: Boolean;
    FCenter: Boolean;
    FEtiket: String;
    FIncrementalDisplay: Boolean;
    FTransparent: Boolean;
    FDrawing: Boolean;
    FProportional: Boolean;
    FCinsiyet: TCinsiyet;
    FNesil: Integer;
    FEbeveynNo: Integer;
    FDedeNo: Integer;
    FNo: Integer;
    function GetCanvas: TCanvas;
    procedure PictureChanged(Sender: TObject);
    procedure SetCenter(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure SetStretch(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure SetProportional(Value: Boolean);
    procedure GetNesil(const Value: Integer);
    procedure GetEbeveynNo(const Value: Integer);
    procedure GetNo(const Value: Integer);
    procedure GetLabel(const Value: String);
    procedure GetDedeNo(const Value: integer);
    procedure GetCinsiyet(const Value: TCinsiyet);
    procedure GetFFImage(const Value: TPicture);
  protected
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    function DestRect: TRect;
    function DoPaletteChange: Boolean;
    function GetPalette: HPALETTE; override;
    procedure Paint; override;
    procedure Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TCanvas read GetCanvas;
  published
    property Align;
    property Anchors;
    property AutoSize;
    property Center: Boolean read FCenter write SetCenter default False;
    property Caption: String read FEtiket write GetLabel;
    property PicttureAlt: TPicture write GetFFImage;
    property Constraints;
    property DragCursor;
    property DedeNumarasi: integer read FDedeNo write GetDedeNo;
    property DragKind;
    property DragMode;
    property Enabled;
    property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
    property ParentShowHint;
    property Picture: TPicture read FPicture write SetPicture;
    property PopupMenu;
    property Cinsiyet: TCinsiyet read FCinsiyet write GetCinsiyet;
    property Nesil: Integer read FNesil write GetNesil;
    property EbeveynNo: Integer read FEbeveynNo write GetEbeveynNo;
    property Numara: Integer read FNo write GetNo;
    property Proportional: Boolean read FProportional write SetProportional default false;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
    property OnStartDock;
    property OnStartDrag;
  end;
  { TBImage }


procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Additional', [TBImage]);
end;

constructor TBImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  FPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  FPicture.OnProgress := Progress;
  FFImage :=Timage.create(Self);
  with FFImage do
  begin
  Picture:=nil;
  Left:=0;
  Top:=0;
  Height:=97;
  Width:=87;
  end;
  Height := 97;
  Width := 87;
  GetLabel(FEtiket);
end;

destructor TBImage.Destroy;
begin
  FPicture.Free;
  FFimage.Free;
  inherited Destroy;
end;

function TBImage.GetPalette: HPALETTE;
begin
  Result := 0;
  if FPicture.Graphic <> nil then
	Result := FPicture.Graphic.Palette;
end;

function TBImage.DestRect: TRect;
var
  w, h, cw, ch: Integer;
  xyaspect: Double;
begin
  w := Picture.Width;
  h := Picture.Height;
  cw := ClientWidth;
  ch := ClientHeight;
  if Stretch or (Proportional and ((w > cw) or (h > ch))) then
  begin
	if Proportional and (w > 0) and (h > 0) then
	begin
      xyaspect := w / h;
      if w > h then
      begin
        w := cw;
        h := Trunc(cw / xyaspect);
        if h > ch then  // woops, too big
        begin
          h := ch;
          w := Trunc(ch * xyaspect);
        end;
      end
      else
      begin
        h := ch;
        w := Trunc(ch * xyaspect);
        if w > cw then  // woops, too big
        begin
          w := cw;
          h := Trunc(cw / xyaspect);
        end;
      end;
    end
    else
    begin
      w := cw;
      h := ch;
    end;
  end;

  with Result do
  begin
    Left := 0;
    Top := 0;
    Right := w;
    Bottom := h;
  end;

  if Center then
	OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);
end;

procedure TBImage.Paint;
var
  Save: Boolean;
begin
  if csDesigning in ComponentState then
	with inherited Canvas do
	begin
	  Pen.Style := psDash;
	  Brush.Style := bsClear;
	  Rectangle(0, 0, Width, Height);
	end;
  Save := FDrawing;
  FDrawing := True;
  try
	with inherited Canvas do
	  StretchDraw(DestRect, Picture.Graphic);
  finally
	FDrawing := Save;
  end;
end;

function TBImage.DoPaletteChange: Boolean;
var
  ParentForm: TCustomForm;
  Tmp: TGraphic;
begin
  Result := False;
  Tmp := Picture.Graphic;
  if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
	(Tmp.PaletteModified) then
  begin
	if (Tmp.Palette = 0) then
	  Tmp.PaletteModified := False
	else
	begin
	  ParentForm := GetParentForm(Self);
	  if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
	  begin
		if FDrawing then
		  ParentForm.Perform(wm_QueryNewPalette, 0, 0)
		else
		  PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
		Result := True;
		Tmp.PaletteModified := False;
	  end;
	end;
  end;
end;

procedure TBImage.Progress(Sender: TObject; Stage: TProgressStage;
  PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  if FIncrementalDisplay and RedrawNow then
  begin
	if DoPaletteChange then Update
	else Paint;
  end;
  if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;

function TBImage.GetCanvas: TCanvas;
var
  Bitmap: TBitmap;
begin
  if Picture.Graphic = nil then
  begin
	Bitmap := TBitmap.Create;
	try
	  Bitmap.Width := Width;
	  Bitmap.Height := Height;
	  Picture.Graphic := Bitmap;
	finally
	  Bitmap.Free;
	end;
  end;
  if Picture.Graphic is TBitmap then
	Result := TBitmap(Picture.Graphic).Canvas
  else
	raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
end;

procedure TBImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
	FCenter := Value;
	PictureChanged(Self);
  end;
end;

procedure TBImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
  GetLabel(FEtiket);
end;

procedure TBImage.SetStretch(Value: Boolean);
begin
  if Value <> FStretch then
  begin
	FStretch := Value;
	PictureChanged(Self);
  end;
end;

procedure TBImage.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
	FTransparent := Value;
	PictureChanged(Self);
  end;
end;

procedure TBImage.SetProportional(Value: Boolean);
begin
  if FProportional <> Value then
  begin
	FProportional := Value;
	PictureChanged(Self);
  end;
end;

procedure TBImage.PictureChanged(Sender: TObject);
var
  G: TGraphic;
  D : TRect;
begin
  if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
	SetBounds(Left, Top, Picture.Width, Picture.Height);
  G := Picture.Graphic;
  if G <> nil then
  begin
	if not ((G is TMetaFile) or (G is TIcon)) then
	  G.Transparent := FTransparent;
        D := DestRect;
	if (not G.Transparent) and (D.Left <= 0) and (D.Top <= 0) and
	   (D.Right >= Width) and (D.Bottom >= Height) then
	  ControlStyle := ControlStyle + [csOpaque]
	else  // picture might not cover entire clientrect
	  ControlStyle := ControlStyle - [csOpaque];
	if DoPaletteChange and FDrawing then Update;
  end
  else ControlStyle := ControlStyle - [csOpaque];
  if not FDrawing then Invalidate;
end;

function TBImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := True;
  if not (csDesigning in ComponentState) or (Picture.Width > 0) and
    (Picture.Height > 0) then
  begin
    if Align in [alNone, alLeft, alRight] then
      NewWidth := Picture.Width;
    if Align in [alNone, alTop, alBottom] then
      NewHeight := Picture.Height;
  end;
end;

procedure TBImage.GetCinsiyet(const Value: TCinsiyet);
begin
  FCinsiyet:=Value;
  GetLabel(FEtiket);
  end;

procedure TBImage.GetNesil(const Value: Integer);
begin
  if FNesil <> Value then
  begin
  FNesil := Value;
  PictureChanged(Self);
  end;
end;

procedure TBImage.GetEbeveynNo(const Value: Integer);
begin
if FEbeveynNo <> Value then
  begin
  FEbeveynNo := Value;
  PictureChanged(Self);
  end;
end;

procedure TBImage.GetNo(const Value: Integer);
begin
if FNo <> Value then
  begin
  FNo := Value;
  PictureChanged(Self);
  end;
end;

procedure TBImage.GetLabel(const Value: String);
begin
    FEtiket:=Value;
    Fpicture.Bitmap.FreeImage;
    if FCinsiyet=cnKiz then
      FPicture.LoadFromFile(GetCurrentDir+'\denemeKiz.bmp');
    if FCinsiyet=cnErkek then
      FPicture.LoadFromFile(GetCurrentDir+'\deneme.bmp');
    PictureChanged(Self);
    Fpicture.Bitmap.Canvas.Font.Color:=clred;
    Fpicture.Bitmap.Canvas.Font.Name:='Comic Sans MS';
    Fpicture.Bitmap.Canvas.Font.Size:=8;
    Fpicture.Bitmap.Canvas.textout(3,Fpicture.Height-18,DupeString(' ',27));
    FPicture.Bitmap.Canvas.TextOut(3+(83-Fpicture.Bitmap.Canvas.TextWidth(Value)) div 2,Fpicture.Height-18,Value);
end;


procedure TBImage.GetDedeNo(const Value: integer);
begin
  if FDedeNo <> Value then
  begin
  FDedeNo := Value;
  PictureChanged(Self);
  end;
end;

procedure TBImage.GetFFImage(const Value: TPicture);
begin
if Value<>FFImage.Picture then
FFImage.Picture:=Value;
end;

end.

Bu durumda komponenti programımı eklediğimde 'Access violation at address 00000000, read of address 00000000' hatası alıyorum.

[sabanakman]

Kodlarını incelemeye pek vaktim olmadı (zaten bunun için yükümlü de değilim ) ama aşağıdaki bağlantılara bir göz atıp incelemekte fayda var.

viewtopic.php?f=2&t=20459&p=117280#p117280

viewtopic.php?p=97629#97629

[qamyoncu]

Hocam, sağ olun; ancak sorunu çözebilmiş değilim. görsel olmayan sınıfları kolaylıkla ekleyebiliyorum ama görsel bir sınıf olan TImage'yi eklerken bir yerleri eksik yaptığım için sorunlar bitmiyor. Hocam kodları incelemek zorunda değilsiniz tabiki, sorumun cevabını herhangi bir .pas dosyasının içine bir timage ekleyerek kolaylıkla verebilirsiniz. Tabii ki bunu yapmakla da yükümlü değilsiniz:) Şimdiden teşekkür ediyorum. Saygılarımla.

[sabanakman]

Zaten 2. link onun için verildi. Biraz aşağıda istediğine paralel örnek kodlar vardı.

Bknz..:viewtopic.php?f=2&t=17009&p=97629#p97629

Bir zamanlar bir bileşen yazmıştım. TImage'ı kopyala yapıştırla alıp bazı eklemeler yapmıştım.

Kod: Tümünü seç

unit Gorsel;

interface

uses Windows, Messages, SysUtils, Classes, Forms, Menus, Graphics, StdCtrls,
  Controls;

type
  TDrawType = (dtNone,dtCenter,dtTile,dtStretch);
  TDrawEvent = procedure(const Canvas:TCanvas) of object;
  //TControlClass = class(TControl);

  TWallPaper = class(TGraphicControl)
  private
    FPicture: TPicture;
    FOnProgress: TProgressEvent;
    FStretch: Boolean;
    FIncrementalDisplay: Boolean;
    FTransparent: Boolean;
    FDrawing: Boolean;
    FDrawType: TDrawType;
    FPictureLeft, FPictureTop:Integer;
    function GetCanvas: TCanvas;
    procedure PictureChanged(Sender: TObject);
    procedure SetPicture(Value: TPicture);
    procedure SetStretch(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure SetDrawType(const Value: TDrawType);
    procedure SetPictureLeft(const Value: Integer);
    procedure SetPictureTop(const Value: Integer);
  protected
    NowDraw:TDrawEvent;
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    function DoPaletteChange: Boolean;
    function GetPalette: HPALETTE; override;
    procedure Paint; override;
    procedure Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
    procedure DrawNone(const Canvas:TCanvas);
    procedure DrawCenter(const Canvas:TCanvas);
    procedure DrawTile(const Canvas:TCanvas);
    procedure DrawStretch(const Canvas:TCanvas);
    procedure SetControlRect(const Control:TControl);
    procedure SetParent(AParent: TWinControl); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure RefreshSize;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    property Canvas: TCanvas read GetCanvas;
  published
    property Align;
    property Anchors;
    property AutoSize;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property DrawType:TDrawType read FDrawType write SetDrawType;
    property Enabled;
    property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
    property ParentShowHint;
    property Picture: TPicture read FPicture write SetPicture;
    property PictureLeft:Integer read FPictureLeft write SetPictureLeft;
    property PictureTop:Integer read FPictureTop write SetPictureTop;
    property PopupMenu;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
    property OnStartDock;
    property OnStartDrag;
  end;

implementation

uses Consts;

{ TWallPaper }

constructor TWallPaper.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  FPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  FPicture.OnProgress := Progress;
  DrawType := dtStretch;
  Anchors:= [akLeft,akTop,akRight,akBottom];
  //Height := 105; Width := 105;
end;

destructor TWallPaper.Destroy;
begin
  FPicture.Free;
  inherited Destroy;
end;

procedure TWallPaper.RefreshSize;
begin
  SetControlRect(Parent);
end;

procedure TWallPaper.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  {if TControlClass(Self).CheckNewSize(AWidth, AHeight) and
    ((ALeft <> FLeft) or (ATop <> FTop) or
    (AWidth <> FWidth) or (AHeight <> FHeight)) then
  begin
    InvalidateControl(Visible, False);
    FLeft := ALeft;
    FTop := ATop;
    FWidth := AWidth;
    FHeight := AHeight;
    UpdateAnchorRules;
    Invalidate;
    Perform(WM_WINDOWPOSCHANGED, 0, 0);
    RequestAlign;
    if not (csLoading in ComponentState) then Resize;
  end;{}
end;

function TWallPaper.GetPalette: HPALETTE;
begin
  Result := 0;
  if FPicture.Graphic <> nil then Result := FPicture.Graphic.Palette;
end;

procedure TWallPaper.Paint;
var Save: Boolean;
begin
  if csDesigning in ComponentState then with inherited Canvas do begin
    Pen.Style := psDash;
    Brush.Style := bsClear;
    Rectangle(0, 0, Width, Height);
  end;
  Save := FDrawing;
  FDrawing := True;
  try
    NowDraw(inherited Canvas);//<- Çizim yapar
  finally
    FDrawing := Save;
  end;
end;

function TWallPaper.DoPaletteChange: Boolean;
var
  ParentForm: TCustomForm;
  Tmp: TGraphic;
begin
  Result := False;
  Tmp := Picture.Graphic;
  if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
    (Tmp.PaletteModified) then
  begin
    if (Tmp.Palette = 0) then
      Tmp.PaletteModified := False
    else
    begin
      ParentForm := GetParentForm(Self);
      if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
      begin
        if FDrawing then
          ParentForm.Perform(wm_QueryNewPalette, 0, 0)
        else
          PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
        Result := True;
        Tmp.PaletteModified := False;
      end;
    end;
  end;
end;

procedure TWallPaper.Progress(Sender: TObject; Stage: TProgressStage;
  PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  if FIncrementalDisplay and RedrawNow then
  begin
    if DoPaletteChange then Update
    else Paint;
  end;
  if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;

procedure TWallPaper.SetControlRect(const Control:TControl);
var _Left, _Top, _Width, _Height: Integer;
begin
  if Assigned(Control) then begin
    _Left:=0;
    _Top:=0;
    _Width:=Control.ClientWidth;
    _Height:=Control.ClientHeight;
    {if (Control is TScrollingWinControl) then with TScrollingWinControl(Control) do begin
      if VertScrollBar.IsScrollBarVisible then begin   //Düşey
        _Top:=-VertScrollBar.Position;
        _Height:=Control.Height;
      end;
      if HorzScrollBar.IsScrollBarVisible then begin  //Yatay
        _Left:=-HorzScrollBar.Position;
        _Width:=Control.Width;
      end;
    end; {}
    if (Control is TWinControl) then SetBounds(_Left, _Top, _Width, _Height);
  end;
end;

procedure TWallPaper.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  SetControlRect(AParent);
end;

function TWallPaper.GetCanvas: TCanvas;
var Bitmap: TBitmap;
begin
  if Picture.Graphic = nil then begin
    Bitmap := TBitmap.Create;
    try
      Bitmap.Width := Width;
      Bitmap.Height := Height;
      Picture.Graphic := Bitmap;
    finally
      Bitmap.Free;
    end;
  end;
  if Picture.Graphic is TBitmap then
    Result := TBitmap(Picture.Graphic).Canvas
  else raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
end;

procedure TWallPaper.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;

procedure TWallPaper.SetStretch(Value: Boolean);
begin
  if Value <> FStretch then begin
    FStretch := Value;
    PictureChanged(Self);
  end;
end;

procedure TWallPaper.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then begin
    FTransparent := Value;
    PictureChanged(Self);
  end;
end;

procedure TWallPaper.PictureChanged(Sender: TObject);
var G: TGraphic;
begin
//  if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then SetBounds(Left, Top, Picture.Width, Picture.Height);
  if AutoSize then SetControlRect(Parent);
  G := Picture.Graphic;
  if G <> nil then begin
    if not ((G is TMetaFile) or (G is TIcon)) then
      G.Transparent := FTransparent;

    if (not G.Transparent) and (Stretch or (G.Width >= Width)
      and (G.Height >= Height)) then

      ControlStyle := ControlStyle + [csOpaque]
    else ControlStyle := ControlStyle - [csOpaque];
    if DoPaletteChange and FDrawing then Update;
  end else ControlStyle := ControlStyle - [csOpaque];
  if not FDrawing then Invalidate;
end;

function TWallPaper.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
var W,H:Boolean;
begin
  Result := True;
  if not (csDesigning in ComponentState) then begin
    W:=(NewWidth <> Parent.ClientWidth) and (Align in [alNone, alLeft, alRight]);
    if W then NewWidth := Parent.ClientWidth;
    H:=(NewHeight <> Parent.ClientHeight) and (Align in [alNone, alTop, alBottom]);
    if H then NewHeight := Parent.ClientHeight;
    if W or H then PictureChanged(Self);
  end;
end;

procedure TWallPaper.SetDrawType(const Value: TDrawType);
begin
  if FDrawType <> Value then begin
    FDrawType := Value;
    case Value of
      dtCenter:NowDraw:=DrawCenter;
      dtTile:NowDraw:=DrawTile;
      dtStretch:NowDraw:=DrawStretch;
    else
      NowDraw:=DrawNone;
    end;
    PictureChanged(Self);
  end;
end;

procedure TWallPaper.DrawNone(const Canvas: TCanvas);
begin
  Canvas.Draw(FPictureLeft, FPictureTop, Picture.Graphic);
end;

procedure TWallPaper.DrawCenter(const Canvas:TCanvas);
begin
  Canvas.Draw((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
   Picture.Graphic);
end;

procedure TWallPaper.DrawStretch(const Canvas:TCanvas);
begin
  Canvas.StretchDraw(ClientRect, Picture.Graphic);
end;

procedure TWallPaper.DrawTile(const Canvas:TCanvas);
var X_Width,Y_Height:Integer;
begin
  if (Picture.Width>0) and (Picture.Height>0) then begin
    Y_Height:=0;
    while Y_Height<Height do begin
      X_Width:=0;
      while X_Width<Width do begin
        Canvas.Draw(X_Width,Y_Height, Picture.Graphic);
        X_Width:=X_Width+Picture.Width;
      end;
      Y_Height:=Y_Height+Picture.Height;
    end;
  end;
end;

procedure TWallPaper.SetPictureLeft(const Value: Integer);
begin
  if FPictureLeft <> Value then begin
    FPictureLeft := Value;
    if FDrawType=dtNone then PictureChanged(Self);
  end;
end;

procedure TWallPaper.SetPictureTop(const Value: Integer);
begin
  if FPictureTop <> Value then begin
    FPictureTop := Value;
    if FDrawType=dtNone then PictureChanged(Self);
  end;
end;

end.

TWallPaper bileşeni TImage bileşeni ile aynı yapıda fakat bazı ek özellikleri bulunmaktadır. DrawType özelliği dtNone,dtCenter,dtTile,dtStretch değerlerini alabiliyor.

dtNone:PictureLeft ve PictureTop ile belirtilen yerden çizim yapar.

dtCenter:Ortalı çizer.

dtTile:Bileşen dolana kadar çizim yapar.

dtStretch:Beleşeni kaplayacak şekilde çizim yapar.

Zaten bu özelliklerin isimlerinden ne işe yaradıkları belli olmaktadır. Bu bileşende bir hata bulunmaktadır. Eğer resim olarak .ico dosyası seçilirse ve "WallPaper1.DrawType:=dtStretch" yapılırsa resim bileşeni kaplamıyor. . Hatayı gidermek için değişik yöntemler buldum ama içime sinen bir yöntem bulursam onu kullanacağım. (Başka Image nesnesine resimi alıp oradan kullanmak sorunu çözüyor.)

[qamyoncu]

İncelemiştim zaten Hocam. Bende sizin gibi TImage'nin kodlarını kopyaladım ve birkaç özellik ekleyerek TBImage nesnesini oluşturdum. Ancak sizin eklediğiniz özellikler benimki gibi görsel olmayan sınıflar veya nesnelerden türetilmiş özellikler. Ben ise, bunların dışında TImage sınıfını da özellik olarak eklmek istiyorum. 2 farklı resim koyabileceğim bir nesne olarak düşünebilirsinz bu komponenti, dış çerçeve ve iç fotoğraf. Mantıksal olarak TImage'den bir bir nesne yaratmam yetmez mi bunun için. Editlerin içine buton konan komponentlerin kodlarnı inceledim, create edip height width gibi birkaç özelliği girmişler ve paşa paşa kullanıyor. Yaklaşık 1 aydır tırmalıyorum iç içe 2 image nesnesi oluşturmak için. Ne farkı olabilir Edit-Button ile BImage-Image ??

@sabanakman hocam; ilginiz için çok teşekkür ederim.. Araştırmaya meraklıyım ancak tıkandım malesef.. Sağ olun.

[sabanakman]

Kod düzeltmek zahmetli olacağı için bunun yerine yeni bir örnek geliştirmek daha mantıklı geldi bana. Burada standart Picture özelliğine ilaveten EPicture (erkek simge resmini tutacak nesne) ve KPicture (kız simge resmini tutacak nesne) özellikleri eklendi ve pratik kullanım için Cinsiyet isimli özellik eklendi. Sadece bu özellik kullanılarak Picture'lara yüklenen resimler kullanılabilinecektir. Örnek olarak verilen kodlar yine tamamen TImage nesnesinden birebir kopyadır. Bu kopyaya eklenen kodların sonuna "//<--" şeklinde imza eklendi. Sadece bu satırlara göz atman sana fikir verecektir.

Kod: Tümünü seç

unit Unit2;

interface

uses Windows, Messages, SysUtils, Classes, Forms, Menus, Graphics, StdCtrls,
  Controls, Consts;

type
  TCinsiyet=(cErkek,cKiz);//<--

  TBImage = class(TGraphicControl)
  private
    FPicture: TPicture;
    FEPicture: TPicture;//<-- Erkek simge resmini tutacak nesne
    FKPicture: TPicture;//<-- Kız simge resmini tutacak nesne
    FOnProgress: TProgressEvent;
    FStretch: Boolean;
    FCenter: Boolean;
    FIncrementalDisplay: Boolean;
    FTransparent: Boolean;
    FDrawing: Boolean;
    FProportional: Boolean;
    FCinsiyet: TCinsiyet;//<--
    function GetCanvas: TCanvas;
    procedure PictureChanged(Sender: TObject);
    procedure SetCenter(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure ResmiTazele;//<-- Seçilen özelliğe göre gereken çizimin yapılması
    procedure SetEPicture(Value: TPicture);//<--
    procedure SetKPicture(Value: TPicture);//<--
    procedure SetStretch(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure SetProportional(Value: Boolean);
    procedure SetCinsiyet(const Value: TCinsiyet);//<--
  protected
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    function DestRect: TRect;
    function DoPaletteChange: Boolean;
    function GetPalette: HPALETTE; override;
    procedure Paint; override;
    procedure Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TCanvas read GetCanvas;
  published
    property Align;
    property Anchors;
    property AutoSize;
    property Center: Boolean read FCenter write SetCenter default False;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
    property ParentShowHint;
    property Picture: TPicture read FPicture write SetPicture;
    property EPicture: TPicture read FEPicture write SetEPicture;//<--
    property KPicture: TPicture read FKPicture write SetKPicture;//<--
    property PopupMenu;
    property Proportional: Boolean read FProportional write SetProportional default false;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
    property OnStartDock;
    property OnStartDrag;
    property Cinsiyet:TCinsiyet read FCinsiyet write SetCinsiyet;//<-- Cinsiyetin belirlenmesi ve buna göre resmin gerekli ayarlanması
  end;

implementation

{ TImage }

constructor TBImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  FPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  FPicture.OnProgress := Progress;
  FEPicture := TPicture.Create;//<-- başlangıçta gereken nesnelerin oluşması ve
  FKPicture := TPicture.Create;//<--
  FCinsiyet := cErkek;//<-- ilk değerin atanması
  Height := 105;
  Width := 105;
end;

destructor TBImage.Destroy;
begin
  FPicture.Free;
  FEPicture.Free;//<-- iş bitince de oluşan nesnelerin silinmesi
  FKPicture.Free;//<--
  inherited Destroy;
end;

function TBImage.GetPalette: HPALETTE;
begin
  Result := 0;
  if FPicture.Graphic <> nil then
	Result := FPicture.Graphic.Palette;
end;

function TBImage.DestRect: TRect;
var
  w, h, cw, ch: Integer;
  xyaspect: Double;
begin
  w := Picture.Width;
  h := Picture.Height;
  cw := ClientWidth;
  ch := ClientHeight;
  if Stretch or (Proportional and ((w > cw) or (h > ch))) then
  begin
	if Proportional and (w > 0) and (h > 0) then
	begin
      xyaspect := w / h;
      if w > h then
      begin
        w := cw;
        h := Trunc(cw / xyaspect);
        if h > ch then  // woops, too big
        begin
          h := ch;
          w := Trunc(ch * xyaspect);
        end;
      end
      else
      begin
        h := ch;
        w := Trunc(ch * xyaspect);
        if w > cw then  // woops, too big
        begin
          w := cw;
          h := Trunc(cw / xyaspect);
        end;
      end;
    end
    else
    begin
      w := cw;
      h := ch;
    end;
  end;

  with Result do
  begin
    Left := 0;
    Top := 0;
    Right := w;
    Bottom := h;
  end;

  if Center then
	OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);
end;

procedure TBImage.Paint;
var
  Save: Boolean;
begin
  if csDesigning in ComponentState then
	with inherited Canvas do
	begin
	  Pen.Style := psDash;
	  Brush.Style := bsClear;
	  Rectangle(0, 0, Width, Height);
	end;
  Save := FDrawing;
  FDrawing := True;
  try
	with inherited Canvas do
	  StretchDraw(DestRect, Picture.Graphic);
  finally
	FDrawing := Save;
  end;
end;

function TBImage.DoPaletteChange: Boolean;
var
  ParentForm: TCustomForm;
  Tmp: TGraphic;
begin
  Result := False;
  Tmp := Picture.Graphic;
  if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
	(Tmp.PaletteModified) then
  begin
	if (Tmp.Palette = 0) then
	  Tmp.PaletteModified := False
	else
	begin
	  ParentForm := GetParentForm(Self);
	  if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
	  begin
		if FDrawing then
		  ParentForm.Perform(wm_QueryNewPalette, 0, 0)
		else
		  PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
		Result := True;
		Tmp.PaletteModified := False;
	  end;
	end;
  end;
end;

procedure TBImage.Progress(Sender: TObject; Stage: TProgressStage;
  PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  if FIncrementalDisplay and RedrawNow then
  begin
	if DoPaletteChange then Update
	else Paint;
  end;
  if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;

function TBImage.GetCanvas: TCanvas;
var
  Bitmap: TBitmap;
begin
  if Picture.Graphic = nil then
  begin
	Bitmap := TBitmap.Create;
	try
	  Bitmap.Width := Width;
	  Bitmap.Height := Height;
	  Picture.Graphic := Bitmap;
	finally
	  Bitmap.Free;
	end;
  end;
  if Picture.Graphic is TBitmap then
	Result := TBitmap(Picture.Graphic).Canvas
  else
	raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
end;

procedure TBImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
	FCenter := Value;
	PictureChanged(Self);
  end;
end;

procedure TBImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;

procedure TBImage.ResmiTazele;//<--
begin
  if FCinsiyet=cKiz then Picture.Assign(KPicture)
  else Picture.Assign(EPicture);
end;

procedure TBImage.SetEPicture(Value: TPicture);//<--
begin
  FEPicture.Assign(Value);
  ResmiTazele;
end;

procedure TBImage.SetKPicture(Value: TPicture);//<--
begin
  FKPicture.Assign(Value);
  ResmiTazele;
end;

procedure TBImage.SetStretch(Value: Boolean);
begin
  if Value <> FStretch then
  begin
	FStretch := Value;
	PictureChanged(Self);
  end;
end;

procedure TBImage.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
	FTransparent := Value;
	PictureChanged(Self);
  end;
end;

procedure TBImage.SetProportional(Value: Boolean);
begin
  if FProportional <> Value then
  begin
	FProportional := Value;
	PictureChanged(Self);
  end;
end;

procedure TBImage.PictureChanged(Sender: TObject);
var
  G: TGraphic;
  D : TRect;
begin
  if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
	SetBounds(Left, Top, Picture.Width, Picture.Height);
  G := Picture.Graphic;
  if G <> nil then
  begin
	if not ((G is TMetaFile) or (G is TIcon)) then
	  G.Transparent := FTransparent;
        D := DestRect;
	if (not G.Transparent) and (D.Left <= 0) and (D.Top <= 0) and
	   (D.Right >= Width) and (D.Bottom >= Height) then
	  ControlStyle := ControlStyle + [csOpaque]
	else  // picture might not cover entire clientrect
	  ControlStyle := ControlStyle - [csOpaque];
	if DoPaletteChange and FDrawing then Update;
  end
  else ControlStyle := ControlStyle - [csOpaque];
  if not FDrawing then Invalidate;
end;

function TBImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := True;
  if not (csDesigning in ComponentState) or (Picture.Width > 0) and
    (Picture.Height > 0) then
  begin
    if Align in [alNone, alLeft, alRight] then
      NewWidth := Picture.Width;
    if Align in [alNone, alTop, alBottom] then
      NewHeight := Picture.Height;
  end;
end;

procedure TBImage.SetCinsiyet(const Value: TCinsiyet);//<--
begin
  if Value<>FCinsiyet then begin
    FCinsiyet := Value;
    ResmiTazele;
  end;
end;

end.

Örnek olarak kullanmak gerekirse

Kod: Tümünü seç

procedure TForm1.FormCreate(Sender: TObject);
begin
  BImage:=TBImage.Create(Self);
  with BImage do begin
    Parent:=Self;
    Left:=400;
    Top:=350;
    EPicture.LoadFromFile('c:\programyolu\erkek.bmp');
    KPicture.LoadFromFile('c:\programyolu\kiz.bmp');
    Cinsiyet:=cKiz;
  end;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  if CheckBox1.Checked then BImage.Cinsiyet:=cErkek
  else BImage.Cinsiyet:=cKiz;
end;

şeklinde bir kodla kullanılabilir.

[qamyoncu]

Merhabalar;

Sizin kodlarınız istediğime çok yakın sağ olun. Eksik kısmı ise, EPicture ve ya KPicture'nin 15er px içeride olmaması. Bunun için TImage'nin içerisindeki çizim kodlarıyla oynamak gerek sanırım. Biraz kurcaladım fotoğrafı 15er px içerde tutmayı başardım ancak 2. fotoğrafı koyduğumda oda 15erpx içeride oldu Oysa ki biri dışarıda kalmalı

[sabanakman]

Picture nesnesi sadece resimleri bellekte tutar, bunu göstermek, çizmek ve konumlandırmak ancak gerekli kodlarla sağlanabilmektedir. Bu noktada tek yapman gereken Paint metdounda bulunan StretchDraw(DestRect, Picture.Graphic); satırını gerektiği gibi düzenlemek. Burada resim tüm bileşeni kaplayacak şekilde kodlandırma yapılmaktadır. İstenen işlem için tek yapılması gereken DestRect alanını istenen ölçüde daraltmak. Paint metodunun içeriği

Kod: Tümünü seç

procedure TBImage.Paint;
var
  Save: Boolean;
  Alan: TRect;//<--
begin
  if csDesigning in ComponentState then
	with inherited Canvas do
	begin
	  Pen.Style := psDash;
	  Brush.Style := bsClear;
	  Rectangle(0, 0, Width, Height);
	end;
  Save := FDrawing;
  FDrawing := True;
  try
    with inherited Canvas do begin //<--
      Alan:=DestRect;              //<--
      Alan.Left:=Alan.Left+15;     //<--
      Alan.Right:=Alan.Right-15;   //<--
      Alan.Top:=Alan.Top+15;       //<--
      Alan.Bottom:=Alan.Bottom-15; //<--
      StretchDraw(Alan, Picture.Graphic); //<-->
    end;                           //<--
  finally
	FDrawing := Save;
  end;
end;

gibi bir kodla şekillendirilirse sanıyorum istediğin olacaktır.

[qamyoncu]

Evet, istediğim oldu sayılır. Teşekkür ederim. içine gelen fotoğrafın boyutuna göre dıştaki çerçeve de değişiyor ancak sanırım bu sorunun üstesinden gelebilirim:)
Hayırlı Ramazanlar..

[aLonE CoDeR]

Image nesnesinin kodlarını neden kopyaladığınız merakımı celbetti. Her halükarda Graphic unitini import etmek durumundasınız, yine aynı sınıftan türetilebilir..