不看会后悔的Windows XP之经验谈	简单快捷DIY实用家庭影院

一个控件的问题

楼主barton（）2000-01-14 19:37:00 在 Delphi / VCL组件开发及应用提问

//这是一个图象控件的源码，这个控件实现以下功能：
//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.画图象时稍嫌慢。

哪位大虾有办法？问题点数：100、回复次数：10Top

1 楼Venne（感觉一下）回复于 2000-01-14 21:34:00 得分 60

关于第一个问题，没有试你的代码，没有发言权
第二问题，应该这样调用：
Const
MyCursor=99;
Screen.Cursors[MyCursor]:=LoadCursorFromFile(CursorFilename)
Screen.Cursor:=MyCursor;
//这样可以把光标文件名调入，也可从资源中调入。
第三个问题，
我使用bitblt API函数做的图像拖动效果，和ACDSEE的效果没有两样，图像绘制相当平滑，应该不会很慢。
这个API函数已经被Canvas的CopyRect方法封装，因此你可以使用这个方法也是一样而且比较安全。
而且我建议你不要使用PAINT来重画拖动后的效果，而是在MOUSEMOVE事件里直接向CANVAS绘制，会快很多，你可以记一个坐标位置，以使重绘时同样不会错位。
如果明天你上网，我可以把我写的一段在PAINTBOX里拖动的代码给你，如果图像比PAINTBOX大，则可以拖动，如果小于PAINTBOX的宽高，则不显示拖动，同时也改变了光标。Top

2 楼barton（）回复于 2000-01-15 00:40:00 得分 0

2.难道Delphi带的crHandPoint不能用吗？
3.我当然知道用bitblt,但因为有TJpegImage所以缺一个Handle参数。这样
当然用CopyRect也有问题。

基于PaintBox是GraphicControl,没有窗口句柄，不过也没有滚动条。
BTW：你的代码支持TJpegImage吗？Top

3 楼kxy（手举穿肠毒药，怀抱刮骨钢刀）回复于 2000-01-15 02:08:00 得分 40

1) 兄弟眼神不好,没有看出来.
2)
SetCursor(LoadCursor(0, 'MYHAND')); //无效,没有光标
改成SetCursor(LoadCursor(hInstance, 'MYHAND'));
把光标资源做到ShlImage.res中即可.
3)
procedure TShlImage.WMPaint(var Message: TMessage);
begin
inherited;
if not FEmpty then
begin
if FCanvas.ClassName = 'TBitmap' then
begin
BitBlt(FCanvas.Handle,0,0,Width,Height,(FGraphic as TBitmap).Handle,- HorzScrollBar.Position,
- VertScrollBar.Position,PATCOPY);
end else
FCanvas.Draw(- HorzScrollBar.Position, - VertScrollBar.Position, FGraphic);
end;
end;
速度没有什末变化.
我使用你原来的代码,速度还可以(赛杨333,64M,I740的显卡)

以下是 TJepgImage的Help中的一段
A TJPEGImage object:

?Has no canvas (so it cannot draw onto a canvas). However, TJPEGImage implements the protected Draw method introduced in TGraphic, so it can draw itself on the canvas of another object.
?Provides no access to the internal bitmap image that it creates for the JPEG image.
?Performs reference counting and handle sharing by means of the TJPEGData object. Multiple instances can refer to the same TJPEGData image. TJPEGData is the actual owner of the file handle to the JPEG data source.
所以如果用TJepgImage是没有其它的办法.
对1)问题Draw调整一下,如果你觉得少一条线.
3)Venna的提议可以,不要再WM_PAINT中Draw,刷新次数太多.Top

4 楼Venne（感觉一下）回复于 2000-01-15 11:22:00 得分 0

怎么回事，回复即死？Top

5 楼Venne（感觉一下）回复于 2000-01-15 11:24:00 得分 0

我只有分为两步写好象是太多的缘故。
这里是我做的图像拖动的一段代码，我会在里面做一些解释，包括你提的问题。
var bmp:Tbitmap;
BmpX,BmpY:integer;
OldPoint:TPoint;
SourceRect,DestRect:TRect;
CurrentMode:AllFileProperty;
OrginWidth,OrginHeight:integer;
fp:array [fpText..fpVideo] of String;

//该例程会在需要显示一幅文件时进行处理
//只被调用一次，如果是JPEG 或者其它类型
//的图像，应该在这里加入代码处理
//imgContent 是一个TPaintBox。
//仅当需要重画时才调用其REPAINT
procedure TfrmMain.LoadImage(FileName: string);
var
jpeg:TJpegImage;{需要使用JPEG单元}
begin
{这里加上一段处理的伪代码可以使用：}
{如果文件是JPEG，那么
Jpeg:=TJPEGIMAGE.CREATE;
JPEG导入文件；
BMP.assign(JPEG);
JPEG释放
{到此，JPEG的内容转为BMP}
否则：
bmp.LoadFromFile (Filename);

}
bmpX:=0;
bmpy:=0;
CalcRect;
imgContent.Repaint ;
end;

//计算图像大小与显示大小的关系。
procedure TfrmMain.CalcRect;
var
NowX,NowY:integer;
begin

