unit MyHintWindow;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Math, ExtCtrls;
const DefColFrom: TColor = $00FFFFFF;
DefColTo: TColor = $00F0E5E5;
type
THintStyle = (hsXP, hsVista);
TShowHintType = (stNone, st_LtoR, st_RtoL, st_UtoD, st_DtoU, st_Centr, st_Blend);
type
TVistaHint = class(TComponent)
private
FHintStyle: THintStyle;
FColorFrom, FColorTo: TColor;
FShowingTime: Cardinal;
FHintPause, FHintHidePause: Cardinal;
FShowHintType: TShowHintType;
FDefaultColors: boolean;
FirstChanged: boolean;
FFont: TFont;
procedure SetHintPause(const Value: Cardinal);
procedure SetHintHidePause(const Value: Cardinal);
procedure SetHintStyle(const Value: THintStyle);
procedure SetColorFrom(const Value: TColor);
procedure SetColorTo(const Value: TColor);
procedure SetDefaultColors(const Value: boolean);
procedure SetFont(const Value: TFont);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ColorsToVistaStyle;
procedure ColorsToXPStyle;
published
property HintStyle: THintStyle read FHintStyle write SetHintStyle;
property ColorFrom: TColor read FColorFrom write SetColorFrom;
property ColorTo: TColor read FColorTo write SetColorTo;
property ShowType: TShowHintType read FShowHintType write FShowHintType;
property ShowingTime: Cardinal read FShowingTime write FShowingTime;
property HintPause: Cardinal read FHintPause write SetHintPause;
property HintHidePause: Cardinal read FHintHidePause write SetHintHidePause;
property DefaultColors: boolean read FDefaultColors write SetDefaultColors;
property Font: TFont read FFont write SetFont;
end;
type
TMyHintWindow = class(THintWindow)
private
FHint: TVistaHint;
FBitmap: TBitmap;
FRegion: THandle;
procedure FreeRegion;
protected
procedure CreateParams (var Params: TCreateParams); override;
procedure Paint; override;
procedure Erase(var Message: TMessage); message WM_ERASEBKGND;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ActivateHint(Rect: TRect; const AHint: String); Override;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TVistaHint]);
end;
constructor TMyHintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBitmap := TBitmap.Create;
FBitmap.PixelFormat := pf24bit;
end;
procedure TMyHintWindow.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = $20000;
begin
inherited;
Params.Style := Params.Style - WS_BORDER;
Params.WindowClass.Style := Params.WindowClass.style or CS_DROPSHADOW;
end;
procedure TMyHintWindow.ActivateHint(Rect: TRect; const AHint: String);
var
i: Integer;
aniType: Cardinal;
begin
FHint:= nil;
with Application.MainForm do
begin
for I:= 0 to ComponentCount - 1 do
if Components[i] is TVistaHint then
begin
FHint := TVistaHint(Components[i]);
Break;
end;
end;
if not Assigned(FHint) then Exit;
Caption := AHint;
Canvas.Font := Screen.HintFont;
FBitmap.Canvas.Font := Screen.HintFont;
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, DT_CALCRECT or DT_NOPREFIX);
case FHint.FHintStyle of
hsVista:
begin
Width := (Rect.Right - Rect.Left) + 16;
Height := (Rect.Bottom - Rect.Top) + 10;
end;
hsXP:
begin
Width := (Rect.Right - Rect.Left) + 10;
Height := (Rect.Bottom - Rect.Top) + 6;
end;
end;
FBitmap.Width := Width;
FBitmap.Height := Height;
Left := Rect.Left;
Top := Rect.Top;
FreeRegion;
case FHint.FShowHintType of
st_LtoR: aniType:= AW_HOR_POSITIVE;
st_RtoL: aniType:= AW_HOR_NEGATIVE;
st_UtoD: aniType:= AW_VER_POSITIVE;
st_DtoU: aniType:= AW_VER_NEGATIVE;
st_Centr: aniType:= AW_CENTER;
st_Blend: aniType:= AW_BLEND;
else aniType:= AW_ACTIVATE;
end;
if FHint.FHintStyle = hsVista then
begin
with Rect do
FRegion := CreateRoundRectRgn(1, 1, Width, Height, 3, 3);
if FRegion <> 0 then
SetWindowRgn(Handle, FRegion, True);
end;
AnimateWindowProc(Handle, FHint.FShowingTime, aniType);
SetWindowPos(Handle, HWND_TOPMOST, Left, Top, 0, 0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
end;
destructor TMyHintWindow.Destroy;
begin
FBitmap.Free;
FreeRegion;
inherited;
end;
procedure TMyHintWindow.Erase(var Message: TMessage);
begin
Message.Result := 0;
end;
procedure TMyHintWindow.FreeRegion;
begin
if FRegion <> 0 then
begin
SetWindowRgn(Handle, 0, True);
DeleteObject(FRegion);
FRegion := 0;
end;
end;
procedure DrawGradientVertical(Canvas: TCanvas; Rect: TRect; FromColor, ToColor: TColor);
var
i, Y: Integer;
R, G, B: Byte;
begin
i := 0;
for Y := Rect.Top to Rect.Bottom - 1 do
begin
R := GetRValue(FromColor) + Ceil(((GetRValue(ToColor) - GetRValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
G := GetGValue(FromColor) + Ceil(((GetGValue(ToColor) - GetGValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
B := GetBValue(FromColor) + Ceil(((GetBValue(ToColor) - GetBValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
Canvas.Pen.Color := RGB(R, G, B);
Canvas.MoveTo(Rect.Left, Y);
Canvas.LineTo(Rect.Right, Y);
Inc(i);
end;
end;
procedure TMyHintWindow.Paint;
var
CaptionRect: TRect;
begin
if not Assigned(FHint) then exit;
case FHint.FHintStyle of
hsVista:
begin
DrawGradientVertical(FBitmap.Canvas, GetClientRect, FHint.FColorFrom,
FHint.FColorTo);
with FBitmap.Canvas do
begin
Font:= FHint.FFont;
Brush.Style := bsClear;
Pen.Color := RGB(118, 118, 118);
RoundRect(1, 1, Width - 1, Height - 1, 6, 6);
RoundRect(1, 1, Width - 1, Height - 1, 3, 3);
end;
CaptionRect := Rect(8, 5, Width, Height);
end;
hsXP:
begin
with FBitmap.Canvas do
begin
Font:= FHint.FFont;
Brush.Style := bsSolid;
Brush.Color := FHint.FColorFrom;
Pen.Color := RGB(0, 0, 0);
Rectangle(0, 0, Width, Height);
end;
CaptionRect := Rect(5, 3, Width, Height);
end;
end;
DrawText(FBitmap.Canvas.Handle, PChar(Caption), Length(Caption), CaptionRect, DT_WORDBREAK or DT_NOPREFIX);
BitBlt(Canvas.Handle, 0, 0, Width, Height, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TVistaHint.ColorsToVistaStyle;
begin
FHintStyle:= hsVista;
FColorFrom:= DefColFrom;
FColorTo:= DefColTo;
end;
procedure TVistaHint.ColorsToXPStyle;
begin
FHintStyle:= hsXP;
FColorFrom:= clInfoBk;
end;
constructor TVistaHint.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FColorFrom:= DefColFrom;
FColorTo:= DefColTo;
FHintStyle:= hsVista;
FShowHintType:= st_Blend;
FShowingTime:= 300;
FHintPause:= 500;
FHintHidePause:= 5000;
FDefaultColors:= false;
FFont:= TFont.Create;
FirstChanged:= false;
if not (csDesigning in ComponentState) then
begin
with Application do
begin
HintWindowClass := TMyHintWindow;
HintPause := FHintPause;
HintHidePause := FHintHidePause;
end;
end;
end;
destructor TVistaHint.Destroy;
begin
FFont.Free;
inherited;
end;
procedure TVistaHint.SetColorFrom(const Value: TColor);
begin
if not FDefaultColors then
FColorFrom := Value;
FirstChanged:= true;
end;
procedure TVistaHint.SetColorTo(const Value: TColor);
begin
if not FDefaultColors then
FColorTo := Value;
FirstChanged:= true;
end;
procedure TVistaHint.SetDefaultColors(const Value: boolean);
begin
FDefaultColors := Value;
if Value then
case FHintStyle of
hsXP: ColorsToXPStyle;
hsVista: ColorsToVistaStyle;
end;
end;
procedure TVistaHint.SetFont(const Value: TFont);
begin
FFont.Assign(Value);
end;
procedure TVistaHint.SetHintHidePause(const Value: Cardinal);
begin
FHintHidePause := Value;
if not (csDesigning in ComponentState) then
with Application do HintHidePause := FHintHidePause;
end;
procedure TVistaHint.SetHintPause(const Value: Cardinal);
begin
FHintPause := Value;
if not (csDesigning in ComponentState) then
with Application do HintPause := FHintPause;
end;
procedure TVistaHint.SetHintStyle(const Value: THintStyle);
begin
FHintStyle := Value;
if not FirstChanged then
case Value of
hsXP: FColorFrom:= clInfoBk;
hsVista: FColorFrom:= DefColFrom
end;
end;
end.
20.10.2008, 13:49
Hint под XP Vista
Линейный вид
