A
Another_eYes
Unregistered / Unconfirmed
GUEST, unregistred user!
[源码分享]实用控件五：不规则形状窗口控件，可将form或panel甚至Edit,Memo转成加载的bmp的形状，还可以在运行时自由拖动和改变大小 ( 积分: 0 )<br />unit中包含两个控件：
一个可视控件(TRgnForm)，放入容器（form, panel等）内设置属性可以将容器控件转成加载的bmp的形状。
另一个是不可视控件(TImgBorder)，可以关联到任意TWinControl上，除了改变该WinControl控件的形状外还可以通过设置属性支持在运行时通过拖动鼠标改变其大小。
两个控件中保存的bmp都使用zlib压缩后才存储到dfm, 可以尽可能减小exe的尺寸。
压缩保存用到的FileRes.pas源码在这里列出：
http://www.delphibbs.com/delphibbs/dispq.asp?lid=3263037
TRgnForm相关属性说明：
AutoDrag: Boolean --> 是否能够通过拖动鼠标同时拖动form/panel
BkBmp: TBitmap --> 背景图片，form/panel等将变成这个图片的形状
TransColor: TColor --> 指定图片的透明色如果是clNone的话透明色=图片左下角的颜色
DesignEffect: Boolean --> 是否在设计期显示效果（包括拖动效果）
TImgBorder相关属性说明：
FaceStyle: TFaceStyle -->
fsNone: 不生成内部GraphicControl
fsDesignTime: 只在设计器生成内部GraphicControl作为背景图片的载体
fsRunTime: 在设计期和运行期都使用内部GraphicControl作为背景图片的载体（因为除了form外其它WinControl控件不能通过WM_ERASEBKGND消息画上背景图片,所以需要一个Align=alClient的控件作为背景图片的载体）
SetAsBkgnd: Boolean --> 将图片设置成背景（通过WM_ERASEBKGND画背景，只对form有效）
BkImage: TBitmap --> 指定的WinControl将根据该图片改变形状
NosizeLeft: Integer --> BkImage中左侧不能自由改变大小的宽度（自由改变后形状可能很难看）
NosizeTop: Integer --> BkImage中上部不能自由改变大小的高度
NoSizeRight: Integer --> BkImage中右侧不能自由改变大小的宽度
NoSizeBottom: Integer --> BkImage中下部不能自由改变大小的高度
Control: TWinControl --> 需要改变形状的控件，可以从列表中选择，如果是form的话需要手工输入form的Name
Active: Boolean --> 是否起作用
AffectNC: Boolean --> 改变控件形状时是否包含原控件的边框部分（比如form的CaptionBar），如果不包括将只按照Client部分的大小计算形状
TransColor: TColor --> 透明色，如果为clNone则取图片的左下角作为透明色
HookHitTest: Boolean --> 是否允许通过拖动鼠标改变窗口大小和位置（=true的话同时影响设计期）
HTTestLSize: Integer --> 能够接受鼠标在此区域拖动就改变窗口左边大小的宽度
HTTestTSize: Integer --> 能够接受鼠标在此区域拖动就改变窗口上边大小的高度
HTTestRSize: Integer --> 能够接受鼠标在此区域拖动就改变窗口右边大小的宽度
HTTestBSize: Integer --> 能够接受鼠标在此区域拖动就改变窗口下边大小的高度
HTTestTitle: Integer --> 能够接受鼠标在此区域拖动同时移动窗口的上边高度
MinimizeBtn: TControl --> 指定最小化按钮，可以选择任意Control作为最小化按钮，指定之后将自动截取该Control.OnClick事件并在点击该Control时最小化窗口（只针对form）
MaximizeBtn: TControl --> 指定最大化按钮，可以选择任意Control作为最大化按钮，指定之后将自动截取该Control.OnClick事件并在点击该Control时最大化窗口（只针对form）
CloseBtn: TControl --> 指定关闭按钮，可以选择任意Control作为关闭按钮，指定之后将自动截取该Control.OnClick事件并在点击该Control时关闭窗口（只针对form）
源代码中还包含几个优化过的将bmp(或者Canvas上内容)转成region的函数
unit RgnForm;
interface
uses
SysUtils, Classes, Windows, Messages, Forms, Controls, Graphics, FileRes;
type
TRgnForm = class(TGraphicControl)
private
{ Private declarations }
FRgnData: PRgnDataHeader;
FBkBmp: TBitmap;
FTransColor: TColor;
FDesignEffect: Boolean;
FAutoDrag: Boolean;
procedure WriteRgnData(Writer: TStream);
procedure ReadRgnData(Reader: TStream);
procedure BmpChanged(Sender: TObject);
procedure SetBkBmp(const Value: TBitmap);
procedure SetTransColor(const Value: TColor);
procedure SetDesignEffect(const Value: Boolean);
procedure CMDesignHitTest(var Message: TMessage); message CM_DESIGNHITTEST;
protected
{ Protected declarations }
procedure DefineProperties(Filer: TFiler); override;
procedure Paint; override;
procedure AdjustSize; override;
procedure Loaded; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
public
{ Public declarations }
constructor Create(AComponent: TComponent); override;
destructor Destroy; override;
procedure ResetRgn;
procedure SetParent(AParent: TWinControl); override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
{ Published declarations }
property AutoDrag: Boolean read FAutoDrag write FAutoDrag;
property BkBmp: TBitmap read FBkBmp write SetBkBmp stored False;
property TransColor: TColor read FTransColor write SetTransColor;
property DesignEffect: Boolean read FDesignEffect write SetDesignEffect stored False;
property Align;
property Anchors;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;
TDesignImgBdrFace = class(TGraphicControl)
private
//procedure CMDesignHitTest(var Message: TMessage); message CM_DESIGNHITTEST;
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
end;
TFaceStyle = (fsNone, fsDesignTime, fsRunTime);
TImgBorder = class(TComponent)
private
{ Private declarations }
FRgns: array [0..8] of PRgnDataHeader;
FRects: array [0..8] of TRect;
FSrcs: array [0..8] of TRect;
FNosizes: array [0..3] of Integer;
FHits: array [0..4] of Integer;
FBtns: array [0..2] of TControl;
FHookHitTest: Boolean;
FActive: Boolean;
FAffectNC: Boolean;
FBkImage: TBitmap;
FTransColor: TColor;
FControl: TWinControl;
FOldWndProc: TWndMethod;
FAnalyzed: Boolean;
FOldBS: TBrushStyle;
FOldBC: TColor;
FDesignFace: TDesignImgBdrFace;
FSetAsBkgnd: Boolean;
FFaceStyle: TFaceStyle;
procedure ImgChanged(Sender: TObject);
procedure SaveRgns(Writer: TStream);
procedure LoadRgns(Reader: TStream);
function BuildRgn: HRGN;
procedure PaintNCBdr;
function CheckHitTest(Pt: TPoint; DefRst: Integer): Integer;
procedure drawBk(DC: HDC; OffX, OffY: Integer);
function GetPartRgn(Index: Integer): HRGN;
procedure AnalyzeRgns;
function CheckDesignHitTest(Pt: TPoint): Integer;
procedure ClickSysBtn(Sender: TObject);
function IsSysBtn(x, y: Integer): Boolean;
procedure SetActive(const Value: Boolean);
procedure SetAffectNC(const Value: Boolean);
procedure SetBkImage(const Value: TBitmap);
procedure SetControl(const Value: TWinControl);
procedure SetHitTestSize(const Index, Value: Integer);
procedure SetNosizeValue(const Index, Value: Integer);
procedure SetTransColor(const Value: TColor);
procedure SetFaceStyle(const Value: TFaceStyle);
procedure SetSetAsBkgnd(const Value: Boolean);
procedure SetBtns(const Index: Integer; const Value: TControl);
protected
{ Protected declarations }
procedure DefineProperties(Filer: TFiler); override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure NewWndProc(var Message: TMessage); virtual;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure PaintBk(DC: HDC);
published
{ Published declarations }
property FaceStyle: TFaceStyle read FFaceStyle write SetFaceStyle;
property SetAsBkgnd: Boolean read FSetAsBkgnd write SetSetAsBkgnd;
property BkImage: TBitmap read FBkImage write SetBkImage stored False;
property NosizeLeft: Integer index 0 read FNosizes[0] write SetNosizeValue;
property NosizeTop: Integer index 1 read FNosizes[1] write SetNosizeValue;
property NoSizeRight: Integer index 2 read FNosizes[2] write SetNosizeValue;
property NoSizeBottom: Integer index 3 read FNosizes[3] write SetNosizeValue;
property Control: TWinControl read FControl write SetControl;
property Active: Boolean read FActive write SetActive;
property AffectNC: Boolean read FAffectNC write SetAffectNC;
property TransColor: TColor read FTransColor write SetTransColor;
property HookHitTest: Boolean read FHookHitTest write FHookHitTest;
property HTTestLSize: Integer index 0 read FHits[0] write SetHitTestSize;
property HTTestTSize: Integer index 1 read FHits[1] write SetHitTestSize;
property HTTestRSize: Integer index 2 read FHits[2] write SetHitTestSize;
property HTTestBSize: Integer index 3 read FHits[3] write SetHitTestSize;
property HTTestTitle: Integer index 4 read FHits[4] write SetHitTestSize;
property MinimizeBtn: TControl index 0 read FBtns[0] write SetBtns;
property MaximizeBtn: TControl index 1 read FBtns[1] write SetBtns;
property CloseBtn: TControl index 2 read FBtns[2] write SetBtns;
end;
function CreateRgnFromMask(Msk: HBITMAP; x, y: Integer): HRGN;
function CreateRgnFromHBmp(DC: HDC; Left, top, width, height: Integer; TransColor: TColor; x, y: Integer): HRGN;
function CreateRgnFromBmp(Bmp: TBitmap; TransColor: TColor; x, y: Integer): HRGN;
function RgnDataToRgn(RgnH: PRgnDataHeader; Left, Top: Integer; AutoFree: Boolean = True): HRGN;
function CreateRgnDataFromMask(Msk: HBITMAP): PRgnDataHeader;
function CreateRgnDataFromHBmp(DC: HDC; Left, Top, Width, Height: Integer; TransColor: TColor): PRgnDataHeader;
function CreateRgnDataFromBmp(Bmp: TBitmap; TransColor: TColor): PRgnDataHeader;
function ResizeRgnData(Dt: PRgnDataHeader; DeltaX, DeltaY: Double): PRgnDataHeader;
function ResizeRgnDataToRgn(dt: PRgnDataHeader; DeltaX, DeltaY: Double; Left, Top: Integer): HRGN;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TRgnForm, TImgBorder]);
end;
function CreateRgnDataFromBmpBits(Bits: Pointer; Width, Height, Gap: Integer): PRgnDataHeader;
var
Rct: TRect;
i, l: Integer;
RgnH: PRgnDataHeader;
MaxLen: Integer;
p, p1: PByte;
b, e: Byte;
LineP, LastP: PRect;
procedure ResizeRects;
var
p: PRect;
begin
p := LineP;
while Integer(p) < Integer(LastP) do
begin
Inc(p^.Bottom);
Inc(p);
end;
Inc(RgnH^.rcBound.Bottom);
end;
procedure NewRectInStruct(x, y: Integer);
var
i, j: Integer;
begin
if Integer(LastP) >= Integer(RgnH) + MaxLen then
begin
i := Integer(LastP) - Integer(RgnH);
j := Integer(LineP) - Integer(RgnH);
Inc(maxLen, 4096);
ReAllocMem(RgnH, MaxLen);
LastP := Pointer(Integer(RgnH) + i);
LineP := Pointer(Integer(RgnH) + j);
end;
Inc(RgnH^.nCount);
with LastP^ do
begin
Left := x;
Top := y;
Right := x + 1;
Bottom := y + 1;
if Left < RgnH^.rcBound.Left then
RgnH^.rcBound.Left := Left;
if Top < RgnH^.rcBound.Top then
RgnH^.rcBound.Top := Top;
if Right > RgnH^.rcBound.Right then
RgnH^.rcBound.Right := Right;
if Bottom > RgnH^.rcBound.Bottom then
RgnH^.rcBound.Bottom := Bottom;
end;
end;
function IsScanLineEmpty(v: PByte): Boolean;
var
i: Integer;
begin
if l < 0 then
Result := (v^ or b) = $ff
else begin
Result := v^ or b = $ff;
if not Result then Exit;
Inc(v);
for i := 0 to l - 1 do
begin
Result := Result and (v^ = $ff);
if not Result then Exit;
Inc(v);
end;
Result := v^ or e = $ff;
end;
end;
function SameScanLine(v, v1: PByte): Boolean;
begin
Result := (v^ or b) = (v1^ or b);
if not Result then Exit;
if l < 0 then Exit;
Inc(v);
Inc(v1);
if l > 0 then
Result := CompareMem(v, v1, l);
if not Result then Exit;
Inc(v, l);
Inc(v1, l);
Result := v^ or e = v1^ or e;
end;
procedure ScanLineToRects(n: Integer; v: PByte);
var
i, j, x: Integer;
f: Boolean;
begin
LineP := LastP;
f := False;
x := Rct.Left and $fffffff8;
for i := 0 to 7 do
if $80 shr i and (v^ or b) = 0 then
if f then Inc(LastP^.Right)
else begin
NewRectInStruct(x + i, n);
f := True;
end
else if f then
begin
f := False;
Inc(LastP);
end;
if l >= 0 then
begin
Inc(v);
Inc(x, 8);
for i := 0 to l-1 do
begin
if v^ and $ff = $ff then
if f then begin
f := False;
Inc(LastP);
end
else
else if v^ and $ff = 0 then
if f then
Inc(LastP^.Right, 8)
else begin
f := True;
NewRectInStruct(x, n);
Inc(LastP^.Right, 7);
end
else
for j := 0 to 7 do
if ($80 shr j) and v^ = 0 then
if f then
Inc(LastP^.Right)
else begin
f := True;
NewRectInStruct(x + j, n);
end
else if f then
begin
f := False;
Inc(LastP);
end;
Inc(v);
Inc(x, 8);
end;
for i := 0 to 7 do
if $80 shr i and (v^ or e) = 0 then
if f then Inc(LastP^.Right)
else begin
NewRectInStruct(x + i, n);
f := True;
end
else if f then
begin
f := False;
Inc(LastP);
end;
end;
if f then Inc(LastP);
if Integer(LastP) > Integer(LineP) then
with PRect(Integer(LastP)-16)^ do
if Right > RgnH^.rcBound.Right then
RgnH^.rcBound.Right := Right;
end;
begin
Rct := Rect(0,0,Width, abs(Height));
if IsRectEmpty(Rct) then
begin
Result := nil;
Exit;
end;
MaxLen := SizeOf(_RGNDATAHEADER);
GetMem(RgnH, MaxLen);
LastP := Pointer(Integer(RgnH) + MaxLen);
RgnH^.dwSize := MaxLen;
RgnH^.iType := RDH_RECTANGLES;
RgnH^.nCount := 0;
with RgnH^.rcBound do
begin
Left := Rct.Right + 1;
Top := Rct.Bottom + 1;
Right := Rct.Left - 1;
Bottom := Rct.Top - 1;
end;
l := (Rct.Right - Rct.Left) shr 3;
if Rct.Left mod 8 <> 0 then Inc(l);
if Rct.Right mod 8 <> 0 then Inc(l);
Dec(l, 2);
if height > 0 then
begin
p := pointer(integer(bits)+(height-1)*gap);
gap := -gap;
end
else
p := bits;
p1 := p;
b := $ff shl (8 - Rct.Left mod 8);
e := $ff shr ((Rct.Right-1) mod 8 + 1);
if l < 0 then
b := b or e;
ScanLineToRects(Rct.Top, p);
p := Pointer(Integer(p) + gap);
for i := Rct.Top + 1 to Rct.Bottom - 1 do
begin
if not IsScanLineEmpty(p) then
if SameScanLine(p, p1) then
ResizeRects
else
ScanLineToRects(i, p);
p := Pointer(Integer(p) + gap);
p1 := Pointer(Integer(p1) + gap);
end;
result := RgnH;
end;
function CreateRgnDataFromAlphaBits(Bits: Pointer; Width, Height, Gap: Integer): PRgnDataHeader;
begin
end;
procedure GetRgnBorderData(Rgn: PRgnDataHeader; Offset: Integer; var LineTL, SizeTL, LintBR, SizeBR: Pointer; var CntTL, CntBR: Integer);
begin
end;
function ResizeRgnData(Dt: PRgnDataHeader; DeltaX, DeltaY: Double): PRgnDataHeader;
var
p, p1: PRect;
i: Integer;
begin
getmem(result, dt.nCount * sizeof(TRect) + sizeof(TRgnDataHeader));
move(dt^, result^, sizeof(TRgnDataHeader));
result^.rcBound := rect(round(dt.rcBound.Left * DeltaX), round(dt.rcBound.Top * DeltaY), round(dt.rcBound.Right * DeltaX), round(dt.rcBound.Bottom * DeltaY));
p := pointer(Integer(dt) + sizeof(TRgnDataHeader));
p1 := pointer(integer(result)+sizeof(TRgnDataHeader));
for i := 0 to dt.nCount - 1 do
begin
p1^ := rect(round(p.Left * DeltaX), round(p.Top * DeltaY), round(p.Right * DeltaX), round(p.Bottom * DeltaY));
inc(p);
inc(p1);
end;
end;
function ResizeRgnDataToRgn(dt: PRgnDataHeader; DeltaX, DeltaY: Double; Left, Top: Integer): HRGN;
begin
result := rgndatatorgn(resizergndata(dt, deltax, deltay), left, top, true);
end;
function RgnDataToRgn(RgnH: PRgnDataHeader; Left, Top: Integer; AutoFree: Boolean = True): HRGN;
begin
if (RgnH = nil) or IsRectEmpty(RgnH^.rcBound) then
Result := CreateRectRgn(-2, -2, -1, -1)
else begin
RgnH^.nRgnSize := RgnH^.nCount * 16;
Result := ExtCreateRegion(nil, RgnH^.nRgnSize + SizeOf(_RGNDATAHEADER),
PRgnData(Integer(RgnH))^);
offsetrgn(result, left, top);
end;
if (RgnH <> nil) and autofree then
FreeMem(RgnH);
end;
function CreateRgnFromMask(Msk: HBITMAP; x, y: Integer): HRGN;
begin
result := rgndatatorgn(creatergndatafrommask(msk), x, y);
end;
function CreateRgnDataFromMask(Msk: HBITMAP): PRgnDataHeader;
var
Info: PBitmapInfo;
Bits: Pointer;
InfoSize, ImgSize: DWORD;
DS: TDIBSection;
DC: HDC;
Gap: Integer;
begin
if msk = 0 then
begin
result := nil;
exit;
end;
infosize := sizeof(TBitmapInfo)+256*sizeof(TRGBQuad);
GetObject(Msk, sizeof(ds), @ds);
info := allocmem(infosize);
fillchar(info^, sizeof(TBitmapInfo), #0);
with info^.bmiHeader do
begin
bisize := sizeof(TBitmapInfoHeader);
biWidth := ds.dsBm.bmWidth;
biheight := ds.dsBm.bmHeight;
biplanes := 1;
bibitcount := 1;
gap := bytesperscanline(biwidth, 1, 32);
imgsize := gap * abs(biheight);
bits := allocmem(imgsize);
dc := createcompatibledc(0);
getdibits(dc, msk, 0, biheight, bits, info^, DIB_RGB_COLORS);
deletedc(dc);
result := creatergndatafromBmpbits(bits, biwidth, biheight, Gap);
end;
freemem(info, infosize);
freemem(bits, imgsize);
end;
function CreateRgnFromHBmp(DC: HDC; Left, Top, width, height: Integer; TransColor: TColor; x, y: Integer): HRGN;
begin
result := RgnDataToRgn(CreateRgnDataFromHBmp(DC, Left, Top, Width, Height, TransColor), x, y);
end;
function CreateRgnDataFromHBmp(DC: HDC; Left, Top, Width, Height: Integer; TransColor: TColor): PRgnDataHeader;
var
monoDC : HDC;
MonoImg: HBITMAP;
sav: THandle;
begin
if (width = 0) or (height = 0) then
begin
result := nil;
exit;
end;
monodc := createcompatibledc(0);
monoimg := createbitmap(width, height, 1, 1, nil);
sav := selectobject(monodc, monoimg);
setbkcolor(dc, colortorgb(transcolor));
bitblt(monodc, 0, 0, width, height, dc, Left, Top, SRCCOPY);
selectobject(monodc, sav);
deletedc(monodc);
result := creatergndatafrommask(monoimg);
deleteobject(monoimg);
end;
function CreateRgnFromBmp(Bmp: TBitmap; TransColor: TColor; x, y: Integer): HRGN;
begin
result := RgnDataToRgn(CreateRgnDataFromBmp(Bmp, TransColor), x, y);
end;
function CreateRgnDataFromBmp(Bmp: TBitmap; TransColor: TColor): PRgnDataHeader;
var
monoDC, ScreenDC: HDC;
MonoImg: HBITMAP;
sav: THandle;
begin
if (bmp.Width=0) or (bmp.Height = 0) then
begin
result := nil;
exit;
end;
screendc := getdc(0);
monodc := createcompatibledc(screendc);
monoimg := createbitmap(bmp.width, bmp.height, 1, 1, nil);
sav := selectobject(monodc, monoimg);
setbkcolor(bmp.canvas.handle, colortorgb(transcolor));
bitblt(monodc, 0, 0, bmp.width, bmp.height, bmp.canvas.handle, 0, 0, SRCCOPY);
selectobject(monodc, sav);
deletedc(monodc);
releasedc(0, screendc);
result := creatergndatafrommask(monoimg);
deleteobject(monoimg);
end;
{ TRgnForm }
constructor TRgnForm.Create(AComponent: TComponent);
begin
inherited;
FBkBmp := TBitmap.Create;
FBkBmp.OnChange := BmpChanged;
FTransColor := clNone;
AutoSize := True;
end;
destructor TRgnForm.Destroy;
begin
if frgndata <> nil then
freemem(frgndata);
FBkBmp.Free;
inherited;
end;
procedure TRgnForm.BmpChanged(Sender: TObject);
var
c: TColor;
begin
if not (csLoading in ComponentState) then
begin
if frgndata <> nil then
begin
freemem(frgndata);
frgndata := nil;
end;
if (fbkbmp.Width<>0) and (fbkbmp.Height<>0) then
begin
if ftranscolor = clNone then
c := fbkbmp.Canvas.Pixels[0, fbkbmp.Height-1]
else
c := ftranscolor;
frgndata := creatergndatafrombmp(fbkbmp, c);
if (parent<>nil) and parent.HandleAllocated then
resetrgn;
adjustsize;
end;
end;
end;
procedure TRgnForm.DefineProperties(Filer: TFiler);
begin
inherited;
filer.DefineBinaryProperty('RgnData', ReadRgnData, WriteRgnData, FRgnData<>nil);
end;
procedure TRgnForm.Paint;
begin
Canvas.Draw(0, 0, fbkbmp);
end;
procedure TRgnForm.ReadRgnData(Reader: TStream);
var
Stm: TBufferStream;
l: Integer;
begin
stm := TBufferStream.Create;
stm.LoadFromStream(reader);
stm.Read(l, 4);
getmem(frgndata, l);
if l > 0 then
begin
stm.Read(frgndata^, l);
end;
bkbmp.LoadFromStream(stm);
stm.Free;
end;
procedure TRgnForm.WriteRgnData(Writer: TStream);
var
Stm: TBufferStream;
l: Integer;
begin
stm := TBufferStream.Create;
l := length(string(frgndata)) and $7FFFFFF8;
stm.Write(l, 4);
if l > 0 then
stm.Write(frgndata^, l);
fbkbmp.SaveToStream(stm);
stm.SaveToStream(writer);
stm.Free;
end;
procedure TRgnForm.SetBkBmp(const Value: TBitmap);
begin
FBkBmp.Assign(value);
end;
procedure TRgnForm.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
moved: Boolean;
begin
moved := (ALeft <> Left) or (ATop <> Top);
if (fbkbmp.Width<>0) and (fbkbmp.Height<>0) then
inherited setbounds(aleft, atop, fbkbmp.Width, fbkbmp.Height)
else
inherited setbounds(aleft, atop, awidth, aheight);
if moved then
resetrgn;
end;
procedure TRgnForm.SetParent(AParent: TWinControl);
begin
inherited;
resetrgn;
end;
procedure TRgnForm.SetTransColor(const Value: TColor);
begin
if FTransColor <> Value then
begin
FTransColor := Value;
bmpchanged(self);
end;
end;
procedure TRgnForm.SetDesignEffect(const Value: Boolean);
begin
if FDesignEffect <> Value then
begin
FDesignEffect := Value;
resetrgn;
end;
end;
procedure TRgnForm.ResetRgn;
var
r: HRGN;
rct: TRect;
begin
if (parent<>nil) then
begin
if not parent.HandleAllocated then
parent.HandleNeeded;
if parent.HandleAllocated then
if (frgndata = nil) or ((csDesigning in ComponentState) and not FDesignEffect) then
setwindowrgn(parent.Handle, 0, true)
else begin
rct := Rect(0, 0, Parent.Width, Parent.Height);
parent.Perform(WM_NCCALCSIZE, 0, Integer(@rct));
r := rgndatatorgn(frgndata, rct.Left+Left, rct.Top+Top, false);
setwindowrgn(parent.Handle, r, true);
end;
end;
end;
procedure TRgnForm.AdjustSize;
begin
if csLoading in ComponentState then exit;
if (fbkbmp.Width<>0) and (fbkbmp.Height <> 0) then
setbounds(left, top, fbkbmp.Width, fbkbmp.Height)
else
setbounds(left, top, width, Height);
end;
procedure TRgnForm.Loaded;
begin
inherited;
resetrgn;
end;
procedure TRgnForm.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if (Button = mbLeft) and FAutoDrag then
begin
releasecapture;
parent.perform(WM_SYSCOMMAND, $f012, 0);
end;
end;
procedure TRgnForm.CMDesignHitTest(var Message: TMessage);
begin
inherited;
if FDesignEffect then
message.Result := 1;
end;
{ TImgBorder }
constructor TImgBorder.Create(AOwner: TComponent);
begin
inherited;
ftranscolor := clNone;
fbkimage := TBitmap.Create;
fbkimage.OnChange := imgchanged;
end;
destructor TImgBorder.Destroy;
var
i: Integer;
begin
if fcontrol <> nil then
begin
fcontrol.WindowProc := foldwndproc;
if fcontrol.HandleAllocated and factive then
begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
setwindowrgn(fcontrol.Handle, 0, true);
end;
fcontrol := nil;
end;
for i := 0 to 8 do
if frgns <> nil then
dispose(frgns);
fbkimage.Free;
inherited;
end;
procedure TImgBorder.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineBinaryProperty('RgnData', LoadRgns, SaveRgns, not FBkImage.Empty);
end;
procedure TImgBorder.LoadRgns(Reader: TStream);
var
stm: TBufferStream;
i, l: Integer;
begin
stm := TBufferStream.Create;
stm.LoadFromStream(reader);
for i := 0 to 8 do
begin
stm.Read(l, 4);
if l > 0 then
begin
getmem(frgns, l);
stm.Read(frgns^, l);
end
else frgns := nil;
end;
fbkimage.LoadFromStream(stm);
stm.Free;
end;
procedure TImgBorder.SaveRgns(Writer: TStream);
var
stm: TBufferStream;
i, l: Integer;
begin
stm := TBufferStream.Create;
for i := 0 to 8 do
begin
if frgns <> nil then
l := frgns.nCount * sizeof(TRect)+sizeof(TRgnDataHeader)
else l := 0;
//l := length(string(frgns)) and $7FFFFFF8;
stm.Write(l, 4);
if l > 0 then
stm.Write(frgns^, l);
end;
fbkimage.SaveToStream(stm);
stm.SaveToStream(writer);
stm.Free;
end;
type
TWinControlRef = class(TControl)
public
FAlignLevel: Word;
FBevelEdges: TBevelEdges;
FBevelInner: TBevelCut;
FBevelOuter: TBevelCut;
FBevelKind: TBevelKind;
FBevelWidth: TBevelWidth;
FBorderWidth: TBorderWidth;
FBrush: TBrush;
FDefWndProc: Pointer;
FDockClients: TList;
FDockManager: IDockManager;
FHandle: HWnd;
FImeMode: TImeMode;
FImeName: TImeName;
FObjectInstance: Pointer;
FParentWindow: HWnd;
FTabList: TList;
FControls: TList;
FWinControls: TList;
end;
procedure TImgBorder.NewWndProc(var Message: TMessage);
var
n: Integer;
begin
if fcontrol<>nil then
begin
if factive then
case message.Msg of
WM_NCCREATE:
begin
setwindowrgn(fcontrol.Handle, BuildRgn, true);
fcontrol.Invalidate;
end;
WM_NCPAINT:
if FAffectNC then
PaintNCBdr;
WM_WINDOWPOSCHANGING:
with PWindowPos(message.LParam)^ do
begin
foldwndproc(message);
if (flags and (SWP_NOSIZE or SWP_SHOWWINDOW or SWP_HIDEWINDOW) = 0) then
begin
if cx < fnosizes[0]+fnosizes[2] then
cx := fnosizes[0]+fnosizes[2];
if cy < fnosizes[1]+fnosizes[3] then
cy := fnosizes[1]+fnosizes[3];
end;
message.Result := 0;
exit;
end;
WM_NCHITTEST:
if FHookHitTest then
begin
foldwndproc(message);
if message.Result in [HTCLIENT, HTBORDER] then
message.Result := CheckHitTest(point(message.LParamLo, message.LParamHi), message.Result);
exit;
end;
WM_SIZE:
begin
setwindowrgn(fcontrol.Handle, BuildRgn, true);
fcontrol.Invalidate;
end;
WM_ERASEBKGND:
if FSetAsBkgnd then
PaintBk(message.WParam);
WM_PAINT:
if (fdesignface <> nil) then
with TWinControlRef(fcontrol) do
if (fcontrols.Count > 0) and (fcontrols[0] <> pointer(fdesignface)) then
begin
n := fcontrols.IndexOf(pointer(fdesignface));
if n > 0 then
fcontrols.Delete
;
fcontrols.Insert(0, pointer(fdesignface));
end;
CM_DESIGNHITTEST:
begin
foldwndproc(message);
if message.Result = 0 then
if IsSysBtn(message.LParamLo, message.LParamHi) or
(CheckDesignHitTest(point(message.LParamLo, message.LParamHi)) <> HTCLIENT) then
message.Result := 1;
exit;
end;
end;
foldwndproc(message);
end;
end;
type
TControlRef = class(TControl);
procedure TImgBorder.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if (operation = opRemove) then
if AComponent = FDesignFace then
begin
FDesignFace := nil
end
else if (AComponent = FControl) then
begin
{fcontrol.WindowProc := foldwndproc;
if fcontrol.HandleAllocated and factive then
begin
if fsetasbkgnd then
begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
end;
setwindowrgn(fcontrol.Handle, 0, true);
end;
if fdesignface <> nil then
freeandnil(fdesignface);}
control := nil;
end
else if AComponent = FBtns[0] then
begin
TControlRef(FBtns[0]).OnClick := nil;
FBtns[0] := nil;
end
else if AComponent = FBtns[1] then
begin
TControlRef(FBtns[1]).OnClick := nil;
FBtns[1] := nil;
end
else if AComponent = FBtns[2] then
begin
TControlRef(FBtns[2]).OnClick := nil;
FBtns[2] := nil;
end
end;
procedure TImgBorder.SetActive(const Value: Boolean);
begin
if FActive <> Value then
begin
FActive := Value;
if (fcontrol <> nil) then
if value then
begin
if fsetasbkgnd then
begin
foldbs := fcontrol.Brush.Style;
foldbc := fcontrol.Brush.Color;
fcontrol.Brush.Style := bsClear;
end;
if fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
if (ffacestyle = fsRunTime) or ((ffacestyle = fsDesignTime) and (csDesigning in ComponentState)) then
begin
FDesignFace := TDesignImgBdrFace.Create(self);
FDesignFace.FreeNotification(self);
FDesignFace.Parent := fcontrol;
fcontrol.DoubleBuffered := true;
FDesignFace.Align := alClient;
FDesignFace.Visible := true;
end;
end
else begin
if fsetasbkgnd then
begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
end;
if fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, 0, true);
fcontrol.Invalidate;
end;
if FDesignFace <> nil then
FreeAndNil(FDesignFace);
end;
end;
end;
procedure TImgBorder.SetAffectNC(const Value: Boolean);
begin
if FAffectNC <> Value then
begin
FAffectNC := Value;
if (fcontrol <> nil) and fcontrol.HandleAllocated then
if factive then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
end;
end;
procedure TImgBorder.SetBkImage(const Value: TBitmap);
begin
FBkImage.Assign(value);
end;
procedure TImgBorder.SetControl(const Value: TWinControl);
begin
if FControl <> Value then
begin
if fcontrol <> nil then
begin
fcontrol.WindowProc := foldwndproc;
if (fcontrol is TCustomForm) and ((FBtns[0] <> nil) or (FBtns[1] <> nil) or (FBtns[2] <> nil)) then
begin
if FBtns[0] <> nil then
TControlRef(FBtns[0]).OnClick := nil;
if FBtns[1] <> nil then
TControlRef(FBtns[1]).OnClick := nil;
if FBtns[2] <> nil then
TControlRef(FBtns[2]).OnClick := nil;
end;
if fcontrol.HandleAllocated then
begin
if fsetasbkgnd then
begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
end;
setwindowrgn(fcontrol.Handle, 0, true);
end;
if FDesignFace <> nil then
freeandnil(fdesignface);
end;
FControl := Value;
if fcontrol <> nil then
begin
foldwndproc := fcontrol.WindowProc;
fcontrol.WindowProc := NewWndProc;
if fcontrol is TCustomForm then
begin
if FBtns[0] <> nil then
TControlRef(FBtns[0]).OnClick := ClickSysBtn;
if FBtns[1] <> nil then
TControlRef(FBtns[1]).OnClick := ClickSysBtn;
if FBtns[2] <> nil then
TControlRef(FBtns[2]).OnClick := ClickSysBtn;
end;
if factive then
begin
if fsetasbkgnd then
begin
foldbs := fcontrol.Brush.Style;
foldbc := fcontrol.Brush.Color;
fcontrol.Brush.Style := bsClear;
end;
if fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
if (ffacestyle = fsRunTime) or ((ffacestyle = fsDesignTime) and (csDesigning in ComponentState)) then
begin
FDesignFace := TDesignImgBdrFace.Create(self);
FDesignFace.FreeNotification(self);
FDesignFace.Parent := fcontrol;
fcontrol.DoubleBuffered := true;
FDesignFace.Align := alClient;
FDesignFace.Visible := true;
end;
end;
end;
end;
end;
procedure TImgBorder.SetHitTestSize(const Index, Value: Integer);
begin
FHits[Index] := Value;
end;
procedure TImgBorder.SetNosizeValue(const Index, Value: Integer);
begin
if (FNosizes[Index] <> Value) and (value >= 0) then
begin
FNosizes[Index] := Value;
FAnalyzed := false;
if (fcontrol<>nil) and factive and fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
end;
end;
procedure TImgBorder.SetTransColor(const Value: TColor);
begin
if FTransColor <> Value then
begin
FTransColor := Value;
FAnalyzed := false;
if (fcontrol<>nil) and factive and fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
end;
end;
procedure TImgBorder.ImgChanged(Sender: TObject);
begin
FAnalyzed := false;
if (fcontrol<>nil) and factive and fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
end;
function TImgBorder.BuildRgn: HRGN;
var
Rct: TRect;
r: HRGN;
i: Integer;
begin
//if not FAnalyzed then
analyzergns;
getwindowrect(fcontrol.Handle, rct);
offsetrect(rct, -rct.left, -rct.Top);
if not faffectnc then
fcontrol.Perform(WM_NCCALCSIZE, 0, Integer(@Rct));
frects[0] := bounds(rct.Left, rct.Top, fnosizes[0], fnosizes[1]);
frects[1] := bounds(rct.Right - fnosizes[2], rct.Top, fnosizes[2], fnosizes[1]);
frects[2] := bounds(rct.Right - fnosizes[2], rct.Bottom - fnosizes[3], fnosizes[2], fnosizes[3]);
frects[3] := bounds(rct.Left, rct.Bottom - fnosizes[3], fnosizes[0], fnosizes[3]);
frects[4] := rect(frects[0].right, frects[0].Top, frects[1].left, frects[0].bottom);
frects[5] := rect(frects[1].left, frects[1].bottom, frects[1].right, frects[2].top);
frects[6] := rect(frects[3].right, frects[3].top, frects[2].left, frects[3].bottom);
frects[7] := rect(frects[0].left, frects[0].bottom, frects[0].right, frects[3].top);
frects[8] := rect(frects[0].right, frects[0].bottom, frects[2].left, frects[2].top);
result := 0;
for i := 0 to 8 do
begin
r := getpartrgn(i);
if r <> 0 then
begin
if result <> 0 then
begin
combinergn(result, result, r, RGN_OR);
deleteobject(r);
end
else result := r;
end;
end;
end;
function TImgBorder.GetPartRgn(Index: Integer): HRGN;
begin
result := 0;
if frgns[index] <> nil then
if index < 4 then
result := rgndatatorgn(frgns[index], frects[index].Left, frects[index].Top, false)
else
result := resizergndatatorgn(frgns[index],
(frects[index].Right - frects[index].Left) / (fsrcs[index].Right - fsrcs[index].Left),
(frects[index].Bottom - frects[index].Top) / (fsrcs[index].Bottom - fsrcs[index].Top),
frects[index].Left, frects[index].Top);
end;
function TImgBorder.CheckHitTest(Pt: TPoint; DefRst: Integer): Integer;
var
rct: TRect;
c: TControl;
begin
if (fcontrol is TCustomForm) and (TForm(fcontrol).WindowState = wsMaximized) then
begin
result := DefRst;
exit;
end;
getwindowrect(fcontrol.Handle, rct);
dec(pt.X, rct.Left);
dec(pt.Y, rct.Top);
if ptinrect(rect(frects[0].Left, frects[0].Top, frects[1].Right, frects[0].Top+fHits[1]), pt) then
result := HTTOP
else if ptinrect(rect(frects[0].Left, frects[0].Top, frects[0].Left+fhits[0], frects[3].Bottom), pt) then
result := HTLEFT
else if ptinrect(rect(frects[1].Right - fhits[2], frects[1].Top, frects[1].Right, frects[2].Bottom), pt) then
result := HTRIGHT
else if ptinrect(rect(frects[0].Left, frects[3].Bottom-fhits[3], frects[1].Right, frects[3].Bottom), pt) then
result := HTBOTTOM
else if ptinrect(rect(frects[0].Left, frects[0].Top, frects[1].Right, frects[0].Top+fhits[4]), pt) then
begin
offsetrect(rct, -rct.Left, -rct.Top);
fcontrol.Perform(WM_NCCALCSIZE, 0, Integer(@Rct));
dec(pt.X, rct.Left);
dec(pt.Y, rct.Top);
c := fcontrol.ControlAtPos(pt, false);
if (c = nil) or (c = fdesignface) then
result := HTCAPTION
else
result := DefRst;
end
else result := DefRst;
end;
procedure TImgBorder.PaintBk(DC: HDC);
var
rct: TRect;
begin
getwindowrect(fcontrol.Handle, rct);
offsetrect(rct, -rct.left, -rct.Top);
//if faffectnc then
fcontrol.Perform(WM_NCCALCSIZE, 0, Integer(@Rct));
drawbk(dc, -rct.Left, -rct.Top);
end;
procedure TImgBorder.drawBk(DC: HDC; OffX, OffY: Integer);
var
i: Integer;
begin
for i := 0 to 8 do
if not isrectempty(frects) then
stretchblt(dc, frects.Left+offx, frects.Top+offy, frects.Right - frects.Left,
frects.Bottom - frects.Top, fbkimage.Canvas.Handle, fsrcs.Left,
fsrcs.Top, fsrcs.Right - fsrcs.Left, fsrcs.Bottom - fsrcs.Top,
SRCCOPY);
end;
procedure TImgBorder.PaintNCBdr;
var
rct: TRect;
dc: HDC;
begin
if faffectnc then
begin
getwindowrect(fcontrol.Handle, rct);
offsetrect(rct, -rct.Left, -rct.Top);
dc := getwindowdc(fcontrol.Handle);
fcontrol.Perform(WM_NCCALCSIZE, 0, Integer(@Rct));
if excludecliprect(dc, rct.Left, rct.Top, rct.Right, rct.Bottom) <> NULLREGION then
drawbk(dc, 0, 0);
releasedc(fcontrol.Handle, dc);
end;
end;
procedure TImgBorder.AnalyzeRgns;
var
i: Integer;
c: TColor;
begin
if not fanalyzed then
begin
c := ftranscolor;
for i := 0 to 8 do
begin
if frgns <> nil then
begin
dispose(frgns);
frgns := nil;
end;
fsrcs := rect(0,0,0,0);
end;
if not fbkimage.Empty then
begin
if c = clNone then
c := fbkimage.Canvas.Pixels[0, fbkimage.Height - 1];
fsrcs[0] := rect(0, 0, fnosizes[0], fnosizes[1]);
fsrcs[1] := bounds(fbkimage.Width - fnosizes[2], 0, fnosizes[2], fnosizes[1]);
fsrcs[2] := bounds(fbkimage.Width - fnosizes[2], fbkimage.Height - fnosizes[3], fnosizes[2], fnosizes[3]);
fsrcs[3] := bounds(0, fbkimage.Height - fnosizes[3], fnosizes[0], fnosizes[3]);
fsrcs[4] := bounds(fnosizes[0], 0, fbkimage.Width - fnosizes[0] - fnosizes[2], fnosizes[1]);
fsrcs[5] := bounds(fbkimage.Width - fnosizes[2], fnosizes[1], fnosizes[2], fbkimage.Height - fnosizes[1] - fnosizes[3]);
fsrcs[6] := bounds(fnosizes[0], fbkimage.Height - fnosizes[3], fbkimage.Width - fnosizes[0] - fnosizes[2], fnosizes[3]);
fsrcs[7] := bounds(0, fnosizes[1], fnosizes[0], fbkimage.Height - fnosizes[1]- fnosizes[3]);
fsrcs[8] := bounds(fnosizes[0], fnosizes[1], fbkimage.Width - fnosizes[0] - fnosizes[2], fbkimage.Height - fnosizes[1] - fnosizes[3]);
end;
for i := 0 to 8 do
if not isrectempty(fsrcs) then
frgns := creatergndatafromhbmp(fbkimage.Canvas.Handle, fsrcs.Left, fsrcs.Top, fsrcs.Right - fsrcs.Left,
fsrcs.Bottom - fsrcs.Top, c);
fanalyzed := true;
end;
end;
function TImgBorder.CheckDesignHitTest(Pt: TPoint): Integer;
var
c: TControl;
begin
c := fcontrol.ControlAtPos(pt, true, true);
if (c = nil) or (c = fdesignface) then
result := checkhittest(fcontrol.ClientToScreen(pt), HTCLIENT)
else result := HTCLIENT;
end;
procedure TImgBorder.SetFaceStyle(const Value: TFaceStyle);
begin
if FFaceStyle <> Value then
begin
FFaceStyle := Value;
if (value = fsRunTime) or ((value = fsDesignTime) and (csDesigning in ComponentState)) then
begin
if (fcontrol<>nil) and active and fcontrol.HandleAllocated and (fdesignface = nil) then
begin
fdesignface := TDesignImgBdrFace.Create(self);
fdesignface.FreeNotification(self);
fcontrol.DoubleBuffered := true;
fdesignface.Parent := fcontrol;
fdesignface.Align := alClient;
fdesignface.Visible := true;
end;
end
else if fdesignface <> nil then
freeandnil(fdesignface);
end;
end;
procedure TImgBorder.SetSetAsBkgnd(const Value: Boolean);
begin
if FSetAsBkgnd <> Value then
begin
FSetAsBkgnd := Value;
if (fcontrol <> nil) and factive then
if value then
begin
foldbs := fcontrol.Brush.Style;
foldbc := fcontrol.Brush.Color;
fcontrol.Brush.Style := bsClear;
end
else begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
end;
end;
end;
procedure TImgBorder.SetBtns(const Index: Integer; const Value: TControl);
begin
if FBtns[Index] <> Value then
begin
if (FBtns[Index] <> nil) and (FControl is TCustomForm) then
TControlRef(FBtns[Index]).OnClick := nil;
FBtns[Index] := Value;
if (FBtns[Index] <> nil) and (FControl is TCustomForm) then
TControlRef(FBtns[Index]).OnClick := ClickSysBtn;
end;
end;
procedure TImgBorder.ClickSysBtn(Sender: TObject);
begin
if fcontrol is TCustomForm then
if Sender = FBtns[0] then // min
if application.MainForm = fcontrol then
application.Minimize
else TForm(fcontrol).WindowState := wsMinimized
else if Sender = FBtns[1] then // max
if TForm(fcontrol).WindowState = wsMaximized then
TForm(fcontrol).WindowState := wsNormal
else
TForm(fcontrol).WindowState := wsMaximized
else if Sender = FBtns[2] then // close
TForm(fcontrol).Close;
end;
function TImgBorder.IsSysBtn(x, y: Integer): Boolean;
var
c: TControl;
begin
result := false;
if fcontrol is TCustomForm then
begin
c := fcontrol.ControlAtPos(point(x, y), false, true);
if c <> nil then
result := (c = fbtns[0]) or (c = fbtns[1]) or (c = fbtns[2]);
end;
end;
{ TDesignImgBdrFace }
constructor TDesignImgBdrFace.Create(AOwner: TComponent);
begin
inherited;
controlstyle := [csNoStdEvents];
self.SetSubComponent(true);
end;
{procedure TDesignImgBdrFace.CMDesignHitTest(var Message: TMessage);
begin
if TImgBorder(Owner).CheckDesignHitTest(point(Message.LParamLo, Message.LParamHi)) <> HTCLIENT then
message.Result := 1
else message.Result := 0;
end;}
procedure TDesignImgBdrFace.Paint;
begin
if (parent<>nil) then
TImgBorder(Owner).PaintBk(Canvas.Handle);
end;
end.
一个可视控件(TRgnForm)，放入容器（form, panel等）内设置属性可以将容器控件转成加载的bmp的形状。
另一个是不可视控件(TImgBorder)，可以关联到任意TWinControl上，除了改变该WinControl控件的形状外还可以通过设置属性支持在运行时通过拖动鼠标改变其大小。
两个控件中保存的bmp都使用zlib压缩后才存储到dfm, 可以尽可能减小exe的尺寸。
压缩保存用到的FileRes.pas源码在这里列出：
http://www.delphibbs.com/delphibbs/dispq.asp?lid=3263037
TRgnForm相关属性说明：
AutoDrag: Boolean --> 是否能够通过拖动鼠标同时拖动form/panel
BkBmp: TBitmap --> 背景图片，form/panel等将变成这个图片的形状
TransColor: TColor --> 指定图片的透明色如果是clNone的话透明色=图片左下角的颜色
DesignEffect: Boolean --> 是否在设计期显示效果（包括拖动效果）
TImgBorder相关属性说明：
FaceStyle: TFaceStyle -->
fsNone: 不生成内部GraphicControl
fsDesignTime: 只在设计器生成内部GraphicControl作为背景图片的载体
fsRunTime: 在设计期和运行期都使用内部GraphicControl作为背景图片的载体（因为除了form外其它WinControl控件不能通过WM_ERASEBKGND消息画上背景图片,所以需要一个Align=alClient的控件作为背景图片的载体）
SetAsBkgnd: Boolean --> 将图片设置成背景（通过WM_ERASEBKGND画背景，只对form有效）
BkImage: TBitmap --> 指定的WinControl将根据该图片改变形状
NosizeLeft: Integer --> BkImage中左侧不能自由改变大小的宽度（自由改变后形状可能很难看）
NosizeTop: Integer --> BkImage中上部不能自由改变大小的高度
NoSizeRight: Integer --> BkImage中右侧不能自由改变大小的宽度
NoSizeBottom: Integer --> BkImage中下部不能自由改变大小的高度
Control: TWinControl --> 需要改变形状的控件，可以从列表中选择，如果是form的话需要手工输入form的Name
Active: Boolean --> 是否起作用
AffectNC: Boolean --> 改变控件形状时是否包含原控件的边框部分（比如form的CaptionBar），如果不包括将只按照Client部分的大小计算形状
TransColor: TColor --> 透明色，如果为clNone则取图片的左下角作为透明色
HookHitTest: Boolean --> 是否允许通过拖动鼠标改变窗口大小和位置（=true的话同时影响设计期）
HTTestLSize: Integer --> 能够接受鼠标在此区域拖动就改变窗口左边大小的宽度
HTTestTSize: Integer --> 能够接受鼠标在此区域拖动就改变窗口上边大小的高度
HTTestRSize: Integer --> 能够接受鼠标在此区域拖动就改变窗口右边大小的宽度
HTTestBSize: Integer --> 能够接受鼠标在此区域拖动就改变窗口下边大小的高度
HTTestTitle: Integer --> 能够接受鼠标在此区域拖动同时移动窗口的上边高度
MinimizeBtn: TControl --> 指定最小化按钮，可以选择任意Control作为最小化按钮，指定之后将自动截取该Control.OnClick事件并在点击该Control时最小化窗口（只针对form）
MaximizeBtn: TControl --> 指定最大化按钮，可以选择任意Control作为最大化按钮，指定之后将自动截取该Control.OnClick事件并在点击该Control时最大化窗口（只针对form）
CloseBtn: TControl --> 指定关闭按钮，可以选择任意Control作为关闭按钮，指定之后将自动截取该Control.OnClick事件并在点击该Control时关闭窗口（只针对form）
源代码中还包含几个优化过的将bmp(或者Canvas上内容)转成region的函数
unit RgnForm;
interface
uses
SysUtils, Classes, Windows, Messages, Forms, Controls, Graphics, FileRes;
type
TRgnForm = class(TGraphicControl)
private
{ Private declarations }
FRgnData: PRgnDataHeader;
FBkBmp: TBitmap;
FTransColor: TColor;
FDesignEffect: Boolean;
FAutoDrag: Boolean;
procedure WriteRgnData(Writer: TStream);
procedure ReadRgnData(Reader: TStream);
procedure BmpChanged(Sender: TObject);
procedure SetBkBmp(const Value: TBitmap);
procedure SetTransColor(const Value: TColor);
procedure SetDesignEffect(const Value: Boolean);
procedure CMDesignHitTest(var Message: TMessage); message CM_DESIGNHITTEST;
protected
{ Protected declarations }
procedure DefineProperties(Filer: TFiler); override;
procedure Paint; override;
procedure AdjustSize; override;
procedure Loaded; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
public
{ Public declarations }
constructor Create(AComponent: TComponent); override;
destructor Destroy; override;
procedure ResetRgn;
procedure SetParent(AParent: TWinControl); override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
{ Published declarations }
property AutoDrag: Boolean read FAutoDrag write FAutoDrag;
property BkBmp: TBitmap read FBkBmp write SetBkBmp stored False;
property TransColor: TColor read FTransColor write SetTransColor;
property DesignEffect: Boolean read FDesignEffect write SetDesignEffect stored False;
property Align;
property Anchors;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;
TDesignImgBdrFace = class(TGraphicControl)
private
//procedure CMDesignHitTest(var Message: TMessage); message CM_DESIGNHITTEST;
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
end;
TFaceStyle = (fsNone, fsDesignTime, fsRunTime);
TImgBorder = class(TComponent)
private
{ Private declarations }
FRgns: array [0..8] of PRgnDataHeader;
FRects: array [0..8] of TRect;
FSrcs: array [0..8] of TRect;
FNosizes: array [0..3] of Integer;
FHits: array [0..4] of Integer;
FBtns: array [0..2] of TControl;
FHookHitTest: Boolean;
FActive: Boolean;
FAffectNC: Boolean;
FBkImage: TBitmap;
FTransColor: TColor;
FControl: TWinControl;
FOldWndProc: TWndMethod;
FAnalyzed: Boolean;
FOldBS: TBrushStyle;
FOldBC: TColor;
FDesignFace: TDesignImgBdrFace;
FSetAsBkgnd: Boolean;
FFaceStyle: TFaceStyle;
procedure ImgChanged(Sender: TObject);
procedure SaveRgns(Writer: TStream);
procedure LoadRgns(Reader: TStream);
function BuildRgn: HRGN;
procedure PaintNCBdr;
function CheckHitTest(Pt: TPoint; DefRst: Integer): Integer;
procedure drawBk(DC: HDC; OffX, OffY: Integer);
function GetPartRgn(Index: Integer): HRGN;
procedure AnalyzeRgns;
function CheckDesignHitTest(Pt: TPoint): Integer;
procedure ClickSysBtn(Sender: TObject);
function IsSysBtn(x, y: Integer): Boolean;
procedure SetActive(const Value: Boolean);
procedure SetAffectNC(const Value: Boolean);
procedure SetBkImage(const Value: TBitmap);
procedure SetControl(const Value: TWinControl);
procedure SetHitTestSize(const Index, Value: Integer);
procedure SetNosizeValue(const Index, Value: Integer);
procedure SetTransColor(const Value: TColor);
procedure SetFaceStyle(const Value: TFaceStyle);
procedure SetSetAsBkgnd(const Value: Boolean);
procedure SetBtns(const Index: Integer; const Value: TControl);
protected
{ Protected declarations }
procedure DefineProperties(Filer: TFiler); override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure NewWndProc(var Message: TMessage); virtual;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure PaintBk(DC: HDC);
published
{ Published declarations }
property FaceStyle: TFaceStyle read FFaceStyle write SetFaceStyle;
property SetAsBkgnd: Boolean read FSetAsBkgnd write SetSetAsBkgnd;
property BkImage: TBitmap read FBkImage write SetBkImage stored False;
property NosizeLeft: Integer index 0 read FNosizes[0] write SetNosizeValue;
property NosizeTop: Integer index 1 read FNosizes[1] write SetNosizeValue;
property NoSizeRight: Integer index 2 read FNosizes[2] write SetNosizeValue;
property NoSizeBottom: Integer index 3 read FNosizes[3] write SetNosizeValue;
property Control: TWinControl read FControl write SetControl;
property Active: Boolean read FActive write SetActive;
property AffectNC: Boolean read FAffectNC write SetAffectNC;
property TransColor: TColor read FTransColor write SetTransColor;
property HookHitTest: Boolean read FHookHitTest write FHookHitTest;
property HTTestLSize: Integer index 0 read FHits[0] write SetHitTestSize;
property HTTestTSize: Integer index 1 read FHits[1] write SetHitTestSize;
property HTTestRSize: Integer index 2 read FHits[2] write SetHitTestSize;
property HTTestBSize: Integer index 3 read FHits[3] write SetHitTestSize;
property HTTestTitle: Integer index 4 read FHits[4] write SetHitTestSize;
property MinimizeBtn: TControl index 0 read FBtns[0] write SetBtns;
property MaximizeBtn: TControl index 1 read FBtns[1] write SetBtns;
property CloseBtn: TControl index 2 read FBtns[2] write SetBtns;
end;
function CreateRgnFromMask(Msk: HBITMAP; x, y: Integer): HRGN;
function CreateRgnFromHBmp(DC: HDC; Left, top, width, height: Integer; TransColor: TColor; x, y: Integer): HRGN;
function CreateRgnFromBmp(Bmp: TBitmap; TransColor: TColor; x, y: Integer): HRGN;
function RgnDataToRgn(RgnH: PRgnDataHeader; Left, Top: Integer; AutoFree: Boolean = True): HRGN;
function CreateRgnDataFromMask(Msk: HBITMAP): PRgnDataHeader;
function CreateRgnDataFromHBmp(DC: HDC; Left, Top, Width, Height: Integer; TransColor: TColor): PRgnDataHeader;
function CreateRgnDataFromBmp(Bmp: TBitmap; TransColor: TColor): PRgnDataHeader;
function ResizeRgnData(Dt: PRgnDataHeader; DeltaX, DeltaY: Double): PRgnDataHeader;
function ResizeRgnDataToRgn(dt: PRgnDataHeader; DeltaX, DeltaY: Double; Left, Top: Integer): HRGN;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TRgnForm, TImgBorder]);
end;
function CreateRgnDataFromBmpBits(Bits: Pointer; Width, Height, Gap: Integer): PRgnDataHeader;
var
Rct: TRect;
i, l: Integer;
RgnH: PRgnDataHeader;
MaxLen: Integer;
p, p1: PByte;
b, e: Byte;
LineP, LastP: PRect;
procedure ResizeRects;
var
p: PRect;
begin
p := LineP;
while Integer(p) < Integer(LastP) do
begin
Inc(p^.Bottom);
Inc(p);
end;
Inc(RgnH^.rcBound.Bottom);
end;
procedure NewRectInStruct(x, y: Integer);
var
i, j: Integer;
begin
if Integer(LastP) >= Integer(RgnH) + MaxLen then
begin
i := Integer(LastP) - Integer(RgnH);
j := Integer(LineP) - Integer(RgnH);
Inc(maxLen, 4096);
ReAllocMem(RgnH, MaxLen);
LastP := Pointer(Integer(RgnH) + i);
LineP := Pointer(Integer(RgnH) + j);
end;
Inc(RgnH^.nCount);
with LastP^ do
begin
Left := x;
Top := y;
Right := x + 1;
Bottom := y + 1;
if Left < RgnH^.rcBound.Left then
RgnH^.rcBound.Left := Left;
if Top < RgnH^.rcBound.Top then
RgnH^.rcBound.Top := Top;
if Right > RgnH^.rcBound.Right then
RgnH^.rcBound.Right := Right;
if Bottom > RgnH^.rcBound.Bottom then
RgnH^.rcBound.Bottom := Bottom;
end;
end;
function IsScanLineEmpty(v: PByte): Boolean;
var
i: Integer;
begin
if l < 0 then
Result := (v^ or b) = $ff
else begin
Result := v^ or b = $ff;
if not Result then Exit;
Inc(v);
for i := 0 to l - 1 do
begin
Result := Result and (v^ = $ff);
if not Result then Exit;
Inc(v);
end;
Result := v^ or e = $ff;
end;
end;
function SameScanLine(v, v1: PByte): Boolean;
begin
Result := (v^ or b) = (v1^ or b);
if not Result then Exit;
if l < 0 then Exit;
Inc(v);
Inc(v1);
if l > 0 then
Result := CompareMem(v, v1, l);
if not Result then Exit;
Inc(v, l);
Inc(v1, l);
Result := v^ or e = v1^ or e;
end;
procedure ScanLineToRects(n: Integer; v: PByte);
var
i, j, x: Integer;
f: Boolean;
begin
LineP := LastP;
f := False;
x := Rct.Left and $fffffff8;
for i := 0 to 7 do
if $80 shr i and (v^ or b) = 0 then
if f then Inc(LastP^.Right)
else begin
NewRectInStruct(x + i, n);
f := True;
end
else if f then
begin
f := False;
Inc(LastP);
end;
if l >= 0 then
begin
Inc(v);
Inc(x, 8);
for i := 0 to l-1 do
begin
if v^ and $ff = $ff then
if f then begin
f := False;
Inc(LastP);
end
else
else if v^ and $ff = 0 then
if f then
Inc(LastP^.Right, 8)
else begin
f := True;
NewRectInStruct(x, n);
Inc(LastP^.Right, 7);
end
else
for j := 0 to 7 do
if ($80 shr j) and v^ = 0 then
if f then
Inc(LastP^.Right)
else begin
f := True;
NewRectInStruct(x + j, n);
end
else if f then
begin
f := False;
Inc(LastP);
end;
Inc(v);
Inc(x, 8);
end;
for i := 0 to 7 do
if $80 shr i and (v^ or e) = 0 then
if f then Inc(LastP^.Right)
else begin
NewRectInStruct(x + i, n);
f := True;
end
else if f then
begin
f := False;
Inc(LastP);
end;
end;
if f then Inc(LastP);
if Integer(LastP) > Integer(LineP) then
with PRect(Integer(LastP)-16)^ do
if Right > RgnH^.rcBound.Right then
RgnH^.rcBound.Right := Right;
end;
begin
Rct := Rect(0,0,Width, abs(Height));
if IsRectEmpty(Rct) then
begin
Result := nil;
Exit;
end;
MaxLen := SizeOf(_RGNDATAHEADER);
GetMem(RgnH, MaxLen);
LastP := Pointer(Integer(RgnH) + MaxLen);
RgnH^.dwSize := MaxLen;
RgnH^.iType := RDH_RECTANGLES;
RgnH^.nCount := 0;
with RgnH^.rcBound do
begin
Left := Rct.Right + 1;
Top := Rct.Bottom + 1;
Right := Rct.Left - 1;
Bottom := Rct.Top - 1;
end;
l := (Rct.Right - Rct.Left) shr 3;
if Rct.Left mod 8 <> 0 then Inc(l);
if Rct.Right mod 8 <> 0 then Inc(l);
Dec(l, 2);
if height > 0 then
begin
p := pointer(integer(bits)+(height-1)*gap);
gap := -gap;
end
else
p := bits;
p1 := p;
b := $ff shl (8 - Rct.Left mod 8);
e := $ff shr ((Rct.Right-1) mod 8 + 1);
if l < 0 then
b := b or e;
ScanLineToRects(Rct.Top, p);
p := Pointer(Integer(p) + gap);
for i := Rct.Top + 1 to Rct.Bottom - 1 do
begin
if not IsScanLineEmpty(p) then
if SameScanLine(p, p1) then
ResizeRects
else
ScanLineToRects(i, p);
p := Pointer(Integer(p) + gap);
p1 := Pointer(Integer(p1) + gap);
end;
result := RgnH;
end;
function CreateRgnDataFromAlphaBits(Bits: Pointer; Width, Height, Gap: Integer): PRgnDataHeader;
begin
end;
procedure GetRgnBorderData(Rgn: PRgnDataHeader; Offset: Integer; var LineTL, SizeTL, LintBR, SizeBR: Pointer; var CntTL, CntBR: Integer);
begin
end;
function ResizeRgnData(Dt: PRgnDataHeader; DeltaX, DeltaY: Double): PRgnDataHeader;
var
p, p1: PRect;
i: Integer;
begin
getmem(result, dt.nCount * sizeof(TRect) + sizeof(TRgnDataHeader));
move(dt^, result^, sizeof(TRgnDataHeader));
result^.rcBound := rect(round(dt.rcBound.Left * DeltaX), round(dt.rcBound.Top * DeltaY), round(dt.rcBound.Right * DeltaX), round(dt.rcBound.Bottom * DeltaY));
p := pointer(Integer(dt) + sizeof(TRgnDataHeader));
p1 := pointer(integer(result)+sizeof(TRgnDataHeader));
for i := 0 to dt.nCount - 1 do
begin
p1^ := rect(round(p.Left * DeltaX), round(p.Top * DeltaY), round(p.Right * DeltaX), round(p.Bottom * DeltaY));
inc(p);
inc(p1);
end;
end;
function ResizeRgnDataToRgn(dt: PRgnDataHeader; DeltaX, DeltaY: Double; Left, Top: Integer): HRGN;
begin
result := rgndatatorgn(resizergndata(dt, deltax, deltay), left, top, true);
end;
function RgnDataToRgn(RgnH: PRgnDataHeader; Left, Top: Integer; AutoFree: Boolean = True): HRGN;
begin
if (RgnH = nil) or IsRectEmpty(RgnH^.rcBound) then
Result := CreateRectRgn(-2, -2, -1, -1)
else begin
RgnH^.nRgnSize := RgnH^.nCount * 16;
Result := ExtCreateRegion(nil, RgnH^.nRgnSize + SizeOf(_RGNDATAHEADER),
PRgnData(Integer(RgnH))^);
offsetrgn(result, left, top);
end;
if (RgnH <> nil) and autofree then
FreeMem(RgnH);
end;
function CreateRgnFromMask(Msk: HBITMAP; x, y: Integer): HRGN;
begin
result := rgndatatorgn(creatergndatafrommask(msk), x, y);
end;
function CreateRgnDataFromMask(Msk: HBITMAP): PRgnDataHeader;
var
Info: PBitmapInfo;
Bits: Pointer;
InfoSize, ImgSize: DWORD;
DS: TDIBSection;
DC: HDC;
Gap: Integer;
begin
if msk = 0 then
begin
result := nil;
exit;
end;
infosize := sizeof(TBitmapInfo)+256*sizeof(TRGBQuad);
GetObject(Msk, sizeof(ds), @ds);
info := allocmem(infosize);
fillchar(info^, sizeof(TBitmapInfo), #0);
with info^.bmiHeader do
begin
bisize := sizeof(TBitmapInfoHeader);
biWidth := ds.dsBm.bmWidth;
biheight := ds.dsBm.bmHeight;
biplanes := 1;
bibitcount := 1;
gap := bytesperscanline(biwidth, 1, 32);
imgsize := gap * abs(biheight);
bits := allocmem(imgsize);
dc := createcompatibledc(0);
getdibits(dc, msk, 0, biheight, bits, info^, DIB_RGB_COLORS);
deletedc(dc);
result := creatergndatafromBmpbits(bits, biwidth, biheight, Gap);
end;
freemem(info, infosize);
freemem(bits, imgsize);
end;
function CreateRgnFromHBmp(DC: HDC; Left, Top, width, height: Integer; TransColor: TColor; x, y: Integer): HRGN;
begin
result := RgnDataToRgn(CreateRgnDataFromHBmp(DC, Left, Top, Width, Height, TransColor), x, y);
end;
function CreateRgnDataFromHBmp(DC: HDC; Left, Top, Width, Height: Integer; TransColor: TColor): PRgnDataHeader;
var
monoDC : HDC;
MonoImg: HBITMAP;
sav: THandle;
begin
if (width = 0) or (height = 0) then
begin
result := nil;
exit;
end;
monodc := createcompatibledc(0);
monoimg := createbitmap(width, height, 1, 1, nil);
sav := selectobject(monodc, monoimg);
setbkcolor(dc, colortorgb(transcolor));
bitblt(monodc, 0, 0, width, height, dc, Left, Top, SRCCOPY);
selectobject(monodc, sav);
deletedc(monodc);
result := creatergndatafrommask(monoimg);
deleteobject(monoimg);
end;
function CreateRgnFromBmp(Bmp: TBitmap; TransColor: TColor; x, y: Integer): HRGN;
begin
result := RgnDataToRgn(CreateRgnDataFromBmp(Bmp, TransColor), x, y);
end;
function CreateRgnDataFromBmp(Bmp: TBitmap; TransColor: TColor): PRgnDataHeader;
var
monoDC, ScreenDC: HDC;
MonoImg: HBITMAP;
sav: THandle;
begin
if (bmp.Width=0) or (bmp.Height = 0) then
begin
result := nil;
exit;
end;
screendc := getdc(0);
monodc := createcompatibledc(screendc);
monoimg := createbitmap(bmp.width, bmp.height, 1, 1, nil);
sav := selectobject(monodc, monoimg);
setbkcolor(bmp.canvas.handle, colortorgb(transcolor));
bitblt(monodc, 0, 0, bmp.width, bmp.height, bmp.canvas.handle, 0, 0, SRCCOPY);
selectobject(monodc, sav);
deletedc(monodc);
releasedc(0, screendc);
result := creatergndatafrommask(monoimg);
deleteobject(monoimg);
end;
{ TRgnForm }
constructor TRgnForm.Create(AComponent: TComponent);
begin
inherited;
FBkBmp := TBitmap.Create;
FBkBmp.OnChange := BmpChanged;
FTransColor := clNone;
AutoSize := True;
end;
destructor TRgnForm.Destroy;
begin
if frgndata <> nil then
freemem(frgndata);
FBkBmp.Free;
inherited;
end;
procedure TRgnForm.BmpChanged(Sender: TObject);
var
c: TColor;
begin
if not (csLoading in ComponentState) then
begin
if frgndata <> nil then
begin
freemem(frgndata);
frgndata := nil;
end;
if (fbkbmp.Width<>0) and (fbkbmp.Height<>0) then
begin
if ftranscolor = clNone then
c := fbkbmp.Canvas.Pixels[0, fbkbmp.Height-1]
else
c := ftranscolor;
frgndata := creatergndatafrombmp(fbkbmp, c);
if (parent<>nil) and parent.HandleAllocated then
resetrgn;
adjustsize;
end;
end;
end;
procedure TRgnForm.DefineProperties(Filer: TFiler);
begin
inherited;
filer.DefineBinaryProperty('RgnData', ReadRgnData, WriteRgnData, FRgnData<>nil);
end;
procedure TRgnForm.Paint;
begin
Canvas.Draw(0, 0, fbkbmp);
end;
procedure TRgnForm.ReadRgnData(Reader: TStream);
var
Stm: TBufferStream;
l: Integer;
begin
stm := TBufferStream.Create;
stm.LoadFromStream(reader);
stm.Read(l, 4);
getmem(frgndata, l);
if l > 0 then
begin
stm.Read(frgndata^, l);
end;
bkbmp.LoadFromStream(stm);
stm.Free;
end;
procedure TRgnForm.WriteRgnData(Writer: TStream);
var
Stm: TBufferStream;
l: Integer;
begin
stm := TBufferStream.Create;
l := length(string(frgndata)) and $7FFFFFF8;
stm.Write(l, 4);
if l > 0 then
stm.Write(frgndata^, l);
fbkbmp.SaveToStream(stm);
stm.SaveToStream(writer);
stm.Free;
end;
procedure TRgnForm.SetBkBmp(const Value: TBitmap);
begin
FBkBmp.Assign(value);
end;
procedure TRgnForm.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
moved: Boolean;
begin
moved := (ALeft <> Left) or (ATop <> Top);
if (fbkbmp.Width<>0) and (fbkbmp.Height<>0) then
inherited setbounds(aleft, atop, fbkbmp.Width, fbkbmp.Height)
else
inherited setbounds(aleft, atop, awidth, aheight);
if moved then
resetrgn;
end;
procedure TRgnForm.SetParent(AParent: TWinControl);
begin
inherited;
resetrgn;
end;
procedure TRgnForm.SetTransColor(const Value: TColor);
begin
if FTransColor <> Value then
begin
FTransColor := Value;
bmpchanged(self);
end;
end;
procedure TRgnForm.SetDesignEffect(const Value: Boolean);
begin
if FDesignEffect <> Value then
begin
FDesignEffect := Value;
resetrgn;
end;
end;
procedure TRgnForm.ResetRgn;
var
r: HRGN;
rct: TRect;
begin
if (parent<>nil) then
begin
if not parent.HandleAllocated then
parent.HandleNeeded;
if parent.HandleAllocated then
if (frgndata = nil) or ((csDesigning in ComponentState) and not FDesignEffect) then
setwindowrgn(parent.Handle, 0, true)
else begin
rct := Rect(0, 0, Parent.Width, Parent.Height);
parent.Perform(WM_NCCALCSIZE, 0, Integer(@rct));
r := rgndatatorgn(frgndata, rct.Left+Left, rct.Top+Top, false);
setwindowrgn(parent.Handle, r, true);
end;
end;
end;
procedure TRgnForm.AdjustSize;
begin
if csLoading in ComponentState then exit;
if (fbkbmp.Width<>0) and (fbkbmp.Height <> 0) then
setbounds(left, top, fbkbmp.Width, fbkbmp.Height)
else
setbounds(left, top, width, Height);
end;
procedure TRgnForm.Loaded;
begin
inherited;
resetrgn;
end;
procedure TRgnForm.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if (Button = mbLeft) and FAutoDrag then
begin
releasecapture;
parent.perform(WM_SYSCOMMAND, $f012, 0);
end;
end;
procedure TRgnForm.CMDesignHitTest(var Message: TMessage);
begin
inherited;
if FDesignEffect then
message.Result := 1;
end;
{ TImgBorder }
constructor TImgBorder.Create(AOwner: TComponent);
begin
inherited;
ftranscolor := clNone;
fbkimage := TBitmap.Create;
fbkimage.OnChange := imgchanged;
end;
destructor TImgBorder.Destroy;
var
i: Integer;
begin
if fcontrol <> nil then
begin
fcontrol.WindowProc := foldwndproc;
if fcontrol.HandleAllocated and factive then
begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
setwindowrgn(fcontrol.Handle, 0, true);
end;
fcontrol := nil;
end;
for i := 0 to 8 do
if frgns <> nil then
dispose(frgns);
fbkimage.Free;
inherited;
end;
procedure TImgBorder.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineBinaryProperty('RgnData', LoadRgns, SaveRgns, not FBkImage.Empty);
end;
procedure TImgBorder.LoadRgns(Reader: TStream);
var
stm: TBufferStream;
i, l: Integer;
begin
stm := TBufferStream.Create;
stm.LoadFromStream(reader);
for i := 0 to 8 do
begin
stm.Read(l, 4);
if l > 0 then
begin
getmem(frgns, l);
stm.Read(frgns^, l);
end
else frgns := nil;
end;
fbkimage.LoadFromStream(stm);
stm.Free;
end;
procedure TImgBorder.SaveRgns(Writer: TStream);
var
stm: TBufferStream;
i, l: Integer;
begin
stm := TBufferStream.Create;
for i := 0 to 8 do
begin
if frgns <> nil then
l := frgns.nCount * sizeof(TRect)+sizeof(TRgnDataHeader)
else l := 0;
//l := length(string(frgns)) and $7FFFFFF8;
stm.Write(l, 4);
if l > 0 then
stm.Write(frgns^, l);
end;
fbkimage.SaveToStream(stm);
stm.SaveToStream(writer);
stm.Free;
end;
type
TWinControlRef = class(TControl)
public
FAlignLevel: Word;
FBevelEdges: TBevelEdges;
FBevelInner: TBevelCut;
FBevelOuter: TBevelCut;
FBevelKind: TBevelKind;
FBevelWidth: TBevelWidth;
FBorderWidth: TBorderWidth;
FBrush: TBrush;
FDefWndProc: Pointer;
FDockClients: TList;
FDockManager: IDockManager;
FHandle: HWnd;
FImeMode: TImeMode;
FImeName: TImeName;
FObjectInstance: Pointer;
FParentWindow: HWnd;
FTabList: TList;
FControls: TList;
FWinControls: TList;
end;
procedure TImgBorder.NewWndProc(var Message: TMessage);
var
n: Integer;
begin
if fcontrol<>nil then
begin
if factive then
case message.Msg of
WM_NCCREATE:
begin
setwindowrgn(fcontrol.Handle, BuildRgn, true);
fcontrol.Invalidate;
end;
WM_NCPAINT:
if FAffectNC then
PaintNCBdr;
WM_WINDOWPOSCHANGING:
with PWindowPos(message.LParam)^ do
begin
foldwndproc(message);
if (flags and (SWP_NOSIZE or SWP_SHOWWINDOW or SWP_HIDEWINDOW) = 0) then
begin
if cx < fnosizes[0]+fnosizes[2] then
cx := fnosizes[0]+fnosizes[2];
if cy < fnosizes[1]+fnosizes[3] then
cy := fnosizes[1]+fnosizes[3];
end;
message.Result := 0;
exit;
end;
WM_NCHITTEST:
if FHookHitTest then
begin
foldwndproc(message);
if message.Result in [HTCLIENT, HTBORDER] then
message.Result := CheckHitTest(point(message.LParamLo, message.LParamHi), message.Result);
exit;
end;
WM_SIZE:
begin
setwindowrgn(fcontrol.Handle, BuildRgn, true);
fcontrol.Invalidate;
end;
WM_ERASEBKGND:
if FSetAsBkgnd then
PaintBk(message.WParam);
WM_PAINT:
if (fdesignface <> nil) then
with TWinControlRef(fcontrol) do
if (fcontrols.Count > 0) and (fcontrols[0] <> pointer(fdesignface)) then
begin
n := fcontrols.IndexOf(pointer(fdesignface));
if n > 0 then
fcontrols.Delete
;fcontrols.Insert(0, pointer(fdesignface));
end;
CM_DESIGNHITTEST:
begin
foldwndproc(message);
if message.Result = 0 then
if IsSysBtn(message.LParamLo, message.LParamHi) or
(CheckDesignHitTest(point(message.LParamLo, message.LParamHi)) <> HTCLIENT) then
message.Result := 1;
exit;
end;
end;
foldwndproc(message);
end;
end;
type
TControlRef = class(TControl);
procedure TImgBorder.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if (operation = opRemove) then
if AComponent = FDesignFace then
begin
FDesignFace := nil
end
else if (AComponent = FControl) then
begin
{fcontrol.WindowProc := foldwndproc;
if fcontrol.HandleAllocated and factive then
begin
if fsetasbkgnd then
begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
end;
setwindowrgn(fcontrol.Handle, 0, true);
end;
if fdesignface <> nil then
freeandnil(fdesignface);}
control := nil;
end
else if AComponent = FBtns[0] then
begin
TControlRef(FBtns[0]).OnClick := nil;
FBtns[0] := nil;
end
else if AComponent = FBtns[1] then
begin
TControlRef(FBtns[1]).OnClick := nil;
FBtns[1] := nil;
end
else if AComponent = FBtns[2] then
begin
TControlRef(FBtns[2]).OnClick := nil;
FBtns[2] := nil;
end
end;
procedure TImgBorder.SetActive(const Value: Boolean);
begin
if FActive <> Value then
begin
FActive := Value;
if (fcontrol <> nil) then
if value then
begin
if fsetasbkgnd then
begin
foldbs := fcontrol.Brush.Style;
foldbc := fcontrol.Brush.Color;
fcontrol.Brush.Style := bsClear;
end;
if fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
if (ffacestyle = fsRunTime) or ((ffacestyle = fsDesignTime) and (csDesigning in ComponentState)) then
begin
FDesignFace := TDesignImgBdrFace.Create(self);
FDesignFace.FreeNotification(self);
FDesignFace.Parent := fcontrol;
fcontrol.DoubleBuffered := true;
FDesignFace.Align := alClient;
FDesignFace.Visible := true;
end;
end
else begin
if fsetasbkgnd then
begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
end;
if fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, 0, true);
fcontrol.Invalidate;
end;
if FDesignFace <> nil then
FreeAndNil(FDesignFace);
end;
end;
end;
procedure TImgBorder.SetAffectNC(const Value: Boolean);
begin
if FAffectNC <> Value then
begin
FAffectNC := Value;
if (fcontrol <> nil) and fcontrol.HandleAllocated then
if factive then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
end;
end;
procedure TImgBorder.SetBkImage(const Value: TBitmap);
begin
FBkImage.Assign(value);
end;
procedure TImgBorder.SetControl(const Value: TWinControl);
begin
if FControl <> Value then
begin
if fcontrol <> nil then
begin
fcontrol.WindowProc := foldwndproc;
if (fcontrol is TCustomForm) and ((FBtns[0] <> nil) or (FBtns[1] <> nil) or (FBtns[2] <> nil)) then
begin
if FBtns[0] <> nil then
TControlRef(FBtns[0]).OnClick := nil;
if FBtns[1] <> nil then
TControlRef(FBtns[1]).OnClick := nil;
if FBtns[2] <> nil then
TControlRef(FBtns[2]).OnClick := nil;
end;
if fcontrol.HandleAllocated then
begin
if fsetasbkgnd then
begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
end;
setwindowrgn(fcontrol.Handle, 0, true);
end;
if FDesignFace <> nil then
freeandnil(fdesignface);
end;
FControl := Value;
if fcontrol <> nil then
begin
foldwndproc := fcontrol.WindowProc;
fcontrol.WindowProc := NewWndProc;
if fcontrol is TCustomForm then
begin
if FBtns[0] <> nil then
TControlRef(FBtns[0]).OnClick := ClickSysBtn;
if FBtns[1] <> nil then
TControlRef(FBtns[1]).OnClick := ClickSysBtn;
if FBtns[2] <> nil then
TControlRef(FBtns[2]).OnClick := ClickSysBtn;
end;
if factive then
begin
if fsetasbkgnd then
begin
foldbs := fcontrol.Brush.Style;
foldbc := fcontrol.Brush.Color;
fcontrol.Brush.Style := bsClear;
end;
if fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
if (ffacestyle = fsRunTime) or ((ffacestyle = fsDesignTime) and (csDesigning in ComponentState)) then
begin
FDesignFace := TDesignImgBdrFace.Create(self);
FDesignFace.FreeNotification(self);
FDesignFace.Parent := fcontrol;
fcontrol.DoubleBuffered := true;
FDesignFace.Align := alClient;
FDesignFace.Visible := true;
end;
end;
end;
end;
end;
procedure TImgBorder.SetHitTestSize(const Index, Value: Integer);
begin
FHits[Index] := Value;
end;
procedure TImgBorder.SetNosizeValue(const Index, Value: Integer);
begin
if (FNosizes[Index] <> Value) and (value >= 0) then
begin
FNosizes[Index] := Value;
FAnalyzed := false;
if (fcontrol<>nil) and factive and fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
end;
end;
procedure TImgBorder.SetTransColor(const Value: TColor);
begin
if FTransColor <> Value then
begin
FTransColor := Value;
FAnalyzed := false;
if (fcontrol<>nil) and factive and fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
end;
end;
procedure TImgBorder.ImgChanged(Sender: TObject);
begin
FAnalyzed := false;
if (fcontrol<>nil) and factive and fcontrol.HandleAllocated then
begin
setwindowrgn(fcontrol.Handle, buildrgn, true);
fcontrol.Invalidate;
end;
end;
function TImgBorder.BuildRgn: HRGN;
var
Rct: TRect;
r: HRGN;
i: Integer;
begin
//if not FAnalyzed then
analyzergns;
getwindowrect(fcontrol.Handle, rct);
offsetrect(rct, -rct.left, -rct.Top);
if not faffectnc then
fcontrol.Perform(WM_NCCALCSIZE, 0, Integer(@Rct));
frects[0] := bounds(rct.Left, rct.Top, fnosizes[0], fnosizes[1]);
frects[1] := bounds(rct.Right - fnosizes[2], rct.Top, fnosizes[2], fnosizes[1]);
frects[2] := bounds(rct.Right - fnosizes[2], rct.Bottom - fnosizes[3], fnosizes[2], fnosizes[3]);
frects[3] := bounds(rct.Left, rct.Bottom - fnosizes[3], fnosizes[0], fnosizes[3]);
frects[4] := rect(frects[0].right, frects[0].Top, frects[1].left, frects[0].bottom);
frects[5] := rect(frects[1].left, frects[1].bottom, frects[1].right, frects[2].top);
frects[6] := rect(frects[3].right, frects[3].top, frects[2].left, frects[3].bottom);
frects[7] := rect(frects[0].left, frects[0].bottom, frects[0].right, frects[3].top);
frects[8] := rect(frects[0].right, frects[0].bottom, frects[2].left, frects[2].top);
result := 0;
for i := 0 to 8 do
begin
r := getpartrgn(i);
if r <> 0 then
begin
if result <> 0 then
begin
combinergn(result, result, r, RGN_OR);
deleteobject(r);
end
else result := r;
end;
end;
end;
function TImgBorder.GetPartRgn(Index: Integer): HRGN;
begin
result := 0;
if frgns[index] <> nil then
if index < 4 then
result := rgndatatorgn(frgns[index], frects[index].Left, frects[index].Top, false)
else
result := resizergndatatorgn(frgns[index],
(frects[index].Right - frects[index].Left) / (fsrcs[index].Right - fsrcs[index].Left),
(frects[index].Bottom - frects[index].Top) / (fsrcs[index].Bottom - fsrcs[index].Top),
frects[index].Left, frects[index].Top);
end;
function TImgBorder.CheckHitTest(Pt: TPoint; DefRst: Integer): Integer;
var
rct: TRect;
c: TControl;
begin
if (fcontrol is TCustomForm) and (TForm(fcontrol).WindowState = wsMaximized) then
begin
result := DefRst;
exit;
end;
getwindowrect(fcontrol.Handle, rct);
dec(pt.X, rct.Left);
dec(pt.Y, rct.Top);
if ptinrect(rect(frects[0].Left, frects[0].Top, frects[1].Right, frects[0].Top+fHits[1]), pt) then
result := HTTOP
else if ptinrect(rect(frects[0].Left, frects[0].Top, frects[0].Left+fhits[0], frects[3].Bottom), pt) then
result := HTLEFT
else if ptinrect(rect(frects[1].Right - fhits[2], frects[1].Top, frects[1].Right, frects[2].Bottom), pt) then
result := HTRIGHT
else if ptinrect(rect(frects[0].Left, frects[3].Bottom-fhits[3], frects[1].Right, frects[3].Bottom), pt) then
result := HTBOTTOM
else if ptinrect(rect(frects[0].Left, frects[0].Top, frects[1].Right, frects[0].Top+fhits[4]), pt) then
begin
offsetrect(rct, -rct.Left, -rct.Top);
fcontrol.Perform(WM_NCCALCSIZE, 0, Integer(@Rct));
dec(pt.X, rct.Left);
dec(pt.Y, rct.Top);
c := fcontrol.ControlAtPos(pt, false);
if (c = nil) or (c = fdesignface) then
result := HTCAPTION
else
result := DefRst;
end
else result := DefRst;
end;
procedure TImgBorder.PaintBk(DC: HDC);
var
rct: TRect;
begin
getwindowrect(fcontrol.Handle, rct);
offsetrect(rct, -rct.left, -rct.Top);
//if faffectnc then
fcontrol.Perform(WM_NCCALCSIZE, 0, Integer(@Rct));
drawbk(dc, -rct.Left, -rct.Top);
end;
procedure TImgBorder.drawBk(DC: HDC; OffX, OffY: Integer);
var
i: Integer;
begin
for i := 0 to 8 do
if not isrectempty(frects) then
stretchblt(dc, frects.Left+offx, frects.Top+offy, frects.Right - frects.Left,
frects.Bottom - frects.Top, fbkimage.Canvas.Handle, fsrcs.Left,
fsrcs.Top, fsrcs.Right - fsrcs.Left, fsrcs.Bottom - fsrcs.Top,
SRCCOPY);
end;
procedure TImgBorder.PaintNCBdr;
var
rct: TRect;
dc: HDC;
begin
if faffectnc then
begin
getwindowrect(fcontrol.Handle, rct);
offsetrect(rct, -rct.Left, -rct.Top);
dc := getwindowdc(fcontrol.Handle);
fcontrol.Perform(WM_NCCALCSIZE, 0, Integer(@Rct));
if excludecliprect(dc, rct.Left, rct.Top, rct.Right, rct.Bottom) <> NULLREGION then
drawbk(dc, 0, 0);
releasedc(fcontrol.Handle, dc);
end;
end;
procedure TImgBorder.AnalyzeRgns;
var
i: Integer;
c: TColor;
begin
if not fanalyzed then
begin
c := ftranscolor;
for i := 0 to 8 do
begin
if frgns <> nil then
begin
dispose(frgns);
frgns := nil;
end;
fsrcs := rect(0,0,0,0);
end;
if not fbkimage.Empty then
begin
if c = clNone then
c := fbkimage.Canvas.Pixels[0, fbkimage.Height - 1];
fsrcs[0] := rect(0, 0, fnosizes[0], fnosizes[1]);
fsrcs[1] := bounds(fbkimage.Width - fnosizes[2], 0, fnosizes[2], fnosizes[1]);
fsrcs[2] := bounds(fbkimage.Width - fnosizes[2], fbkimage.Height - fnosizes[3], fnosizes[2], fnosizes[3]);
fsrcs[3] := bounds(0, fbkimage.Height - fnosizes[3], fnosizes[0], fnosizes[3]);
fsrcs[4] := bounds(fnosizes[0], 0, fbkimage.Width - fnosizes[0] - fnosizes[2], fnosizes[1]);
fsrcs[5] := bounds(fbkimage.Width - fnosizes[2], fnosizes[1], fnosizes[2], fbkimage.Height - fnosizes[1] - fnosizes[3]);
fsrcs[6] := bounds(fnosizes[0], fbkimage.Height - fnosizes[3], fbkimage.Width - fnosizes[0] - fnosizes[2], fnosizes[3]);
fsrcs[7] := bounds(0, fnosizes[1], fnosizes[0], fbkimage.Height - fnosizes[1]- fnosizes[3]);
fsrcs[8] := bounds(fnosizes[0], fnosizes[1], fbkimage.Width - fnosizes[0] - fnosizes[2], fbkimage.Height - fnosizes[1] - fnosizes[3]);
end;
for i := 0 to 8 do
if not isrectempty(fsrcs) then
frgns := creatergndatafromhbmp(fbkimage.Canvas.Handle, fsrcs.Left, fsrcs.Top, fsrcs.Right - fsrcs.Left,
fsrcs.Bottom - fsrcs.Top, c);
fanalyzed := true;
end;
end;
function TImgBorder.CheckDesignHitTest(Pt: TPoint): Integer;
var
c: TControl;
begin
c := fcontrol.ControlAtPos(pt, true, true);
if (c = nil) or (c = fdesignface) then
result := checkhittest(fcontrol.ClientToScreen(pt), HTCLIENT)
else result := HTCLIENT;
end;
procedure TImgBorder.SetFaceStyle(const Value: TFaceStyle);
begin
if FFaceStyle <> Value then
begin
FFaceStyle := Value;
if (value = fsRunTime) or ((value = fsDesignTime) and (csDesigning in ComponentState)) then
begin
if (fcontrol<>nil) and active and fcontrol.HandleAllocated and (fdesignface = nil) then
begin
fdesignface := TDesignImgBdrFace.Create(self);
fdesignface.FreeNotification(self);
fcontrol.DoubleBuffered := true;
fdesignface.Parent := fcontrol;
fdesignface.Align := alClient;
fdesignface.Visible := true;
end;
end
else if fdesignface <> nil then
freeandnil(fdesignface);
end;
end;
procedure TImgBorder.SetSetAsBkgnd(const Value: Boolean);
begin
if FSetAsBkgnd <> Value then
begin
FSetAsBkgnd := Value;
if (fcontrol <> nil) and factive then
if value then
begin
foldbs := fcontrol.Brush.Style;
foldbc := fcontrol.Brush.Color;
fcontrol.Brush.Style := bsClear;
end
else begin
fcontrol.Brush.Color := foldbc;
fcontrol.Brush.Style := foldbs;
end;
end;
end;
procedure TImgBorder.SetBtns(const Index: Integer; const Value: TControl);
begin
if FBtns[Index] <> Value then
begin
if (FBtns[Index] <> nil) and (FControl is TCustomForm) then
TControlRef(FBtns[Index]).OnClick := nil;
FBtns[Index] := Value;
if (FBtns[Index] <> nil) and (FControl is TCustomForm) then
TControlRef(FBtns[Index]).OnClick := ClickSysBtn;
end;
end;
procedure TImgBorder.ClickSysBtn(Sender: TObject);
begin
if fcontrol is TCustomForm then
if Sender = FBtns[0] then // min
if application.MainForm = fcontrol then
application.Minimize
else TForm(fcontrol).WindowState := wsMinimized
else if Sender = FBtns[1] then // max
if TForm(fcontrol).WindowState = wsMaximized then
TForm(fcontrol).WindowState := wsNormal
else
TForm(fcontrol).WindowState := wsMaximized
else if Sender = FBtns[2] then // close
TForm(fcontrol).Close;
end;
function TImgBorder.IsSysBtn(x, y: Integer): Boolean;
var
c: TControl;
begin
result := false;
if fcontrol is TCustomForm then
begin
c := fcontrol.ControlAtPos(point(x, y), false, true);
if c <> nil then
result := (c = fbtns[0]) or (c = fbtns[1]) or (c = fbtns[2]);
end;
end;
{ TDesignImgBdrFace }
constructor TDesignImgBdrFace.Create(AOwner: TComponent);
begin
inherited;
controlstyle := [csNoStdEvents];
self.SetSubComponent(true);
end;
{procedure TDesignImgBdrFace.CMDesignHitTest(var Message: TMessage);
begin
if TImgBorder(Owner).CheckDesignHitTest(point(Message.LParamLo, Message.LParamHi)) <> HTCLIENT then
message.Result := 1
else message.Result := 0;
end;}
procedure TDesignImgBdrFace.Paint;
begin
if (parent<>nil) then
TImgBorder(Owner).PaintBk(Canvas.Handle);
end;
end.