我开发了一个组件来实现基于Graphics32的 ImgView32 的平移和缩放功能。可以将组件放在 TImgView32 旁边,设置我的组件的 Image 视图属性,一切都很好,并且按预期工作。但是,一旦我尝试关闭托管我的组件的表单和 ImgView32,Delphi IDE 就会冻结。我的第一个想法是仍然链接到我的组件的 ImgView32 在我的组件之前被销毁,所以我实现了 Delphi 标准通知机制。问题仍然存在。这是我的组件的源代码。该组件包含在运行时包中,而另一个设计时包正在使用运行时包并注册该组件。
更新,作为 Rob 有用的调试技巧的结果:事实证明,组件在对 Notification 方法的无休止调用中挂起。也许那是对某人的暗示。
unit MJImgView32PanZoom;
interface
uses Classes, Controls, Gr32, GR32_Image, GR32_Layers;
type
TImgView32ScaleChangeEvent = procedure( OldScale, NewScale: Double ) of object;
TimgView32PanZoom = class(TComponent)
private
FEnabled: Boolean;
FMaxZoom: Double;
FMinZoom: Double;
FImgView32: TImgView32;
FZoomStep: Double;
FOrigImgMouseMove: TImgMouseMoveEvent;
FOrigImgMouseDown: TImgMouseEvent;
FOrigImgMouseUp: TImgMouseEvent;
FOrigImgMouseWheel: TMouseWheelEvent;
FOrigImgCursor: TCursor;
FPanMouseButton: TMouseButton;
FLastMouseDownPos : TFloatPoint;
FPanCursor: TCursor;
FOnScaleChanged: TImgView32ScaleChangeEvent;
procedure imgMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
procedure imgMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
procedure SetImgView32(const Value: TImgView32);
procedure imgMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
procedure imgMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
destructor Destroy; override;
constructor Create(AOwner: TComponent); override;
published
property Enabled: Boolean read FEnabled write FEnabled;
property MaxZoom: Double read FMaxZoom write FMaxZoom;
property MinZoom: Double read FMinZoom write FMinZoom;
property PanMouseButton: TMouseButton read FPanMouseButton write FPanMouseButton;
property PanCursor: TCursor read FPanCursor write FPanCursor;
property ZoomStep: Double read FZoomStep write FZoomStep;
property ImgView32: TImgView32 read FImgView32 write SetImgView32;
property OnScaleChanged: TImgView32ScaleChangeEvent read FOnScaleChanged write FOnScaleChanged;
end;
implementation
{ TimgView32PanZoom }
constructor TimgView32PanZoom.Create(AOwner: TComponent);
begin
inherited;
FimgView32 := nil;
FEnabled := True;
FZoomStep := 0.1;
FMaxZoom := 5;
FMinZoom := 0.1;
FPanMouseButton := mbLeft;
FEnabled := True;
FPanCursor := crDefault;
end;
destructor TimgView32PanZoom.Destroy;
begin
ImgView32 := nil;
inherited;
end;
procedure TimgView32PanZoom.imgMouseDown( Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer );
begin
if not Enabled then
Exit;
if ( FPanMouseButton = mbLeft ) and not( ssLeft in Shift ) then
Exit;
if ( FPanMouseButton = mbRight ) and not( ssRight in Shift ) then
Exit;
FImgView32.Cursor := FPanCursor;
Mouse.CursorPos := Point(Mouse.CursorPos.X+1, Mouse.CursorPos.Y); // need to move mouse in order to make
Mouse.CursorPos := Point(Mouse.CursorPos.X-1, Mouse.CursorPos.Y); // cursor change visible
with FImgView32, GetBitmapRect do
FLastMouseDownPos := FloatPoint((X - Left) / Scale,(Y - Top) / Scale);
if Assigned(FOrigImgMouseDown) then
FOrigImgMouseDown(Sender, Button, Shift, X, Y, Layer);
end;
procedure TimgView32PanZoom.imgMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
FImgView32.Cursor := FOrigImgCursor;
if Assigned(FOrigImgMouseUp) then
FOrigImgMouseUp(Sender, Button, Shift, X, Y, Layer);
end;
procedure TimgView32PanZoom.imgMouseMove( Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer );
begin
if not Enabled then
Exit;
if ( FPanMouseButton = mbLeft ) and not( ssLeft in Shift ) then
Exit;
if ( FPanMouseButton = mbRight ) and not( ssRight in Shift ) then
Exit;
with FImgView32 do
with ControlToBitmap( Point( X, Y ) ) do
begin
OffsetHorz := OffsetHorz + Scale * ( X - FLastMouseDownPos.X );
OffsetVert := OffsetVert + Scale * ( Y - FLastMouseDownPos.Y );
end;
if Assigned( FOrigImgMouseMove ) then
FOrigImgMouseMove( Sender, Shift, X, Y, Layer );
end;
procedure TimgView32PanZoom.imgMouseWheel( Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean );
var
tmpScale: Single;
NewHoriz, NewVert: Single;
NewScale: Single;
begin
if not Enabled then
Exit;
with FImgView32 do
begin
BeginUpdate;
tmpScale := Scale;
if WheelDelta > 0 then
NewScale := Scale * 1.1
else
NewScale := Scale / 1.1;
if NewScale > FMaxZoom then
NewScale := FMaxZoom;
if NewScale < FMinZoom then
NewScale := FMinZoom;
NewHoriz := OffsetHorz + ( tmpScale - NewScale ) * FImgView32.ControlToBitmap( FImgView32.ScreenToClient( Mouse.CursorPos ) ).X;
NewVert := OffsetVert + ( tmpScale - NewScale ) * FImgView32.ControlToBitmap( FImgView32.ScreenToClient( Mouse.CursorPos ) ).Y;
Scale := NewScale;
OffsetHorz := NewHoriz;
OffsetVert := NewVert;
EndUpdate;
Invalidate;
end;
if Assigned( FOnScaleChanged ) then
FOnScaleChanged( tmpScale, NewScale );
if Assigned( FOrigImgMouseWheel ) then
FOrigImgMouseWheel( Sender, Shift, WheelDelta, MousePos, Handled );
end;
procedure TimgView32PanZoom.Notification(AComponent: TComponent; Operation: TOperation);
begin
if (Operation = opRemove) and (AComponent = FImgView32) then
begin
FImgView32 := nil;
end;
end;
procedure TimgView32PanZoom.SetImgView32(const Value: TImgView32);
begin
if Assigned(FImgView32) then
begin
FImgView32.RemoveFreeNotification(Self);
FImgView32.OnMouseMove := FOrigImgMouseMove;
FImgView32.OnMouseDown := FOrigImgMouseDown;
FImgView32.OnMouseWheel := FOrigImgMouseWheel;
FImgView32.OnMouseUp := FOrigImgMouseUp;
FImgView32.Cursor := FOrigImgCursor;
end;
FImgView32 := Value;
if Assigned(FImgView32) then
begin
FOrigImgMouseMove := FImgView32.OnMouseMove;
FOrigImgMouseDown := FImgView32.OnMouseDown;
FOrigImgMouseWheel := FImgView32.OnMouseWheel;
FOrigImgMouseUp := FImgView32.OnMouseUp;
FOrigImgCursor := FImgView32.Cursor;
FImgView32.OnMouseDown := imgMouseDown;
FImgView32.OnMouseMove := imgMouseMove;
FImgView32.OnMouseWheel := imgMouseWheel;
FImgView32.OnMouseUp := imgMouseUp;
FImgView32.FreeNotification(Self);
end;
end;
end.