Текущий архив: 2008.08.17;
Скачать: CL | DM;

Вниз

подскажите компонент   Найти похожие ветки 

← →
LexXL   (2007-12-04 13:54) [0]

подскажите компонент для маштабирования изображений

---

← →
kami   (2007-12-04 13:59) [1]

imgaspect к примеру - на торри.нет

---

← →
Rouse_ ©   (2007-12-04 14:09) [2]

Да его писать то :)

unit FWImage;

interface

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

type
 TFWImage = class(TGraphicControl)
 private
   FPicture: TPicture;
   FX, FY, FBX, FBY: Integer;
   BitMap: TBitmap;
   FZoom: Byte;
   procedure SetPicture(const Value: TPicture);
   procedure WMLButtonDown(var Message: TMessage); message WM_LBUTTONDOWN;
   procedure WMMouseMove(var Message: TMessage); message WM_MOUSEMOVE;
   procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
   procedure SetZoom(const Value: Byte);
 protected
   procedure PictureChanged(Sender: TObject);
   procedure Paint; override;
 public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
 published
   property Picture: TPicture read FPicture write SetPicture;
   property Zoom: Byte read FZoom write SetZoom;
 end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents("Samples", [TFWImage]);
end;

{ TFWImage }

constructor TFWImage.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FPicture := TPicture.Create;
 FPicture.OnChange := PictureChanged;
 Height := 105;
 Width := 105;
 BitMap := TBitmap.Create;
 FZoom := 1;
end;

destructor TFWImage.Destroy;
begin
 FPicture.Free;
 BitMap.Free;
 inherited;
end;

procedure TFWImage.Paint;
begin
 inherited;
 Canvas.Lock;
 if csDesigning in ComponentState then
   with Canvas do
   begin
     Pen.Style := psDash;
     Pen.Color := clBlack;
     Brush.Style := bsClear;
     Rectangle(0, 0, Width, Height);
   end;
 if Assigned(FPicture) then
   if FZoom = 1 then
     BitBlt(Canvas.Handle, 0, 0, Width, Height, Bitmap.Canvas.Handle, FX, FY, SRCCOPY)
   else
     StretchBlt(Canvas.Handle, 0, 0, Width, Height, Bitmap.Canvas.Handle,
       FX, FY, Width div FZoom, Height div FZoom, SRCCOPY);
 Canvas.Unlock;
end;

procedure TFWImage.PictureChanged(Sender: TObject);
begin
 Bitmap.Assign(FPicture.Graphic);
 Invalidate;
end;

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

procedure TFWImage.SetZoom(const Value: Byte);
begin
 if FZoom <> Value then
 begin
   FZoom := Value;
   if FZoom = 0 then FZoom := 1;
   invalidate;
 end;
end;

procedure TFWImage.WMEraseBkgnd(var Message: TMessage);
begin
 Message.Result := 0;
end;

procedure TFWImage.WMLButtonDown(var Message: TMessage);
begin
 with Message do
 begin
   FBX := LParamLo + FX * FZoom;
   FBY := LParamHi + FY * FZoom;
 end;
 inherited;
end;

procedure TFWImage.WMMouseMove(var Message: TMessage);
var
 L, H: Integer;
begin
 inherited;
 with Message do
 begin
   if KeysToShiftState(WParam) = [ssLeft] then
   begin
     L:= LParamLo;
     H:= LParamHi;
     if L > 65000 then L := L - 65535;
     if H > 65000 then H := H - 65535;
     FX := (FBX - L) div FZoom;
     FY := (FBY - H) div FZoom;
     if FX > Picture.Width - (Width div FZoom) then
       FX := Picture.Width - (Width div FZoom);
     if FY > Picture.Height - (Height div FZoom) then
       FY := Picture.Height - (Height div FZoom);
     if FX<0 then FX := 0;
     if FY<0 then FY := 0;
     Paint;
   end;
 end;
end;

end.

---

← →
Правильный_Вася   (2007-12-04 14:16) [3]

> Rouse_ ©   (04.12.07 14:09) [2]

а если не битмап, а векторное что-то, а?

---

← →
Rouse_ ©   (2007-12-04 15:00) [4]

Вектор? Эээ... Метафайл векторный? (я с метафайлами просто никогда не работал :)
Да ну и битмап - это промежуточный, т.е. он отобразит все что может подгрузить TPicture :)

---

← →
tesseract ©   (2007-12-04 15:03) [5]

> Вектор? Эээ... Метафайл векторный? (я с метафайлами просто
> никогда не работал :)


Да он векторный.

---

← →
DVM ©   (2007-12-04 15:52) [6]

WMF это формат файла. Не более.
Он векторный, но рисование на нем ничем не отличается от рисования на растре. Также на канву выводятся линии, прямоугольники и прочее. Просто потом запоминаются не точки изображения, а параметры того что рисовали.

---

← →
Eraser ©   (2007-12-04 15:57) [7]

> LexXL   (04.12.07 13:54) 

StretchBlt.

---

← →
Sapersky   (2007-12-04 16:35) [8]

Вместо StretchBlt лучше Canvas.StretchDraw(DstRect, FPicture.Graphic).
В этом случае метафайл должен отмасштабироваться векторно (вызовется TMetafile.Draw -> PlayEnhMetaFile).

---

← →
Eraser ©   (2007-12-04 16:49) [9]

непонятно другое - зачем тут вообще вектор?

---

← →
Правильный_Вася   (2007-12-04 18:41) [10]

>  зачем тут вообще вектор?

изображения разные бывают
автор-то не уточняет
можеТ, у него вообще в зеркале

---

Страницы: 1 вся ветка

Текущий архив: 2008.08.17;
Скачать: CL | DM;

Наверх

Память: 0.49 MB
Время: 0.02 c