VPF::Сдвиг в TImage - Форум программистов

MacTep

Дата 10.5.2005, 13:45 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1292
Регистрация: 4.8.2003
Где: г. Самара

Репутация: нет
Всего: 4

Привет всем участникам форума! smile

Подскажите, пожалуйста, как можно сделать такое: есть компонент TImage небольшого размера и картинка размера намного большего, чем сам компонент. Как можно в этом компоненте отобразить картинку не с ее верхнего левого угла, а например с точки (100, 200) от начала (левый верхний угол). Спасибо...
smile

--------------------

(A)bort, (R)etry, (I)gnore = Haфиг, Heфиг, Пoфиг ... :)

Rouse_

Дата 10.5.2005, 15:41 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 469
Регистрация: 23.4.2005

Репутация: нет
Всего: 29

Это пойдет?

Код


////////////////////////////////////////////////////////////////////////////////
//
//  ****************************************************************************
//  * Unit Name : FWImage
//  * Purpose   : демонстроционный компонент - аналог TImage с возможностью скролирования
//  * Author    : Александр Багель
//  * Version   : 1.00
//  ****************************************************************************
//

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.

--------------------

Vae Victis
(Горе побежденным (лат.))
Демо с открытым кодом: http://rouse.drkb.ru

MacTep

Дата 10.5.2005, 20:40 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1292
Регистрация: 4.8.2003
Где: г. Самара

Репутация: нет
Всего: 4

Все хорошо! smile

А еще какие-нибудь способы есть, без ввода дополнительного компонента? smile

--------------------

(A)bort, (R)etry, (I)gnore = Haфиг, Heфиг, Пoфиг ... :)

Rouse_

Дата 11.5.2005, 10:18 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 469
Регистрация: 23.4.2005

Репутация: нет
Всего: 29

Цитата(MacTep @ 10.5.2005, 21:40)

А еще какие-нибудь способы есть, без ввода дополнительного компонента?

Ну так BitBlt smile

--------------------

Vae Victis
(Горе побежденным (лат.))
Демо с открытым кодом: http://rouse.drkb.ru

MacTep

Дата 11.5.2005, 21:08 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1292
Регистрация: 4.8.2003
Где: г. Самара

Репутация: нет
Всего: 4

Цитата

Ну так BitBlt

Так вот я и не пойму, что это такое?

--------------------

(A)bort, (R)etry, (I)gnore = Haфиг, Heфиг, Пoфиг ... :)

Rouse_

Дата 11.5.2005, 22:34 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 469
Регистрация: 23.4.2005

Репутация: нет
Всего: 29

И не поймешь, если не почитаешь справку по данной функции...

--------------------

Vae Victis
(Горе побежденным (лат.))
Демо с открытым кодом: http://rouse.drkb.ru

MacTep

Дата 12.5.2005, 20:20 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1292
Регистрация: 4.8.2003
Где: г. Самара

Репутация: нет
Всего: 4

Цитата

И не поймешь, если ...

Красиво сказал...
Вот выдержка из справки:

Цитата

The BitBlt function performs a bit-block transfer of the color data corresponding to a rectangle of pixels from the specified source device context into a destination device context.

BOOL BitBlt(

HDC hdcDest, // handle to destination device context
int nXDest, // x-coordinate of destination rectangle's upper-left corner
int nYDest, // y-coordinate of destination rectangle's upper-left corner
int nWidth, // width of destination rectangle
int nHeight, // height of destination rectangle
HDC hdcSrc, // handle to source device context
int nXSrc, // x-coordinate of source rectangle's upper-left corner
int nYSrc, // y-coordinate of source rectangle's upper-left corner
DWORD dwRop // raster operation code
);

Parameters

hdcDest

Identifies the destination device context.

nXDest

Specifies the logical x-coordinate of the upper-left corner of the destination rectangle.

nYDest

Specifies the logical y-coordinate of the upper-left corner of the destination rectangle.

nWidth

Specifies the logical width of the source and destination rectangles.

nHeight

Specifies the logical height of the source and the destination rectangles.

hdcSrc

Identifies the source device context.

nXSrc

Specifies the logical x-coordinate of the upper-left corner of the source rectangle.

