BMShapedForm 改写到 Delphi 5 的问题。

Hooman 2000-01-26 06:49:00
照着一个用 c++ build 写的控件 BMShapedForm 用DELPHI 5 改写成下面的东东,但是总不能正确的将窗口变成和图片一样的不规则图形。而且不同的图片很容易
出内存错误。

哪位大虾帮忙看一下?

=================================================================
unit BMShapedForm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dia
logs,
ExtCtrls;

type
EParentError = class(Exception);
PColorArray = ^TColorArray;
TColorArray = array of TColor;

TBMShapedForm = class(TImage)
private
{ Private declarations }
FMoveable: Bool;
FMoveX: integer;
FMoveY: integer;

FImageHeight: integer;
FImageWidth: integer;

OldStretch: Bool;
OldAutoSize: Bool;
OldWidth: integer;
OldHeight: integer;

FRegion: HRGN;

MyParent: TBMShapedForm;

protected
{ Protected declarations }
procedure SetParent( Value: TWinControl ); virtual ;
procedure Loaded; virtual;
procedure Paint; virtual;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: i
nteger;
Y: integer); dynamic;
procedure MouseMove(Shift: TShiftState; X: integer;
Y: integer); dynamic;

procedure PictureUpdate(Sender: TObject);
procedure RefreshForm;
procedure ObtainRegion;
procedure AddRegion( x1: integer; x2: integer; y: integer );

public
{ Public declarations }
constructor Create( Owner: TComponent ); override;
destructor Destory;

published
{ Published declarations }
property Moveable: Bool read FMoveable write FMoveable default tru
e;
end;

procedure Register;

implementation
{$R *.DCR}

{ TBMShapedForm }
constructor TBMShapedForm.Create( Owner: TComponent );
begin
inherited Create(Owner);
Align:= alClient;
AutoSize:= false;
Stretch:= false;
OldAutoSize:= false;
FRegion:= 0;

Picture.OnChange:= PictureUpdate;
FMoveable:= true;
OldWidth:= 0;
OldHeight:= 0;
OldStretch:= false;

end;

destructor TBMShapedForm.Destory;
begin
if ( FRegion <> 0 ) then
begin
DeleteObject( FRegion );
end;
end;

