BMShapedForm 改写到 Delphi 5 的问题。
照着一个用 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.