nYSrc

Specifies the logical y-coordinate of the upper-left corner of the source rectangle.

dwRop

Specifies a raster-operation code. These codes define how the color data for the source rectangle is to be combined with the color data for the destination rectangle to achieve the final color.
The following list shows some common raster operation codes:

Value Description
BLACKNESS Fills the destination rectangle using the color associated with index 0 in the physical palette. (This color is black for the default physical palette.)
DSTINVERT Inverts the destination rectangle.
MERGECOPY Merges the colors of the source rectangle with the specified pattern by using the Boolean AND operator.
MERGEPAINT Merges the colors of the inverted source rectangle with the colors of the destination rectangle by using the Boolean OR operator.
NOTSRCCOPY Copies the inverted source rectangle to the destination.
NOTSRCERASE Combines the colors of the source and destination rectangles by using the Boolean OR operator and then inverts the resultant color.
PATCOPY Copies the specified pattern into the destination bitmap.
PATINVERT Combines the colors of the specified pattern with the colors of the destination rectangle by using the Boolean XOR operator.
PATPAINT Combines the colors of the pattern with the colors of the inverted source rectangle by using the Boolean OR operator. The result of this operation is combined with the colors of the destination rectangle by using the Boolean OR operator.
SRCAND Combines the colors of the source and destination rectangles by using the Boolean AND operator.
SRCCOPY Copies the source rectangle directly to the destination rectangle.
SRCERASE Combines the inverted colors of the destination rectangle with the colors of the source rectangle by using the Boolean AND operator.
SRCINVERT Combines the colors of the source and destination rectangles by using the Boolean XOR operator.
SRCPAINT Combines the colors of the source and destination rectangles by using the Boolean OR operator.
WHITENESS Fills the destination rectangle using the color associated with index 1 in the physical palette. (This color is white for the default physical palette.)

Return Values

If the function succeeds, the return value is nonzero.
If the function fails, the return value is zero. To get extended error information, call GetLastError.

Remarks

If a rotation or shear transformation is in effect in the source device context, BitBlt returns an error. If other transformations exist in the source device context (and a matching transformation is not in effect in the destination device context), the rectangle in the destination device context is stretched, compressed, or rotated as necessary.
If the color formats of the source and destination device contexts do not match, the BitBlt function converts the source color format to match the destination format.

When an enhanced metafile is being recorded, an error occurs if the source device context identifies an enhanced-metafile device context.
Not all devices support the BitBlt function. For more information, see the RC_BITBLT raster capability entry in GetDeviceCaps.
BitBlt returns an error if the source and destination device contexts represent different devices.

Ну и что? Все понятно? Вопрос срочный, а что-то никто помочь не может! smile

Сорри, если кого-то обидел!

--------------------

(A)bort, (R)etry, (I)gnore = Haфиг, Heфиг, Пoфиг ... :)

Yanis

Дата 12.5.2005, 23:40 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 2937
Регистрация: 9.2.2004
Где: Москва

Репутация: 2
Всего: 111

Не получилось прикрепить весь проект, но код я всё таки выложу здесь:
Unit1.pas

Код


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, jpeg, ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if (ssCtrl in shift) then
    BitBlt(Image2.Canvas.Handle, 0, 0, Image2.Width, Image2.Height, Image1.Canvas.Handle, X, Y, SRCCOPY);

  Image2.Refresh;
end;
end.

На форме 2 TImage: Image1 - большая картинка, Image2 - маленькая картинка.

Это сообщение отредактировал(а) Yanis - 12.5.2005, 23:41

--------------------

*щёлк*

MacTep

Дата 21.5.2005, 12:46 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1292
Регистрация: 4.8.2003
Где: г. Самара

Репутация: нет
Всего: 4

Yanis, очень полезный совет! Спасибо! +1 к репутации!

--------------------

(A)bort, (R)etry, (I)gnore = Haфиг, Heфиг, Пoфиг ... :)

MacTep

Дата 24.5.2005, 20:28 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1292
Регистрация: 4.8.2003
Где: г. Самара

Репутация: нет
Всего: 4

