TImage içindeki Resimi Döşemek

[vkamadan]

Merhaba ,
TImage nesnesine küçük bir resim koyup, TImageyi büyüttüğümde bu resmin içine döşenmesini sağlamak istiyorum, yada nasıl benzeri bir uygulama yapabilirim?
Teşekkürler.

[sadettinpolat]

timage in boyle bir ozelli zaten var yoksa ben mi soruyo yanlis anliyorum?

[hbahadir]

@sadettinpolat yanılmıyorsam arkadaşımız resmin özgün boyutunu koruyarak, resmi yanyana ve alt alta sürekli olarak yazdırmak istiyor. Bunun için bir kaç component vardı fakat bence paint durumunda kendiniz döşeyin yada bir panel üzerine içiçe döngü yaparak image nesnesini create ile oluşturun (eğer yeniden boyutlandırma olursa, eski oluşturduklarınızı silip tekrar oluşturabilirsiniz).

[sabanakman]

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.)

[vkamadan]

@sabanakman , geliştirmiş olduğun bileşen mükemmel olarak işime yaradı, emeğin ve ilgin için teşekkür ederim.
İlgilenen tüm arkadaşlara teşekkürler, iyi çalışmalar diliyorum.