procedure TBMShapedForm.SetParent( Value: TWinControl );
var
i: integer;
begin
inherited SetParent(Value);
if ( Value <> nil ) then
begin
if ( Value is TForm ) then
begin
// TForm(Value).BorderStyle:=bsNone
for i := 0 to Value.ControlCount do
begin
if (Value.Controls[ i ].ClassNameIs( 'TBMShapedForm' ) and ( V
alue.Controls[ i ] <> TControl( self ))) then
raise EParentError.Create('Please Drop only one TBMShapedFor
m per Form');
end;
end
else
begin
raise EParentError.Create('Please Drop on a Form');
end;
end;
end;

procedure TBMShapedForm.Loaded;
begin
inherited Loaded;
ObtainRegion;
RefreshForm;
end;

procedure TBMShapedForm.Paint;
begin
if ( not Picture.Bitmap.Empty ) then
begin
if ( OldAutoSize <> AutoSize ) then
begin
if ( not AutoSize and not Stretch ) then
begin
Stretch:= true;
OldStretch:= true;
end;

if ( AutoSize and Stretch ) then
begin
Stretch:= false;
OldStretch:= false;
end;
end;

if ( OldStretch <> Stretch ) then
begin
if ( Stretch and AutoSize ) then
AutoSize:= false;

if ( not Stretch and not AutoSize ) then
AutoSize:= true;

end;

if ( AutoSize ) then
if ( Stretch ) then
Stretch:= false;

if ( Stretch ) then
if ( AutoSize ) then
AutoSize:= false;

if ( not AutoSize and not Stretch ) then
AutoSize:= true;

OldStretch:= Stretch;
if (( OldAutoSize <> AutoSize ) or ( OldWidth <> Width ) or ( OldH
eight <> Height )) then
begin
PictureUpdate( self );
OldAutoSize:= AutoSize;
OldWidth:= Width;
OldHeight:= Height;
end;
end;

inherited Paint;

end;

procedure TBMShapedForm.MouseDown(Button: TMouseButton; Shift: TShiftS
tate; X: integer;
Y: integer);
begin
//这个函数似乎不执行?
inherited MouseDown( Button, Shift, X, Y );

FMoveX:= X;
FMoveY:= Y;

end;

procedure TBMShapedForm.MouseMove(Shift: TShiftState; X: integer;
Y: integer);
begin
//这个函数似乎不执行?
inherited MouseMove ( Shift, X, Y );

if ((FMoveable) and ( ssLeft in Shift )) then
begin
Parent.Left := Parent.Left + ( X - FMoveX);
Parent.Top := Parent.Top + ( Y - FMoveY);
Parent.Perform ( WM_PAINT,0,0 );
end;

end;

procedure TBMShapedForm.PictureUpdate(Sender: TObject);
begin
FRegion := 0;
if ( AutoSize ) then
begin
Parent.ClientWidth:= Picture.Width;
Parent.ClientHeight:= Picture.Height;
FImageWidth:= Picture.Width;
FImageHeight:= Picture.Height;
end
else
begin
FImageWidth:= Width;
FImageHeight:= Height;
end;


ObtainRegion;
RefreshForm;

end;

procedure TBMShapedForm.RefreshForm;
begin
if (( not( csDesigning in ComponentState )) and ( FRegion <> 0 )) th
en
SetWindowRgn ( Parent.Handle, FRegion, true );
end;

procedure TBMShapedForm.ObtainRegion;
var
ClientPos, ParentPos: TPoint;
RStart, REnd: Integer;
Bmp: TBitmap;
FTransparentColor: TColor;
i,j: Integer;
TheColor: TColor;
begin
if( csDesigning in ComponentState ) then
exit;

if( Picture.Bitmap.Empty ) then
exit;

if ( FRegion <> 0 ) then
DeleteObject(FRegion);

ClientPos := Parent.ClientToScreen ( Point ( 0, 0 ));

if ( Parent.Parent <> nil ) then
begin
ParentPos:= Parent.Parent.ClientToScreen ( Point ( Parent.Left, Pa
rent.Top ));
ClientPos.x:= ClientPos.x - ParentPos.x;
ClientPos.y:= ClientPos.y - ParentPos.y;
end
else
begin
ClientPos.x:= ClientPos.x - Parent.Left;
ClientPos.y:= ClientPos.y - Parent.Top;
end;



Bmp:= TBitmap.Create;
Bmp.Width:= FImageWidth;
Bmp.Height:= FImageHeight;

Bmp.Canvas.StretchDraw( Rect ( 0, 0, FImageWidth, FImageHeight ), Pi
cture.Bitmap );

Bmp.PixelFormat:= pf32bit;

//就是这里,还有下面一处地方很容易出内存错误。
FTransparentColor:= ( PColorArray( Bmp.ScanLine[ Picture.Height - 1
]))^[0];
for j:= 0 to Bmp.Height - 1 do
begin
RStart:= -1;
REnd:= -1;
for i:= 0 to Bmp.Width - 1 do
begin
//这里也是。不知这样写法对不对。
TheColor:= ( PColorArray( Bmp.ScanLine[ j ] ))^[ i ];
if ((( TheColor <> FTransparentColor ) or
( i = Bmp.Width - 1 )) and
( RStart = -1 )) then
begin
RStart := i;
end;

if ((( TheColor = FTransparentColor ) or
( i = Bmp.Width - 1 )) and
( RStart <> -1 )) then
begin
REnd := i - 1;
AddRegion( RStart, REnd, j );
RStart := -1;
end;
end;
end;

if ( FRegion = 0 ) then
OffsetRgn ( FRegion, ClientPos.x, ClientPos.y );

Bmp.Free;
end;

procedure TBMShapedForm.AddRegion( x1: integer; x2: integer; y: intege
r );
var
Aux: HRGN;
begin

if ( FRegion = 0 ) then
FRegion:= CreateRectRgn ( x1,y,x2+1,y+1 )
else
begin
Aux := CreateRectRgn (x1,y,x2+1,y+1);
CombineRgn( FRegion ,FRegion, Aux, RGN_OR);
DeleteObject ( Aux );
end;

end;

procedure Register;
begin
RegisterComponents('Sample', [TBMShapedForm]);
end;

end.

...全文
172 4 打赏 收藏 转发到动态 举报
写回复
用AI写文章
4 条回复
切换为时间正序
请发表友善的回复…
发表回复
Venne 2000-01-26
  • 打赏
  • 举报
回复
请下载这个控件,它即是计算不规则窗口的控件。里面有源码,可以看到
你的代码需要改动的地方。

http://best.163.com/~venne/download/component/coolform.zip
kxy 2000-01-26
  • 打赏
  • 举报
回复
1) warning没有什么,你可以这样,编译后用鼠标点waring的信息,然后按F1就
可以看到help
2)还是自己想把. 处理WM_SIZE消息.
kxy 2000-01-26
  • 打赏
  • 举报
回复
1)mousemove,mousedown的声明中使用override;不要用dynamic;
2)FTransparentColor:= ( PColorArray( Bmp.ScanLine[ Picture.Height - 1
]))^[0];
Picure的hight如果比Bmp的Height大,就越界了.
3)取得颜色可以直接使用, bmp.Canvas.Pixels[x,y];
4)不能正确的将窗口变成和图片一样的不规则图形,是算法的问题,自己
研究一下吧.
Hooman 2000-01-26
  • 打赏
  • 举报
回复

我改成下面这样了,似乎一切OK! 除了一点小问题。假如图片是拉申了的,我怎么才能
按照他拉申后的尺寸来设置窗口形状呢?

另,编译时有WARNING
[Warning] BMShapedForm.pas(31): Method 'SetParent' hides virtual method of base type 'TControl'
[Warning] BMShapedForm.pas(32): Method 'Loaded' hides virtual method of base type 'TControl'
[Warning] BMShapedForm.pas(33): Method 'Paint' hides virtual method of base type 'TImage'
这些有关系么?如果我这几个方法用 override 似乎会出错。

==========================================================================
FTransparentColor:= Bmp.Canvas.Pixels[ 0, Bmp.Height - 1 ];
for j:= 0 to Bmp.Height - 1 do
begin
RStart:= -1;
for i:= 0 to Bmp.Width - 1 do
begin
TheColor:= Bmp.Canvas.Pixels[ i, j ];
if ((( TheColor <> FTransparentColor ) or
( i = Bmp.Width - 1 )) and
( RStart = -1 )) then
begin
RStart := i;
end;

if ((( TheColor = FTransparentColor ) or
( i = Bmp.Width - 1 )) and
( RStart <> -1 )) then
begin
REnd := i - 1;
AddRegion( RStart, REnd, j );
RStart := -1;
end;
end;
end;

if ( FRegion = 0 ) then
OffsetRgn ( FRegion, ClientPos.x, ClientPos.y );

Bmp.Free;

5,379

社区成员

发帖
与我相关
我的任务
社区描述
Delphi 开发及应用
社区管理员
  • VCL组件开发及应用社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