一个控件的问题
//这是一个图象控件的源码,这个控件实现以下功能:
//1.显示图象文件,如果图象太大,画上滚动条;
//2.可以抓住图象拖动
unit ShlImage;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
JPeg, ExtDlgs, dsgnintf;
type
TImageName = TFileName;
TShlImage = class(TScrollingWinControl)
private
FImageName: TImageName;
FEmpty: Boolean;
FGraphic: TGraphic;
FCanvas: TCanvas;
FDown: Boolean;
FX0, FY0: Integer;
FAutoSize: Boolean;
function Scrolled: Boolean;
procedure SetImageName(const Value: TImageName);
procedure SetAutoSize(Value: Boolean);
procedure WMPaint(var Message: TMessage); message WM_PAINT;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property AutoScroll;
property AutoSize: Boolean read FAutoSize write SetAutoSize;
property ImageName: TImageName read FImageName write SetImageName;
property OnResize;
end;
procedure Register;
implementation
{$R *.RES}
constructor TShlImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FEmpty := True;
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;
Width := 120;
Height := 120;
end;
destructor TShlImage.Destroy;
begin
if not FEmpty then
FGraphic.Free;
FCanvas.Free;
inherited Destroy;
end;
function TShlImage.Scrolled: Boolean;
begin
Result := not FEmpty;
if Result then
Result := (Width < FGraphic.Width) or (Height < FGraphic.Height);
end;
procedure TShlImage.SetImageName(const Value: TImageName);
var
AExt: string;
OldEmpty: Boolean;
begin
if ImageName = Value then Exit;
OldEmpty := FEmpty;
AExt := LowerCase(ExtractFileExt(Value));
FEmpty := True;
try
if (AExt = '.jpg') or (AExt = '.jpeg') then begin
FGraphic := TJPegImage.Create;
TJPegImage(FGraphic).LoadFromFile(Value);
FEmpty := False;
end else if AExt = '.bmp' then begin
FGraphic := TBitmap.Create;
TBitmap(FGraphic).LoadFromFile(Value);
FEmpty := False;
end else if (AExt = '.wmf') or (AExt = '.emf') then begin
FGraphic := TMetaFile.Create;
TMetaFile(FGraphic).LoadFromFile(Value);
FEmpty := False;
end else if AExt = '.ico' then begin
FGraphic := TIcon.Create;
TIcon(FGraphic).LoadFromFile(Value);
FEmpty := False;
end;
except
end;
if not FEmpty then begin
FImageName := Value;
if FAutoSize then begin
Width := FGraphic.Width;
Height := FGraphic.Height;
end;
HorzScrollBar.Range := FGraphic.Width;
VertScrollBar.Range := FGraphic.Height;
FCanvas.FillRect(ClientRect);
end else if OldEmpty then begin
HorzScrollBar.Range := 0;
VertScrollBar.Range := 0;
FCanvas.FillRect(ClientRect);
end;
end;
procedure TShlImage.SetAutoSize(Value: Boolean);
begin
if FAutoSize <> Value then begin
FAutoSize := Value;
if FAutoSize and not FEmpty then begin
Width := FGraphic.Width;
Height := FGraphic.Height;
end;
end;
end;
procedure TShlImage.WMPaint(var Message: TMessage);
begin
inherited;
if not FEmpty then
FCanvas.Draw(- HorzScrollBar.Position, - VertScrollBar.Position, FGraphic);
end;
procedure TShlImage.WMLButtonDown(var Message: TWMLButtonDown);
begin
inherited;
if Scrolled then begin
FDown := True;
Fx0 := Message.XPos;
Fy0 := Message.YPos;
end;
end;
procedure TShlImage.WMLButtonUp(var Message: TWMLButtonUp);
begin
inherited;
if Scrolled then begin
FDown := False;
Cursor := crDefault;
end;
end;
procedure TShlImage.WMMouseMove(var Message: TWMMouseMove);
var
X, Y: Integer;
begin
inherited;
if not FDown then Exit;
// SetCursor(LoadCursor(0, IDC_IBEAM)); //有效,但不是所需,Windows没有手形光标
// Cursor := crHandPoint; //无效,光标不变
// SetCursor(LoadCursor(0, 'MYHAND')); //无效,没有光标
X := Message.XPos - Fx0;
Y := Message.YPos - Fy0;
Fx0 := Message.XPos;
Fy0 := Message.YPos;
HorzScrollBar.Position := HorzScrollBar.Position - X;
VertScrollBar.Position := VertScrollBar.Position - Y;
end;
type
TImageNameProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
function TImageNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
procedure TImageNameProperty.Edit;
var
S: string;
begin
with TOpenPictureDialog.Create(Application) do
try
S := GetValue;
if Length(S) > 0 then begin
InitialDir := ExtractFilePath(S);
FileName := ExtractFileName(S);
end;
if Execute then
SetValue(FileName);
finally
Free;
end;
end;
procedure Register;
begin
RegisterComponents('Bartons', [TShlImage]);
RegisterPropertyEditor(TypeInfo(TImageName), TShlImage, 'ImageName', TImageNameProperty);
end;
end.
//现在有如下问题:
1.垂直滚动条没有问题,水平滚动条大了一点点(多一条边)
2.拖动时想改动光标为手形,但没有成功。用了三种方法,均不行:
3.画图象时稍嫌慢。
哪位大虾有办法?