Вот целый готовый компонент. Там можно посмотреть принцип:
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.
|
Хоть это и фрейм, но естественно можно применить и для форм. |
Подскажите, пожалуйста, как можно сделать такое: есть компонент TImage небольшого размера и картинка размера намного большего, чем сам компонент. Как можно в этом компоненте отобразить картинку не с ее верхнего левого угла, а например с точки (100, 200) от начала (левый верхний угол). Спасибо...