创建不规则形状的Control

最近接了一个单子，开发一个产品的教学软件（汗，程序员开始变成美工了，没办法要混饭吃，只好堕落了）。按照领导（老婆）的说法，工期紧、任务重，所以，只能拿起我最擅长的Delphi作为开发利器，Delphi好是好，最困难的在于界面设计，这样的软件，脸面最重要，但是，Delphi的弱点（别砸我，我话还没有说完）也在于此，灰不拉鸡的界面在现在几乎等同于Dos的黑底白字一样不受欢迎（郁闷，这不是很好吗！整天装嫩，什么都要Q，连软件都不放过，发廊妹妹说自己昨天18岁生日，你也要装！）。言归正传，看来只能用TImage混合PhotoShop、CoreDraw做出来的图片了。做出来一看，还行，就是不会动，要动？很简单，弄个透明的Bebvl当作按钮不就可以啦！不行啊！都是方的怎么行，人家的机器上的按钮都是很复杂的形状，都是方的怎么半呢？有办法，我不说，我不说干吗写这篇文章？开玩笑。其实很简单，如果不是TwinControl继承下来的，而是从TControl继承下来的可以做到对于鼠标动作在任意形状区域的响应，TwinControl当然也可以，我比较懒啦！TwinControl怎么作，MSDN上肯定有，无非就是把窗口和一个区域联系起来（关键API连接，SetWindowRgn），当然也可以是响应消息，不过那样窗口不能透明了。Tcontrol实现起来更加简单，关键在一个消息，CM_HITTEST，这是Delphi自定义的消息，别去MSDN查，肯定查不到。这个消息表示测试x,Y是不是落在Control的范围里面，如果你响应这个消息，那么你就可以告诉VCL鼠标是不是落在你的Control范围里面，这样你就可以在矩形之中定义你的Control的任意形状，只要你在响应这个消息的时候“告诉”VCL。这个消息的格式：

TWMNCHitTest = packed record
Msg: Cardinal;
Unused: Longint;
case Integer of
0: (
XPos: Smallint;
YPos: Smallint);
1: (
Pos: TSmallPoint;
Result: Longint);
end;

TCMHitTest = TWMNCHitTest;
这个消息其实就是一个Windows消息的翻版。Result表示返回值，HTCLIENT就是在，HTNOWHERE就是不在。还有其他很多的返回值，有兴趣你可以根据情况多返回一些（没事找事:)）。

下面就是这个组件的源代码，这个组件只能接受Bitmap，根据0,0的像素决定透明色彩，同时决定区域，Transparent属性表明是否透明，影响鼠标动作区域，不透明就是整个矩形。当鼠标移动进入的时候，图像颜色会变成高亮，高亮的算法是RGB色彩空间转换到HSL色彩空间，HSL色彩空间，H表示色度，S表示饱和度，L表示亮度，所以改变L就可以改变整个图片的亮度，改变以后再转换回RGB色彩空间。祝各位愉快。

unit HotTrackImage;

interface

uses
SysUtils, Classes, Controls, Windows, Messages, Graphics, Math, Forms;

const
MaxPixelCount = 65536;

type
pRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..MaxPixelCount - 1] of TRGBTriple;

THotTrackEvent = procedure(Sender:TObject) of object;

THotTrackImage = class(TGraphicControl)
private
{ Private declarations }
{FSearching:Boolean;
FSearching1:Boolean;
FSearching2:Boolean;
FSearching3:Boolean;
FSearching4:Boolean;
FSearching5:Boolean;
FSearching6:Boolean;}
FPicture: TBitmap;
FHotPicture: TBitmap;
FOnProgress: TProgressEvent;
FStretch: Boolean;
FCenter: Boolean;
FIncrementalDisplay: Boolean;
FDrawing: Boolean;
FProportional: Boolean;
FOnHotTrackLeave: THotTrackEvent;
FOnHotTrackEnter: THotTrackEvent;
FIsHoted: Boolean;
FLightAdd: Integer;
FTransparent: Boolean;
function GetCanvas: TCanvas;
procedure SetHoted(Hoted:Boolean);
procedure DoLightBitmap;
procedure PictureChanged(Sender: TObject);
procedure SetCenter(Value: Boolean);
procedure SetPicture(Value: TBitmap);
procedure SetStretch(Value: Boolean);
procedure SetProportional(Value: Boolean);
procedure SetLightAdd(const Value: Integer);
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
//procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
procedure SetTransparent(const Value: Boolean);
protected
{ Protected declarations }
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
function DestRect: TRect;
function DoPaletteChange: Boolean;
function GetPalette: HPALETTE; override;
procedure Paint; override;
procedure Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
//procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
// X, Y: Integer); override;
//procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
// X, Y: Integer); override;
//procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure DoHotTrackEnter;
procedure DoHotTrackLeave;
//procedure Click; override;
//procedure DblClick; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas: TCanvas read GetCanvas;
published
{ Published declarations }
property Align;
property Anchors;
property AutoSize;
property Center: Boolean read FCenter write SetCenter default False;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
property ParentShowHint;
property Picture: TBitmap read FPicture write SetPicture;
property PopupMenu;
property Proportional: Boolean read FProportional write SetProportional default false;
property ShowHint;
property Stretch: Boolean read FStretch write SetStretch default False;
property Visible;
property IsHoted:Boolean read FIsHoted;
property LightAdd:Integer read FLightAdd write SetLightAdd;
property Transparent: Boolean read FTransparent write SetTransparent default True;
property onClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
property OnStartDock;
property OnStartDrag;
property OnHotTrackEnter:THotTrackEvent read FOnHotTrackEnter write FOnHotTrackEnter;
property OnHotTrackLeave:THotTrackEvent read FOnHotTrackLeave write FOnHotTrackLeave;
end;

