Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 2008.08.17;
Скачать: [xml.tar.bz2];

Вниз

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

 
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;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.48 MB
Время: 0.04 c
2-1215783986
MaximMar
2008-07-11 17:46
2008.08.17
Число, TDateTime


2-1216032987
alexalex
2008-07-14 14:56
2008.08.17
печать


15-1214612469
axis_of_evil
2008-06-28 04:21
2008.08.17
устройство USB не опознано


2-1215729286
fog
2008-07-11 02:34
2008.08.17
Почему генерируется ошибка?


4-1194334678
Mamed
2007-11-06 10:37
2008.08.17
Lan Card Disable





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский