Recently, I received a single child, developed a product teaching software (sweat, programmers began to become a beautiful work, no way to eat, I have to fall.). According to the leader (wife), the work is tight, the task is heavy, so I can only pick up my best as the best-in-one, Delphi is good, the most difficult is the interface design, such software, the face is the most important, but , Delphi's weakness (don't smash me, I haven't finished it yet), it is here, the interface of the gray smashing is almost equivalent to DOS, is not popular (depressed, this is not very good! It is tender, everything is q, even the software does not let go, the hair salon sister said that he was 18th birthday, you also met!). It is only possible to mix Photoshop, Coredraw, made by TIMAGE. When you come out, it's okay, it will not move, should you move? Very simple, get a transparent BEBVL as a button! Can not do it! How is the party, the buttons on the machine's machine are very complicated, how is it half? There is a way, I don't say, don't I say this article? joke. In fact, it is very simple. If it is not TWINControl inherited, but inherited from tControl, you can do respond to the mouse action in any shape area, TWINCONTROL is of course, I am more lazy! How to make TwinControl, there is definitely on MSDN, nothing to link the window and a zone (key API connection, setWindowRGN), of course, can also be a response message, but that window cannot be transparent. TControl is more simple, the key is a message, cm_hittest, this is a Delphi custom message, don't go to MSDN, I can't find it. This message indicates that the test x, y is not in the range of Control, if you respond to this message, then you can tell the VCL mouse inside your Control range so you can define your in the rectangle. Arbitrary shape of Control, as long as you "tell" VCL when you respond to this message. The format of this message:
TWMNCHITTEST = PACKED Record Msg: Cardinal; unused: longint; case integer of 0: (xpos: smallint; ypos: smallint); 1: (POS: tsmallpoint; result: longint);
TCMHITTEST = twmnchittest; this message is actually a turn version of a Windows message. Result indicates that the return value is htclient, htnowhere is not. There are still many other return values. Interested that you can return some (nothing to look for :)).
Below is the source code of this component, this component can only accept Bitmap, determine the transparent color according to the pixels of 0,0, and the TRANSPARENT attribute indicates whether the area is transparent, affecting the mouse action area, is opaque is the entire rectangle. When the mouse moves, the image color will become highlighted, and the highlighted algorithm is RGB color space transition to HSL color space, HSL color space, H represents chromaticity, S represents the saturation, L represents brightness, so change L You can change the brightness of the entire picture, and change it back to RGB color space after changing. I wish you all a happy. Unit HottrackImage;
Interface
Uses Sysutils, Classes, Controls, Windows, Messages, Graphics, Math, Forms
Const maxpixelcount = 65536;
Type prgtriPleArray = ^ trgbtriPleArray; trgbtriPEARRAY = array [0..maxpixelcount - 1] of trgtriple; 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: TMESSA ge); 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: TPROGRESSSTAGE ;ECENTDONE: BYTE; RedRaw: 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 FinderDisplay Write Finder DEFAULT FALSE; Property Parentshow Hint; 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 color space to RGB space conversion var // Similar functions of returns multiple values 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; 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)); 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; ELSE IF H <360 THEN BEGIN R: = 255; G: = 0; B: = ROUND (255 - (255/60) * (H - 300));
SAT: = ABS ((S - 100) / 100); R: = ROUND (R - ((((R - 128) * SAT); g: = ROUND (((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); Else if Lum <0 THEN BEGIN R: = Round (R (R * LUM)); g: = ROUND (G (g * lum)); b: = ROUND (B (B * LUM)); end; end;
Procedure RGBTOHSL (R, G, B: Integer; VAR H, S, L: Double); // RGB Space to HSL Space Translation 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 dam, sat: = 0; hue: = 0; 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 the 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);
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: = ftive.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;
Begin if not fsearching3: = true; tryness; end; fin; 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; setTed (TRUE);
Procedure ThottrackImage.cmmouseeleave (Var Message: TMessage); Begin inherited; set;
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: = FTRANSPARENT: = true; {fsearch: = 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;
begin if not FSearching4 then begin FSearching4: = True; try if FIsHoted then begin inherited; end else begin ReSearch; end; finally FSearching4:; end; = False end; end;} function THotTrackImage.DestRect: TRect; var w, h, CW, CH: Integer; Begin W: = Picture.Width; H: = Picture.Height; CW: = ClientWidth; CH: = ClientHeight; if Stretch or ("ProPortional and ((H) OR (H > ch)) The 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; ELSE BEGIN H: = CH; w: = trunc (ch * xyaspect); if W > cw life // woops, TOO BIG BEGIN W: = CW; h: = trunc (cw / xyaspect); end; end; end else begin w: = cw; h: = CH; 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; fhotputure.free; inherited destroy;
Procedure ThottrackImage.dohottrackenter; Begin If Assigned (FONHOTTRACKENTER) THEN FONHOTTRACKENTER (Self);
Procedure ThottrackImage.dohottrackleave; Begin IF Assigned (FONHOTTRACKLEVE) THEN FONHOTTRACKENTER (Self);
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 , LValue, Lvalue; Lvalue: = min (100, Lvalue Flightd); HSLTORGB (HValue, Svalue, Lvalue, Rvalue, Gvalue, Bvalue); P [x] .RGBTRED: = RVALUE; p [x ] .rgbtgreen: = gvalue; p [x] .RGBTBLUE: = BVALUE; END; INC (P), ScanlineBytes); end; end; end; function technology: boolean; var Parentf, Function THOTTRACKIMAGE.DOALETTECHANGE ORM: TCUSTOMFORM ;TMP: TGRAPHIC; Begin Result: = false; TMP: = fPicture; if Visible and (NOT (CSLoading In ComponentState)) 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;
Function ThottrackImage.getcanvas: Tcanvas; Begin Result: = ftive.canvas; end; function technical: hpalette; begin result: = fpicture.palette;
{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 The begin PX: = x; py: = y; p: = ThottrackImage (Temphk); ThottRackImage (Temphk) .MOUsedown (Button, Shift, PX, PY); End; end;
Begin if not fsearching1: = true; try if (x> = 0) AND (y> = 0) And (y {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) .fsearchning the begin PX: = X; PY: = Y; P: = ThottrackImage (Temphk); ThottRackImage (Temphk) .MouseMove (Shift, PX, PY); EXIT; END; End; End; End; Var i: integer; temphk: tcontrol; begin for i: = 0 to piert.controlcount-1 do begin tempHK: = parent.controls [i]; if Temphk <> Self the startTrackImage (Temphk) .SETHOTED (FALSE); END; End; Begin if not fsearching the begin fsearch: = true; try if (x> = 0) and (y> = 0) and (y {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 The begin PX: = x; py: = y; p: = ThottrackImage (Temphk). ScreentOClient (Clienttoscreen (p)); ThottrackImage (Temphk) .MouseUp (Button, Shift, PX, PY); exit; End; end; end; end; begin if not fsearching2 the begin fsearchding2: = true; try if (x> = 0) AND (x 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, RedRaw, R, MSG); Procedure ThottrackImage.SetCenter (Value: Boolean); Begin IF Fcenter <> Value Then Begin Fcenter: = Value; PictureChanged (Self); Procedure ThottrackImage.cmhittest (VAR message: tcmhittest); VAR X, Y: Integer; Begin IF (Message.XPOS> = 0) AND (Message.ypos> = 0) and (Message. . Ypos 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 technology (const value: integer); begin flightd: = value; DolightBitMap; if FishTed the invalidate; Procedure ThottrackImage.SetPicture (Value: Tbitmap); Begin if Value <> nil dam value.transparent: = ftransparent; value.transparentmode: = tMAUTO; END; fpicture.assign (Value); Procedure ThottrackImage.SetProportional (Value: Boolean); Begin IF FPROPORTIONAL <> VALUE THEN BEGIN FPROPOR: = VALUE; PictureChanged (Self); end; Procedure Thottrackimage.setstretch (Value: Boolean); Begin IF Value <> fstretch The begin Fstretch: = Value; PictureChanged (Self); End; Procedure ThottrackImage.SetTransparent (const value: boolean); Begin if ftransparent <> value dam ftransparent: = value; PictureChanged (Self); end; End.