procedure Register;

implementation

procedure HSLtoRGB(H, S, L: Double; var R, G, B: Integer);
//hsl颜色空间到rgb空间的转换
var //类似于返回多个值的函数
Sat, Lum: Double;
begin
R := 0;
G := 0;
B := 0;
if (H < 360) and (H >= 0) and (S <= 100) and (S >= 0) and (L <= 100) and (L
>=
0) then
begin
if H <= 60 then
begin
R := 255;
G := Round((255 / 60) * H);
B := 0;
end
else if H <= 120 then
begin
R := Round(255 - (255 / 60) * (H - 60));
G := 255;
B := 0;
end
else if H <= 180 then
begin
R := 0;
G := 255;
B := Round((255 / 60) * (H - 120));
end
else if H <= 240 then
begin
R := 0;
G := Round(255 - (255 / 60) * (H - 180));
B := 255;
end
else if H <= 300 then
begin
R := Round((255 / 60) * (H - 240));
G := 0;
B := 255;
end
else if H < 360 then
begin
R := 255;
G := 0;
B := Round(255 - (255 / 60) * (H - 300));
end;

Sat := Abs((S - 100) / 100);
R := Round(R - ((R - 128) * Sat));
G := Round(G - ((G - 128) * Sat));
B := Round(B - ((B - 128) * Sat));

Lum := (L - 50) / 50;
if Lum > 0 then
begin
R := Round(R + ((255 - R) * Lum));
G := Round(G + ((255 - G) * Lum));
B := Round(B + ((255 - B) * Lum));
end
else if Lum < 0 then
begin
R := Round(R + (R * Lum));
G := Round(G + (G * Lum));
B := Round(B + (B * Lum));
end;
end;
end;

procedure RGBtoHSL(R, G, B: Integer; var H, S, L: Double);
// RGB空间到HSL空间的转换
var
Delta: Double;
CMax, CMin: Double;
Red, Green, Blue, Hue, Sat, Lum: Double;
begin
Red := R / 255;
Green := G / 255;
Blue := B / 255;
CMax := Max(Red, Max(Green, Blue));
CMin := Min(Red, Min(Green, Blue));
Lum := (CMax + CMin) / 2;
if CMax = CMin then
begin
Sat := 0;
Hue := 0;
end
else
begin
if Lum < 0.5 then
Sat := (CMax - CMin) / (CMax + CMin)
else
Sat := (cmax - cmin) / (2 - cmax - cmin);
delta := CMax - CMin;
if Red = CMax then
Hue := (Green - Blue) / Delta
else if Green = CMax then
Hue := 2 + (Blue - Red) / Delta
else
Hue := 4.0 + (Red - Green) / Delta;
Hue := Hue / 6;
if Hue < 0 then
Hue := Hue + 1;
end;
H := (Hue * 360);
S := (Sat * 100);
L := (Lum * 100);
end;

procedure Register;
begin
RegisterComponents(''Custom'', [THotTrackImage]);
end;

{ THotTrackImage }

function THotTrackImage.CanAutoSize(var NewWidth,
NewHeight: Integer): Boolean;
begin
Result := True;
if not (csDesigning in ComponentState) or (FPicture.Width > 0) and
(FPicture.Height > 0) then
begin
if Align in [alNone, alLeft, alRight] then
NewWidth := FPicture.Width;
if Align in [alNone, alTop, alBottom] then
NewHeight := FPicture.Height;
end;
end;

