T
taozhiyu
Unregistered / Unconfirmed
GUEST, unregistred user!
发信人: laoduan (知耻者近乎勇), 信区: Delphi
标 题: 不规则窗口VCL控件源码
发信站: BBS 水木清华站 (Mon Jun 18 14:47:04 2001)
{ written by laoduan, you can distribute it as your wish }
unit FormShaper;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Forms, DsgnIntf;
type
// TFormShaper
TFormShaper = class(TComponent)
private
FBkgndBitmap: TBitmap;
FOwnerHandle: HWND;
FOldBorderStyle: TBorderStyle;
FOldClientWidth: Integer;
FOldClientHeight: Integer;
FHookInstance: Pointer;
FOldWindowProc: Pointer;
FOldWindowRgn: HRGN;
procedure HookWindowProc(var Message: TMessage);
procedure BkgndBitmapChange(Sender: TObject);
procedure SetBkgndBitmap(bitmap: TBitmap);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property BkgndBitmap: TBitmap read FBkgndBitmap write SetBkgndBitmap;
end;
// TFormShaperEditor
TFormShaperEditor = class(TDefaultEditor)
protected
procedure EditProperty(PropertyEditor: TPropertyEditor;
var Continue, FreeEditor: Boolean); override;
public
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): string; override;
function GetVerbCount: Integer; override;
end;
// procedure Register
procedure Register;
implementation
// procedure TFormShaper.HookWindowProc(var Message: TMessage);
procedure TFormShaper.HookWindowProc(var Message: TMessage);
var
Canvas: TCanvas;
begin
try
with Message do
begin
if FBkgndBitmap.Empty then
Result := CallWindowProc(FOldWindowProc, FOwnerHandle, Msg, WParam,
LParam)
else
case Msg of
WM_ERASEBKGND:
begin
Canvas := TCanvas.Create;
Canvas.Handle := HDC(WParam);
Canvas.Draw(0, 0, FBkgndBitmap);
Canvas.Free;
Result := LRESULT(True);
end;
WM_LBUTTONDOWN:
begin
ReleaseCapture;
SendMessage(FOwnerHandle, WM_NCLBUTTONDOWN, HTCAPTION, 0);
Result := LRESULT(False);
end;
else
Result := CallWindowProc(FOldWindowProc, FOwnerHandle, Msg, WParam,
LParam);
end;
end;
except
Application.HandleException(Self);
end;
end;
// function CreateRgnFromBitmap(rgnBitmap: TBitmap): HRGN;
function CreateRgnFromBitmap(rgnBitmap: TBitmap): HRGN;
var
transColor: TColor;
i, j: Integer;
width, height: Integer;
left, right: Integer;
rectRgn: HRGN;
begin
Result := 0; // NULL in C/C++
width := rgnBitmap.Width;
height := rgnBitmap.Height;
transColor := rgnBitmap.Canvas.Pixels[width - 1, height - 1];
for i := 0 to height - 1 do
begin
left := -1;
for j := 0 to width - 1 do
begin
if left < 0 then
begin
if rgnBitmap.Canvas.Pixels[j, i] <> transColor then
left := j;
end
else
if rgnBitmap.Canvas.Pixels[j, i] = transColor then
begin
right := j;
rectRgn := CreateRectRgn(left, i, right, i + 1);
if Result = 0 then
Result := rectRgn
else
begin
CombineRgn(Result, Result, rectRgn, RGN_OR);
DeleteObject(rectRgn);
end;
left := -1;
end;
end;
if left >= 0 then
begin
rectRgn := CreateRectRgn(left, i, width, i + 1);
if Result = 0 then
Result := rectRgn
else
begin
CombineRgn(Result, Result, rectRgn, RGN_OR);
DeleteObject(rectRgn);
end;
end;
end;
end;
// procedure TFormShaper.BkgndBitmapChange(Sender: TObject);
procedure TFormShaper.BkgndBitmapChange(Sender: TObject);
var
form: TForm;
windowRgn: HRGN;
begin
if Owner is TForm then
begin
form := TForm(Owner);
if FBkgndBitmap.Empty then
begin
form.BorderStyle := FOldBorderStyle;
form.ClientWidth := FOldClientWidth;
form.ClientHeight := FOldClientHeight;
SetWindowRgn(FOwnerHandle, FOldWindowRgn, True);
end
else
begin
form.BorderStyle := bsNone;
form.ClientWidth := FBkgndBitmap.Width;
form.ClientHeight := FBkgndBitmap.Height;
windowRgn := CreateRgnFromBitmap(FBkgndBitmap);
SetWindowRgn(FOwnerHandle, windowRgn, True);
end;
end;
end;
// procedure TFormShaper.SetBkgndBitmap(bitmap: TBitmap);
procedure TFormShaper.SetBkgndBitmap(bitmap: TBitmap);
begin
FBkgndBitmap.Assign(bitmap);
end;
// constructor TFormShaper.Create(AOwner: TComponent);
constructor TFormShaper.Create(AOwner: TComponent);
var
form: TForm;
begin
inherited Create(AOwner);
FBkgndBitmap := TBitmap.Create;
FBkgndBitmap.OnChange := BkgndBitmapChange;
FHookInstance := MakeObjectInstance(HookWindowProc);
if AOwner is TForm then
begin
form := TForm(AOwner);
FOldBorderStyle := form.BorderStyle;
FOldClientWidth := form.ClientWidth;
FOldClientHeight := form.ClientHeight;
FOwnerHandle := form.Handle;
FOldWindowProc := Pointer(GetWindowLong(FOwnerHandle, GWL_WNDPROC));
SetWindowLong(FOwnerHandle, GWL_WNDPROC, LongInt(FHookInstance));
GetWindowRgn(FOwnerHandle, FOldWindowRgn);
end;
end;
// destructor TFormShaper.Destroy;
destructor TFormShaper.Destroy;
var
form: TForm;
begin
if Owner is TForm then
begin
SetWindowLong(FOwnerHandle, GWL_WNDPROC, LongInt(FOldWindowProc));
form := TForm(Owner);
form.ClientWidth := FOldClientWidth;
form.ClientHeight := FOldClientHeight;
form.BorderStyle := FOldBorderStyle;
SetWindowRgn(FOwnerHandle, FOldWindowRgn, True);
end;
FreeObjectInstance(FHookInstance);
FBkgndBitmap.Free;
inherited Destroy;
end;
// procedure TFormShaperEditor.EditProperty
procedure TFormShaperEditor.EditProperty(PropertyEditor: TPropertyEditor;
var Continue, FreeEditor: Boolean);
var
PropName: string;
begin
PropName := PropertyEditor.GetName;
if (CompareText(PropName, 'BkgndBitmap') = 0) then
begin
PropertyEditor.Edit;
Continue := False;
end;
end;
// function TFormShaperEditor.GetVerbCount
function TFormShaperEditor.GetVerbCount: Integer;
begin
Result := 1;
end;
// function TFormShaperEditor.GetVerb
Index: Integer): string;
begin
if Index = 0 then
Result := 'Load Background Bitmap'
else Result := '';
end;
// procedure TFormShaperEditor.ExecuteVerb
procedure TFormShaperEditor.ExecuteVerb(Index: Integer);
begin
if Index = 0 then Edit;
end;
procedure Register;
begin
RegisterComponents('Samples', [TFormShaper]);
RegisterComponentEditor(TFormShaper, TFormShaperEditor);
end;
end.
--
侠女，其实我就是东方不败的师父---西方失败
多隆，给我备一匹最快的马，我有事要走先~~~
标 题: 不规则窗口VCL控件源码
发信站: BBS 水木清华站 (Mon Jun 18 14:47:04 2001)
{ written by laoduan, you can distribute it as your wish }
unit FormShaper;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Forms, DsgnIntf;
type
// TFormShaper
TFormShaper = class(TComponent)
private
FBkgndBitmap: TBitmap;
FOwnerHandle: HWND;
FOldBorderStyle: TBorderStyle;
FOldClientWidth: Integer;
FOldClientHeight: Integer;
FHookInstance: Pointer;
FOldWindowProc: Pointer;
FOldWindowRgn: HRGN;
procedure HookWindowProc(var Message: TMessage);
procedure BkgndBitmapChange(Sender: TObject);
procedure SetBkgndBitmap(bitmap: TBitmap);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property BkgndBitmap: TBitmap read FBkgndBitmap write SetBkgndBitmap;
end;
// TFormShaperEditor
TFormShaperEditor = class(TDefaultEditor)
protected
procedure EditProperty(PropertyEditor: TPropertyEditor;
var Continue, FreeEditor: Boolean); override;
public
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): string; override;
function GetVerbCount: Integer; override;
end;
// procedure Register
procedure Register;
implementation
// procedure TFormShaper.HookWindowProc(var Message: TMessage);
procedure TFormShaper.HookWindowProc(var Message: TMessage);
var
Canvas: TCanvas;
begin
try
with Message do
begin
if FBkgndBitmap.Empty then
Result := CallWindowProc(FOldWindowProc, FOwnerHandle, Msg, WParam,
LParam)
else
case Msg of
WM_ERASEBKGND:
begin
Canvas := TCanvas.Create;
Canvas.Handle := HDC(WParam);
Canvas.Draw(0, 0, FBkgndBitmap);
Canvas.Free;
Result := LRESULT(True);
end;
WM_LBUTTONDOWN:
begin
ReleaseCapture;
SendMessage(FOwnerHandle, WM_NCLBUTTONDOWN, HTCAPTION, 0);
Result := LRESULT(False);
end;
else
Result := CallWindowProc(FOldWindowProc, FOwnerHandle, Msg, WParam,
LParam);
end;
end;
except
Application.HandleException(Self);
end;
end;
// function CreateRgnFromBitmap(rgnBitmap: TBitmap): HRGN;
function CreateRgnFromBitmap(rgnBitmap: TBitmap): HRGN;
var
transColor: TColor;
i, j: Integer;
width, height: Integer;
left, right: Integer;
rectRgn: HRGN;
begin
Result := 0; // NULL in C/C++
width := rgnBitmap.Width;
height := rgnBitmap.Height;
transColor := rgnBitmap.Canvas.Pixels[width - 1, height - 1];
for i := 0 to height - 1 do
begin
left := -1;
for j := 0 to width - 1 do
begin
if left < 0 then
begin
if rgnBitmap.Canvas.Pixels[j, i] <> transColor then
left := j;
end
else
if rgnBitmap.Canvas.Pixels[j, i] = transColor then
begin
right := j;
rectRgn := CreateRectRgn(left, i, right, i + 1);
if Result = 0 then
Result := rectRgn
else
begin
CombineRgn(Result, Result, rectRgn, RGN_OR);
DeleteObject(rectRgn);
end;
left := -1;
end;
end;
if left >= 0 then
begin
rectRgn := CreateRectRgn(left, i, width, i + 1);
if Result = 0 then
Result := rectRgn
else
begin
CombineRgn(Result, Result, rectRgn, RGN_OR);
DeleteObject(rectRgn);
end;
end;
end;
end;
// procedure TFormShaper.BkgndBitmapChange(Sender: TObject);
procedure TFormShaper.BkgndBitmapChange(Sender: TObject);
var
form: TForm;
windowRgn: HRGN;
begin
if Owner is TForm then
begin
form := TForm(Owner);
if FBkgndBitmap.Empty then
begin
form.BorderStyle := FOldBorderStyle;
form.ClientWidth := FOldClientWidth;
form.ClientHeight := FOldClientHeight;
SetWindowRgn(FOwnerHandle, FOldWindowRgn, True);
end
else
begin
form.BorderStyle := bsNone;
form.ClientWidth := FBkgndBitmap.Width;
form.ClientHeight := FBkgndBitmap.Height;
windowRgn := CreateRgnFromBitmap(FBkgndBitmap);
SetWindowRgn(FOwnerHandle, windowRgn, True);
end;
end;
end;
// procedure TFormShaper.SetBkgndBitmap(bitmap: TBitmap);
procedure TFormShaper.SetBkgndBitmap(bitmap: TBitmap);
begin
FBkgndBitmap.Assign(bitmap);
end;
// constructor TFormShaper.Create(AOwner: TComponent);
constructor TFormShaper.Create(AOwner: TComponent);
var
form: TForm;
begin
inherited Create(AOwner);
FBkgndBitmap := TBitmap.Create;
FBkgndBitmap.OnChange := BkgndBitmapChange;
FHookInstance := MakeObjectInstance(HookWindowProc);
if AOwner is TForm then
begin
form := TForm(AOwner);
FOldBorderStyle := form.BorderStyle;
FOldClientWidth := form.ClientWidth;
FOldClientHeight := form.ClientHeight;
FOwnerHandle := form.Handle;
FOldWindowProc := Pointer(GetWindowLong(FOwnerHandle, GWL_WNDPROC));
SetWindowLong(FOwnerHandle, GWL_WNDPROC, LongInt(FHookInstance));
GetWindowRgn(FOwnerHandle, FOldWindowRgn);
end;
end;
// destructor TFormShaper.Destroy;
destructor TFormShaper.Destroy;
var
form: TForm;
begin
if Owner is TForm then
begin
SetWindowLong(FOwnerHandle, GWL_WNDPROC, LongInt(FOldWindowProc));
form := TForm(Owner);
form.ClientWidth := FOldClientWidth;
form.ClientHeight := FOldClientHeight;
form.BorderStyle := FOldBorderStyle;
SetWindowRgn(FOwnerHandle, FOldWindowRgn, True);
end;
FreeObjectInstance(FHookInstance);
FBkgndBitmap.Free;
inherited Destroy;
end;
// procedure TFormShaperEditor.EditProperty
procedure TFormShaperEditor.EditProperty(PropertyEditor: TPropertyEditor;
var Continue, FreeEditor: Boolean);
var
PropName: string;
begin
PropName := PropertyEditor.GetName;
if (CompareText(PropName, 'BkgndBitmap') = 0) then
begin
PropertyEditor.Edit;
Continue := False;
end;
end;
// function TFormShaperEditor.GetVerbCount
function TFormShaperEditor.GetVerbCount: Integer;
begin
Result := 1;
end;
// function TFormShaperEditor.GetVerb
Index: Integer): string;
begin
if Index = 0 then
Result := 'Load Background Bitmap'
else Result := '';
end;
// procedure TFormShaperEditor.ExecuteVerb
procedure TFormShaperEditor.ExecuteVerb(Index: Integer);
begin
if Index = 0 then Edit;
end;
procedure Register;
begin
RegisterComponents('Samples', [TFormShaper]);
RegisterComponentEditor(TFormShaper, TFormShaperEditor);
end;
end.
--
侠女，其实我就是东方不败的师父---西方失败
多隆，给我备一匹最快的马，我有事要走先~~~