if (bmp.Width < Contentpanel.Width) and
(bmp.height < Contentpanel.height) then
displaymode:=0;

if (bmp.Width < Contentpanel.Width) and
(bmp.height > Contentpanel.height) then
displaymode:=1;

if (bmp.Width > Contentpanel.Width) and
(bmp.height < Contentpanel.height) then
displaymode:=2;

if (bmp.Width > Contentpanel.Width) and
(bmp.height > Contentpanel.height) then
displaymode:=3;

case DisPlayMode of
0:begin
NowX :=(ContentPanel.Width -bmp.Width ) div 2;
NowY :=(ContentPanel.height -bmp.height ) div 2;
SourceRect:=Rect(0,0,bmp.width,bmp.height);
DestRect:=Rect(NowX,NowY,NowX+bmp.width,NowY+Bmp.height);
end;
1:begin
NowX :=(ContentPanel.Width -bmp.Width ) div 2;
NowY :=0;
SourceRect:=Rect(0,0,bmp.width,ContentPanel.height);
DestRect:=Rect(NowX,NowY,NowX+bmp.width,ContentPanel.height);
end;
2:begin
NowX :=0;
NowY :=(ContentPanel.height -bmp.height ) div 2;
SourceRect:=Rect(0,0,Contentpanel.width,bmp.height);
DestRect:=Rect(NowX,NowY,ContentPanel.width,NowY+Bmp.height);
end;
3:begin
NowX :=0;
NowY :=0;
SourceRect:=Rect(0,0,Contentpanel.width,ContentPanel.height);
DestRect:=Rect(NowX,NowY,Contentpanel.width,ContentPanel.height);
end;
end;

end;

Top

6 楼Venne（感觉一下）回复于 2000-01-15 11:31:00 得分 0

这是接下来的内容
procedure TfrmMain.imgContentPaint(Sender: TObject);
begin
With imgContent.Canvas do begin
CopyRect(DestRect,bmp.Canvas,sourceRect);
end;
end;

procedure TfrmMain.imgContentMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Shift<>[ssleft] then exit;
if DisplayMode<>0 then
{在此之前我已经把系统设定给cfHandPoint的值改变了，就和我
前面提到的一样，对于Screen来说， cfHandPoint不过是一个
索引因此我用：Screen.Cursors[crHandPoint]:=LoadCursorfromFile(CursorFilename);之后再调用Screen.Cursor:=crHandPoint即为我的光标，}
Screen.Cursor :=crHandPoint;
OldPoint:=point(x,y);
end;

procedure TfrmMain.imgContentMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Screen.Cursor :=crDefault;
end;

procedure TfrmMain.imgContentMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
Newx,NewY:integer;
begin
if shift<>[ssLeft] then exit;
Newx:=OldPoint.x -x;
NewY:=OldPoint.y-y;
case DisplayMode of
1:begin
bmpY:=Bmpy+NewY;
if bmpY<0 then bmpY:=0;
if (bmpy+contentPanel.Height )>bmp.Height then
bmpy:=bmp.Height -contentPanel.Height ;
SourceRect:=REct(bmpx,bmpy,bmp.width,bmpy+contentPanel.height);
end;
2:begin
BmpX:=BmpX+Newx;
if bmpX<0 then bmpX:=0;
if (bmpx+ContentPanel.Width )> bmp.Width then
bmpx:=bmp.width-contentPanel.Width ;
SourceRect:=REct(bmpx,bmpy,bmpx+ContentPanel.width,bmp.height);
end;
3:begin
BmpX:=BmpX+Newx;
bmpY:=Bmpy+NewY;
if bmpX<0 then bmpX:=0;
if bmpY<0 then bmpY:=0;
if (bmpx+ContentPanel.Width )> bmp.Width then
bmpx:=bmp.width-contentPanel.Width ;
if (bmpy+contentPanel.Height )>bmp.Height then
bmpy:=bmp.Height -contentPanel.Height ;
SourceRect:=REct(bmpx,bmpy,bmpx+ContentPanel.width,bmpy+contentPanel.height);
end;
end;

{前面计算了新位置之后即该重画，而不是要求系统帮助重画，不会有绘制太慢的问题//我在1024X768的全屏下该代码工作和ACDSEE一样流畅！}
With imgContent.Canvas do begin
CopyRect (DestRect,bmp.Canvas,SourceRect);
end;
OldPoint:=Point(x,y);
end;

Top

7 楼barton（）回复于 2000-01-15 19:08:00 得分 0

非常感谢，我决定改了。Top

8 楼barton（）回复于 2000-01-15 19:21:00 得分 0

我给不了分:-(

麻烦管理员给一下分：
venne 60;
kxy 40 :-)Top

9 楼zdg（曾登高）回复于 2000-01-16 13:48:00 得分 0

barton, 你再给一次好吗, 我改了给分程序的显示, 如果再出错会有更详细的信息了...Top

10 楼csdn（）回复于 2000-01-16 14:49:00 得分 0

终于抓住给分的Bug了, 谢谢barton...
你的分我已经代劳分发了...Top