А возможно ли сделать как-нибудь такое: нажимаю и удерживаю левую кнопку мыши на небьольшом компоненте TImage и начинаю водить мышкой. Таким образом начальная картинка сдвигается влево/вправо/вверх/вниз в зависимости от того, куда я потянул мышу. Можно? И если да, от как? Спасибо...

--------------------

(A)bort, (R)etry, (I)gnore = Haфиг, Heфиг, Пoфиг ... :)

s-mike

Дата 25.5.2005, 07:10 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 425
Регистрация: 16.1.2005
Где: Киев

Репутация: 5
Всего: 16

Вот целый готовый компонент. Там можно посмотреть принцип:
http://forum.vingrad.ru/index.php?showtopic=45912

А вот я когда-то писал что-то подобное:

Код


unit ImgFrm;

interface

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

type
  TImageFrame = class(TFrame)
    Image: TImage;
    procedure ImageMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ImageMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure HandleKeyDown(var Key: Word; Shift: TShiftState);
    procedure FrameResize(Sender: TObject);
  private
    FMouseDown, FScrollEnabled: Boolean;
    FX, FY: Integer;
    procedure SetDefImageBounds;
    procedure SetWidthAndHeight;
  public
    constructor Create(AOwner: TComponent); override;
    procedure LoadImage(const FileName: string);
    procedure ScrollImage(const DX, DY: Integer);
  end;

implementation

{$R *.DFM}

const
  crHand = 1;
  crDrag = 2;

constructor TImageFrame.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
end;

procedure TImageFrame.SetWidthAndHeight;
var
  W, H: Integer;
begin
  W := Image.Picture.Width;
  H := Image.Picture.Height;
  Image.Center := (W < ClientWidth) or (H < ClientHeight);
  if W < ClientWidth then W := ClientWidth;
  if H < ClientHeight then H := ClientHeight;
  FScrollEnabled := (W <> ClientWidth) or (H <> ClientHeight);
  if FScrollEnabled then
    Image.Cursor := crHand
  else
    Image.Cursor := crDefault;
  Image.SetBounds(Image.Left, Image.Top, W, H);
end;

procedure TImageFrame.SetDefImageBounds;
begin
  Image.Left := 0;
  Image.Top  := 0;
  SetWidthAndHeight;
end;

procedure TImageFrame.LoadImage(const FileName: string);
begin
  Image.Picture.LoadFromFile(FileName);
  SetDefImageBounds;
  InValidateRect(Handle, nil, True);
end;

procedure TImageFrame.ScrollImage(const DX, DY: Integer);
var
  L, T: Integer;
begin
  L := Image.Left;
  T := Image.Top;
  if DX <> 0 then L := L + DX;
  if DY <> 0 then T := T + DY;
  if L > 0 then L := 0 else
    if Image.Width + L < ClientWidth then L := ClientWidth - Image.Width;
  if T > 0 then T := 0 else
    if Image.Height + T < ClientHeight then T := ClientHeight - Image.Height;
  if (L <> Image.Left) or
     (T <> Image.Top) then
    Image.SetBounds(L, T, Image.Width, Image.Height);
end;

procedure TImageFrame.ImageMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) and FScrollEnabled then
  begin
    Screen.Cursor := crDrag;
    FMouseDown := True;
    FX := X;
    FY := Y;
  end;
end;

procedure TImageFrame.ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if FMouseDown then ScrollImage(X - FX, Y - FY)
end;

procedure TImageFrame.ImageMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    Screen.Cursor := crDefault;
    FMouseDown := False;
  end;
end;

procedure TImageFrame.FrameResize(Sender: TObject);
begin
  SetWidthAndHeight;
  if Image.Width + Image.Left < ClientWidth then
    Image.Left := ClientWidth - Image.Width;
  if Image.Height + Image.Top < ClientHeight then
    Image.Top := ClientHeight - Image.Height;
  InValidateRect(Handle, nil, True);
end;

initialization
  Screen.Cursors[crHand] := LoadCursor(HInstance, 'HAND');
  Screen.Cursors[crDrag] := LoadCursor(HInstance, 'DRAG');

end.

Хоть это и фрейм, но естественно можно применить и для форм.

--------------------

Преферанс для Android на базе исходников Марьяжа

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Звук, графика и видео \| Следующая тема »