{procedure THotTrackImage.Click;

procedure ReSearch;
var
I:Integer;
TempHK:TControl;
begin
for I:=0 to Parent.ControlCount-1 do
begin
TempHK:=Parent.Controls[I];
if TempHK is THotTrackImage then
begin
if not THotTrackImage(TempHK).FSearching3 then
begin
THotTrackImage(TempHK).Click();
Exit;
end;
end;
end;
end;

begin
if not FSearching3 then
begin
FSearching3:=True;
try
if FIsHoted then
begin
inherited;
end else
begin
ReSearch;
end;
finally
FSearching3:=False;
end;
end;
end;}

{procedure THotTrackImage.CMHintShow(var Message: TMessage);

procedure ReSearch;
var
I:Integer;
TempHK:TControl;
begin
for I:=0 to Parent.ControlCount-1 do
begin
TempHK:=Parent.Controls[I];
if TempHK is THotTrackImage then
begin
if not THotTrackImage(TempHK).FSearching5 then
begin
if THotTrackImage(TempHK).ShowHint then
begin
TCMHintShow(Message).HintInfo^.HintStr:=THotTrackImage(TempHK).Hint;
THotTrackImage(TempHK).CMHintShow(Message);
Exit;
end;
end;
end;
end;
end;

begin
if not FSearching5 then
begin
FSearching5:=True;
try
if FIsHoted then
begin
inherited;
end else
begin
ReSearch;
end;
finally
FSearching5:=False;
end;
end;
end;}

procedure THotTrackImage.CMMouseEnter(var Message: TMessage);
begin
inherited;
SetHoted(True);
end;

procedure THotTrackImage.CMMouseLeave(var Message: TMessage);
begin
inherited;
SetHoted(False);
end;

constructor THotTrackImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
FPicture := TBitmap.Create;
FHotPicture := TBitmap.Create;
FPicture.Transparent:=False;
FPicture.TransparentMode:=tmAuto;
FHotPicture.Transparent:=False;
FHotPicture.TransparentMode:=tmAuto;
FPicture.OnChange := PictureChanged;
FPicture.OnProgress := Progress;
Height := 105;
Width := 105;
FIsHoted:=False;
FLightAdd:=8;
FTransparent:=True;
{FSearching:=False;
FSearching1:=False;
FSearching2:=False;
FSearching3:=False;
FSearching4:=False;
FSearching5:=False;
FSearching6:=False;}
end;

{procedure THotTrackImage.DblClick;

procedure ReSearch;
var
I:Integer;
TempHK:TControl;
begin
for I:=0 to Parent.ControlCount-1 do
begin
TempHK:=Parent.Controls[I];
if TempHK is THotTrackImage then
begin
if not THotTrackImage(TempHK).FSearching4 then
begin
THotTrackImage(TempHK).DblClick();
Exit;
end;
end;
end;
end;

begin
if not FSearching4 then
begin
FSearching4:=True;
try
if FIsHoted then
begin
inherited;
end else
begin
ReSearch;
end;
finally
FSearching4:=False;
end;
end;
end;}

function THotTrackImage.DestRect: TRect;
var
w, h, cw, ch: Integer;
xyaspect: Double;
begin
w := Picture.Width;
h := Picture.Height;
cw := ClientWidth;
ch := ClientHeight;
if Stretch or (Proportional and ((w > cw) or (h > ch))) then
begin
if Proportional and (w > 0) and (h > 0) then
begin
xyaspect := w / h;
if w > h then
begin
w := cw;
h := Trunc(cw / xyaspect);
if h > ch then // woops, too big
begin
h := ch;
w := Trunc(ch * xyaspect);
end;
end
else
begin
h := ch;
w := Trunc(ch * xyaspect);
if w > cw then // woops, too big
begin
w := cw;
h := Trunc(cw / xyaspect);
end;
end;
end
else
begin
w := cw;
h := ch;
end;
end;

with Result do
begin
Left := 0;
Top := 0;
Right := w;
Bottom := h;
end;

if Center then
OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);
end;

destructor THotTrackImage.Destroy;
begin
FPicture.Free;
FHotPicture.Free;
inherited Destroy;
end;

procedure THotTrackImage.DoHotTrackEnter;
begin
if Assigned(FOnHotTrackEnter) then
FOnHotTrackEnter(Self);
end;

procedure THotTrackImage.DoHotTrackLeave;
begin
if Assigned(FOnHotTrackLeave) then
FOnHotTrackEnter(Self);
end;

