最近接了一个单子，开发一个产品的教学软件（汗，程序员开始变成美工了，没办法要混饭吃，只好堕落了）。按照领导（老婆）的说法，工期紧、任务重，所以，只能拿起我最擅长的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.
