|
#1
|
|||
|
|||
Hint под XP Vista
Здрасте!!!!
Вот представляю на показ созданный мною компонент TVistaHint. Конечно, я понимаю что таких компонентов "море", но прошу заценить. Отзывы, которые очень жду, прошу писать на аську: 412636666. Вот код: Код:
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 { Private declarations } FHint: TVistaHint; FBitmap: TBitmap; FRegion: THandle; procedure FreeRegion; protected { Protected declarations } procedure CreateParams (var Params: TCreateParams); override; procedure Paint; override; procedure Erase(var Message: TMessage); message WM_ERASEBKGND; public { Public declarations } 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; { TMyHintWindow } 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.Color := clGray;} 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.Color := clBlack;} 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; { TVistaHint } 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. |
#2
|
|||
|
|||
А маленький Example можно?
|
#3
|
|||
|
|||
Цитата:
|
#4
|
|||
|
|||
Затестил. При изменении размера шрифта, рамка остается старых размеров и не видно ничего...
|
#5
|
|||
|
|||
Цитата:
Благодору за тест, здесь исходник с исправлением: Код:
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 { Private declarations } FHint: TVistaHint; FBitmap: TBitmap; FRegion: THandle; procedure FreeRegion; protected { Protected declarations } procedure CreateParams (var Params: TCreateParams); override; procedure Paint; override; procedure Erase(var Message: TMessage); message WM_ERASEBKGND; public { Public declarations } 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; { TMyHintWindow } 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;} Canvas.Font := FHint.FFont; FBitmap.Canvas.Font := FHint.FFont; 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.Color := clGray;} 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.Color := clBlack;} 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; { TVistaHint } 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. |
#6
|
|||
|
|||
Ну и еще. Я не знаю, глюк это или нет, но если на форме несколько элементов у которых включен Hint, то эффект у хинта появляется только у первого элемента. На остальных оно показывается без эффектов.
|
#7
|
|||
|
|||
У меня все работает нормально
|
#8
|
|||
|
|||
Созданный Rouse http://rouse.drkb.ru/components.php#fwhint, содранный мной у Rouse'а, содранный тобой у меня http://www.delphisources.ru/pages/so...int-style.html
|