procedure THotTrackImage.DoLightBitmap;
var
x, y, ScanlineBytes: integer;
p: prgbtriplearray;
RVALUE, bvalue, gvalue: integer;
hVALUE, sVALUE, lVALUE: Double;
begin
FHotPicture.Assign(FPicture);
if not FHotPicture.Empty then
begin
FHotPicture.PixelFormat:=pf24bit;
p := FHotPicture.ScanLine[0];
ScanlineBytes := integer(FHotPicture.ScanLine[1]) - integer(FHotPicture.ScanLine[0]);
for y := 0 to FHotPicture.Height - 1 do
begin
for x := 0 to FHotPicture.Width - 1 do
begin
RVALUE := p[x].rgbtRed;
gVALUE := p[x].rgbtGreen;
bVALUE := p[x].rgbtBlue;
RGBtoHSL(RVALUE, gVALUE, bVALUE, hVALUE, sVALUE, lVALUE);
lVALUE := min(100, lVALUE + FLightAdd);
HSLtorgb(hVALUE, sVALUE, lVALUE, rVALUE, gVALUE, bVALUE);
p[x].rgbtRed := RVALUE;
p[x].rgbtGreen := gVALUE;
p[x].rgbtBlue := bVALUE;
end;
inc(integer(p), ScanlineBytes);
end;
end;
end;

function THotTrackImage.DoPaletteChange: Boolean;
var
ParentForm: TCustomForm;
Tmp: TGraphic;
begin
Result := False;
Tmp := FPicture;
if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
(Tmp.PaletteModified) then
begin
if (Tmp.Palette = 0) then
Tmp.PaletteModified := False
else
begin
ParentForm := GetParentForm(Self);
if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
begin
if FDrawing then
ParentForm.Perform(wm_QueryNewPalette, 0, 0)
else
PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
Result := True;
Tmp.PaletteModified := False;
end;
end;
end;
end;

function THotTrackImage.GetCanvas: TCanvas;
begin
Result := FPicture.Canvas;
end;

function THotTrackImage.GetPalette: HPALETTE;
begin
Result := FPicture.Palette;
end;

{procedure THotTrackImage.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);

procedure ReSearch;
var
P:TPoint;
I:Integer;
TempHK:TControl;
begin
for I:=0 to Parent.ControlCount-1 do
begin
TempHK:=Parent.Controls[I];
if TempHK is THotTrackImage then
begin
if not THotTrackImage(TempHK).FSearching1 then
begin
P.X:=X;
P.Y:=Y;
P:=THotTrackImage(TempHK).ScreenToClient(ClientToScreen(P));
THotTrackImage(TempHK).MouseDown(Button,Shift,P.X,P.Y);
Exit;
end;
end;
end;
end;

begin
if not FSearching1 then
begin
FSearching1:=True;
try
if (X>=0)and(X<FPicture.Width)and(Y>=0)and(Y<FPicture.Height) then
begin
if FPicture.Canvas.Pixels[X,Y]=FPicture.Canvas.Pixels[0,0] then
begin
ReSearch;
end else
begin
inherited;
end;
end else
begin
ReSearch;
end;
finally
FSearching1:=False;
end;
end;
end;}

{procedure THotTrackImage.MouseMove(Shift: TShiftState; X, Y: Integer);

procedure ReSearch;
var
P:TPoint;
I:Integer;
TempHK:TControl;
begin
for I:=0 to Parent.ControlCount-1 do
begin
TempHK:=Parent.Controls[I];
if TempHK is THotTrackImage then
begin
if not THotTrackImage(TempHK).FSearching then
begin
P.X:=X;
P.Y:=Y;
P:=THotTrackImage(TempHK).ScreenToClient(ClientToScreen(P));
THotTrackImage(TempHK).MouseMove(Shift,P.X,P.Y);
Exit;
end;
end;
end;
end;

procedure Slicen;
var
I:Integer;
TempHK:TControl;
begin
for I:=0 to Parent.ControlCount-1 do
begin
TempHK:=Parent.Controls[I];
if TempHK<>Self then
begin
THotTrackImage(TempHK).SetHoted(False);
end;
end;
end;

begin
if not FSearching then
begin
FSearching:=True;
try
if (X>=0)and(X<FPicture.Width)and(Y>=0)and(Y<FPicture.Height) then
begin
if FPicture.Canvas.Pixels[X,Y]=FPicture.Canvas.Pixels[0,0] then
begin
SetHoted(False);
ReSearch;
end else
begin
SetHoted(True);
Slicen;
inherited;
end;
end else
begin
SetHoted(False);
ReSearch;
end;
finally
FSearching:=False;
end;
end;
end;}

{procedure THotTrackImage.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);

procedure ReSearch;
var
P:TPoint;
I:Integer;
TempHK:TControl;
begin
for I:=0 to Parent.ControlCount-1 do
begin
TempHK:=Parent.Controls[I];
if TempHK is THotTrackImage then
begin
if not THotTrackImage(TempHK).FSearching2 then
begin
P.X:=X;
P.Y:=Y;
P:=THotTrackImage(TempHK).ScreenToClient(ClientToScreen(P));
THotTrackImage(TempHK).MouseUp(Button,Shift,P.X,P.Y);
Exit;
end;
end;
end;
end;

begin
if not FSearching2 then
begin
FSearching2:=True;
try
if (X>=0)and(X<FPicture.Width)and(Y>=0)and(Y<FPicture.Height) then
begin
if FPicture.Canvas.Pixels[X,Y]=FPicture.Canvas.Pixels[0,0] then
begin
ReSearch;
end else
begin
inherited;
end;
end else
begin
ReSearch;
end;
finally
FSearching2:=False;
end;
end;
end;}

procedure THotTrackImage.Paint;
var
Save: Boolean;
begin
if csDesigning in ComponentState then
with inherited Canvas do
begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle(0, 0, Width, Height);
end;
Save := FDrawing;
FDrawing := True;
try
with inherited Canvas do
begin
if FIsHoted and not(csDesigning in ComponentState) then
StretchDraw(DestRect, FHotPicture)
else
StretchDraw(DestRect, FPicture);
end;
finally
FDrawing := Save;
end;
end;

procedure THotTrackImage.PictureChanged(Sender: TObject);
begin
Picture.Transparent:=FTransparent;
if AutoSize and (FPicture.Width > 0) and (FPicture.Height > 0) then
SetBounds(Left, Top, FPicture.Width, FPicture.Height);
if FTransparent then
ControlStyle := ControlStyle - [csOpaque]
else
ControlStyle := ControlStyle + [csOpaque];
DoLightBitmap;
if DoPaletteChange and FDrawing then Update;
if not FDrawing then Invalidate;
end;

procedure THotTrackImage.Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
const Msg: string);
begin
if FIncrementalDisplay and RedrawNow then
begin
if DoPaletteChange then Update
else Paint;
end;
if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;

procedure THotTrackImage.SetCenter(Value: Boolean);
begin
if FCenter <> Value then
begin
FCenter := Value;
PictureChanged(Self);
end;
end;

procedure THotTrackImage.CMHitTest(var Message: TCMHitTest);
var
X,Y:Integer;
begin
if (Message.XPos>=0)and(Message.XPos<FPicture.Width)and(Message.YPos>=0)and(Message.YPos<FPicture.Height)then
begin
if FTransparent then
begin
X:=Round(Message.XPos*Picture.Height/Height);
Y:=Round(Message.YPos*Picture.Height/Height);
if(FPicture.Canvas.Pixels[X,Y]<>FPicture.Canvas.Pixels[0,0]) then
Message.Result := HTCLIENT
else
Message.Result := HTNOWHERE
end else
Message.Result := HTCLIENT;
end else
Message.Result := HTNOWHERE;
end;

procedure THotTrackImage.SetHoted(Hoted: Boolean);
begin
if FIsHoted<>Hoted then
begin
FIsHoted:=Hoted;
Invalidate;
if Hoted then
begin
//SetCaptureControl(Self);
DoHotTrackEnter;
end else
begin
//SetCaptureControl(nil);
DoHotTrackLeave;
end;
end;
end;

procedure THotTrackImage.SetLightAdd(const Value: Integer);
begin
FLightAdd := Value;
DoLightBitmap;
if FIsHoted then
Invalidate;
end;

procedure THotTrackImage.SetPicture(Value: TBitmap);
begin
if Value<>nil then
begin
Value.Transparent:=FTransparent;
Value.TransparentMode:=tmAuto;
end;
FPicture.Assign(Value);
end;

procedure THotTrackImage.SetProportional(Value: Boolean);
begin
if FProportional <> Value then
begin
FProportional := Value;
PictureChanged(Self);
end;
end;

procedure THotTrackImage.SetStretch(Value: Boolean);
begin
if Value <> FStretch then
begin
FStretch := Value;
PictureChanged(Self);
end;
end;

procedure THotTrackImage.SetTransparent(const Value: Boolean);
begin
if FTransparent<>Value then
begin
FTransparent := Value;
PictureChanged(Self);
end;
end;

end.